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 if(parj(200).eq.1.) then
3169 CALL PYSHOWQ(IPU3,IPU4,QMAX)
3172 CALL PYSHOW(IPU3,IPU4,QMAX)
3174 ELSEIF(ISET(ISUB).EQ.11) THEN
3179 C...Allow possibility for user to abort event generation.
3181 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
3182 IF(IVETO.EQ.1) GOTO 100
3184 C...Decay of final state resonances.
3186 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
3187 IF(MINT(51).EQ.1) GOTO 100
3191 C...Multiple interactions - PYTHIA 6.3 intermediate style.
3192 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
3193 IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
3195 IF(MINT(51).EQ.1) GOTO 100
3198 C...Beam remnant flavour and colour assignments - new scheme.
3200 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3202 IF(MINT(51).EQ.1) GOTO 100
3204 C...Primordial kT and beam remnant momentum sharing - new scheme.
3206 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3208 IF(MINT(51).EQ.1) GOTO 100
3209 IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
3211 C...Multiple interactions - PYTHIA 6.2 style.
3212 ELSEIF(MINT(111).NE.12) THEN
3213 IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
3218 C...Hadron remnants and primordial kT.
3219 CALL PYREMN(IPU1,IPU2)
3220 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3222 IF(MINT(51).EQ.1) GOTO 100
3225 ELSEIF(ISUB.NE.99) THEN
3226 C...Diffractive and elastic scattering.
3230 C...DIS scattering (photon flux external).
3232 IF(MINT(51).EQ.1) GOTO 100
3235 C...Check that no odd resonance left undecayed.
3237 IF(MSTP(111).GE.1) THEN
3239 DO 150 I=MINT(84)+1,NFIX
3240 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3241 & K(I,2).NE.22) THEN
3243 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3245 IF(MINT(51).EQ.1) GOTO 100
3251 C...Boost hadronic subsystem to overall rest frame.
3252 C..(Only relevant when photon inside lepton beam.)
3253 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3255 C...Recalculate energies from momenta and masses (if desired).
3256 IF(MSTP(113).GE.1) THEN
3257 DO 160 I=MINT(83)+1,N
3258 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3259 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3264 C...Colour reconnection before string formation
3265 IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
3267 C...Rearrange partons along strings, check invariant mass cuts.
3269 IF(MSTP(111).LE.0) MSTJ(14)=-1
3270 CALL PYPREP(MINT(84)+1)
3272 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3276 IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
3277 IF (MINT(51).EQ.1) GOTO 100
3278 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3279 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3280 DO 190 I=MINT(84)+1,N
3281 IF(K(I,2).EQ.94) THEN
3282 DO 180 I1=I+1,MIN(N,I+10)
3283 IF(K(I1,3).EQ.I) THEN
3284 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3285 IF(K(I1,3).EQ.0) THEN
3286 DO 170 II=MINT(84)+1,I-1
3287 IF(K(II,2).EQ.K(I1,2)) THEN
3288 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3289 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3292 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3300 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3301 IF(MSTP(125).EQ.0) MINT(4)=0
3302 DO 210 I=MINT(83)+1,N
3303 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3305 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3306 IF(K(I1,3).EQ.I) K(I,5)=I1
3312 C...Introduce separators between sections in PYLIST event listing.
3313 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3316 ELSEIF(IPILE.EQ.1) THEN
3323 C...Go back to lab frame (needed for vertices, also in fragmentation).
3326 C...Set nonvanishing production vertex (optional).
3327 IF(MSTP(151).EQ.1) THEN
3329 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3330 & SIN(PARU(2)*PYR(0))
3332 DO 240 I=MINT(83)+1,N
3334 V(I,J)=V(I,J)+VTX(J)
3339 C...Perform hadronization (if desired).
3340 IF(MSTP(111).GE.1) THEN
3342 IF(MSTU(24).NE.0) GOTO 100
3344 IF(MSTP(113).GE.1) THEN
3346 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3347 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3350 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3352 C...Store event information and calculate Monte Carlo estimates of
3353 C...subprocess cross-sections.
3354 260 IF(IPILE.EQ.1) CALL PYDOCU
3356 C...Set counters for current pileup event and loop to next one.
3358 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3359 IF(MSTU70.LT.10) THEN
3364 MINT(84)=N+MSTP(126)
3365 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3368 C...Generic information on pileup events. Reconstruct missing history.
3369 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3373 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3377 C...Transform to the desired coordinate frame.
3378 280 CALL PYFRAM(MSTP(124))
3383 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3384 &1X,'Execution stopped.')
3389 C*********************************************************************
3392 C...Administers the generation of a high-pT event via calls to
3393 C...a number of subroutines for the new multiple interactions and
3394 C...showering framework.
3398 C...Double precision and integer declarations.
3399 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3400 IMPLICIT INTEGER(I-N)
3401 INTEGER PYK,PYCHGE,PYCOMP
3403 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3404 COMMON/PYCTAG/NCT,MCT(4000,2)
3405 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3406 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3407 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3408 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3409 COMMON/PYINT1/MINT(400),VINT(400)
3410 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3411 COMMON/PYINT4/MWID(500),WIDS(500,5)
3412 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3413 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
3414 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
3415 & XMI(2,240),PT2MI(240),IMISEP(0:240)
3416 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
3417 & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
3421 C...Stop if no subprocesses on.
3422 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3423 WRITE(MSTU(11),5100)
3427 C...Initial values for some counters.
3440 C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3444 C...Let called routines know call is from PYEVNW (not PYEVNT).
3447 C...If variable energies: redo incoming kinematics and cross-section.
3449 IF(MSTP(171).EQ.1) THEN
3451 IF(MSTI(61).EQ.1) THEN
3455 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3459 C...Loop over number of pileup events; check space left.
3460 IF(MSTP(131).LE.0) THEN
3466 DO 300 IPILE=1,NPILE
3467 IF(MINT(84)+100.GE.MSTU(4)) THEN
3469 & '(PYEVNW:) no more space in PYJETS for pileup events')
3470 IF(MSTU(21).GE.1) GOTO 310
3474 C...Generate variables of hard scattering.
3478 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3485 IF(MSTI(61).EQ.1) THEN
3489 IF(MINT(51).EQ.2) RETURN
3491 IF(MSTP(111).EQ.-1) GOTO 290
3493 C...Loopback point if PYPREP fails, especially for junction topologies.
3499 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3500 C...Hard scattering (including low-pT):
3501 C...reconstruct kinematics and colour flow of hard scattering.
3506 IF(MINT(51).EQ.1) GOTO 100
3510 C...Intertwined initial state showers and multiple interactions.
3511 C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3512 C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3514 IF (MINT(47).LT.2) MSTP(61)=0
3516 IF (MINT(50).EQ.0) MSTP(81)=0
3517 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3518 & MINT(111).NE.12) THEN
3519 C...Absolute max pT2 scale for evolution: phase space limit.
3520 PT2MXS=0.25D0*VINT(2)
3521 C...Check if more constrained by ISR and MI max scales:
3522 PT2MXS=MIN(PT2MXS,MAX(VINT(56),VINT(62)))
3523 C...Loopback point in case of failure in evolution.
3527 IF(LOOP.GT.100) THEN
3528 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3529 & //'multiple interactions.')
3534 C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3535 C...once per event. (E.g. compute constants and save variables to be
3536 C...restored later in case of failure.)
3537 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3539 C...Initialize interleaved MI/ISR/JI evolution.
3540 C...PT2MAX: absolute upper limit for evolution - Initialization may
3541 C... return a PT2MAX which is lower than this.
3542 C...PT2MIN: absolute lower limit for evolution - Initialization may
3543 C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3546 CALL PYEVOL(0,PT2MAX,PT2MIN)
3547 IF (MINT(51).EQ.1) GOTO 130
3549 C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3550 C...In principle factorized, so can be stopped and restarted.
3551 C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3552 C PT2MED=MAX(10D0**2,PT2MIN)
3553 C CALL PYEVOL(1,PT2MAX,PT2MED)
3554 C IF (MINT(51).EQ.1) GOTO 160
3556 CALL PYEVOL(1,PT2MAX,PT2MIN)
3557 IF (MINT(51).EQ.1) GOTO 130
3559 C...Finalize interleaved MI/ISR/JI evolution.
3560 CALL PYEVOL(2,PT2MAX,PT2MIN)
3561 IF (MINT(51).EQ.1) GOTO 130
3566 IF(MINT(51).EQ.1) GOTO 100
3567 C...(MINT(52) is actually obsolete in this routine. Set anyway
3568 C...to ensure PYDOCU stable.)
3572 C...Beam remnants - new scheme.
3573 140 IF(MINT(50).EQ.1) THEN
3574 IF (ISUB.EQ.95) MINT(31)=1
3576 C...Beam remnant flavour and colour assignments - new scheme.
3578 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3580 IF(MINT(51).EQ.1) GOTO 100
3582 C...Primordial kT and beam remnant momentum sharing - new scheme.
3584 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3586 IF(MINT(51).EQ.1) GOTO 100
3587 IF (ISUB.EQ.95) MINT(31)=0
3588 ELSEIF(MINT(111).NE.12) THEN
3589 C...Hadron remnants and primordial kT - old model.
3590 C...Happens e.g. for direct photon on one side.
3593 CALL PYREMN(IPU1,IPU2)
3594 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3596 IF(MINT(51).EQ.1) GOTO 100
3597 C...PYREMN does not set colour tags for BRs, so needs to be done now.
3598 DO 160 I=MINT(53)+1,N
3600 IDA=MOD(K(I,KCS),MSTU(5))
3602 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3608 C...Instruct PYPREP to use colour tags
3612 DO 350 I=MINT(84)+1,N
3614 C...Look for coloured string endpoint, or (later) leftover gluon.
3615 IF (K(I,1).NE.3) GOTO 350
3617 IF(KC.EQ.0) GOTO 350
3619 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
3621 C... Pick up loose string end with no previous tag.
3623 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
3624 IF(MCT(I,KCS-3).NE.0) GOTO 350
3626 CALL PYCTTR(I,KCS,I)
3627 IF(MINT(51).NE.0) RETURN
3631 C...Now delete any colour processing information if set (since partons
3632 C...otherwise not FS showered!)
3633 DO 170 I=MINT(84)+1,N
3635 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3636 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3641 C...Showering of final state partons (optional).
3644 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3647 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3648 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3649 C...External processes: handle successive showers.
3650 ELSEIF(ISET(ISUB).EQ.11) THEN
3655 C...Allow possibility for user to abort event generation.
3657 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
3658 IF(IVETO.EQ.1) GOTO 100
3661 C...Decay of final state resonances.
3663 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3665 IF(MINT(51).NE.0) GOTO 100
3668 IF(MINT(51).EQ.1) GOTO 100
3670 ELSEIF(ISUB.NE.99) THEN
3671 C...Diffractive and elastic scattering.
3675 C...DIS scattering (photon flux external).
3677 IF(MINT(51).EQ.1) GOTO 100
3680 C...Check that no odd resonance left undecayed.
3682 IF(MSTP(111).GE.1) THEN
3684 DO 180 I=MINT(84)+1,NFIX
3685 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3686 & K(I,2).NE.22) THEN
3688 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3690 IF(MINT(51).EQ.1) GOTO 100
3696 C...Boost hadronic subsystem to overall rest frame.
3697 C..(Only relevant when photon inside lepton beam.)
3698 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3700 C...Recalculate energies from momenta and masses (if desired).
3701 IF(MSTP(113).GE.1) THEN
3702 DO 190 I=MINT(83)+1,N
3703 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3704 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3709 C...Colour reconnection before string formation
3710 CALL PYFSCR(MINT(84)+1)
3712 C...Rearrange partons along strings, check invariant mass cuts.
3714 IF(MSTP(111).LE.0) MSTJ(14)=-1
3715 CALL PYPREP(MINT(84)+1)
3717 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3721 IF(MINT(51).EQ.1) GOTO 110
3722 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3723 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3724 DO 220 I=MINT(84)+1,N
3725 IF(K(I,2).EQ.94) THEN
3726 DO 210 I1=I+1,MIN(N,I+10)
3727 IF(K(I1,3).EQ.I) THEN
3728 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3729 IF(K(I1,3).EQ.0) THEN
3730 DO 200 II=MINT(84)+1,I-1
3731 IF(K(II,2).EQ.K(I1,2)) THEN
3732 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3733 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3736 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3744 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3745 IF(MSTP(125).EQ.0) MINT(4)=0
3746 DO 240 I=MINT(83)+1,N
3747 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3749 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3750 IF(K(I1,3).EQ.I) K(I,5)=I1
3756 C...Introduce separators between sections in PYLIST event listing.
3757 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3760 ELSEIF(IPILE.EQ.1) THEN
3767 C...Go back to lab frame (needed for vertices, also in fragmentation).
3770 C...Set nonvanishing production vertex (optional).
3771 IF(MSTP(151).EQ.1) THEN
3773 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3774 & SIN(PARU(2)*PYR(0))
3776 DO 270 I=MINT(83)+1,N
3778 V(I,J)=V(I,J)+VTX(J)
3783 C...Perform hadronization (if desired).
3784 IF(MSTP(111).GE.1) THEN
3786 IF(MSTU(24).NE.0) GOTO 100
3788 IF(MSTP(113).GE.1) THEN
3790 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3791 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3794 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3796 C...Store event information and calculate Monte Carlo estimates of
3797 C...subprocess cross-sections.
3798 290 IF(IPILE.EQ.1) CALL PYDOCU
3800 C...Set counters for current pileup event and loop to next one.
3802 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3803 IF(MSTU70.LT.10) THEN
3808 MINT(84)=N+MSTP(126)
3809 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3812 C...Generic information on pileup events. Reconstruct missing history.
3813 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3817 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3821 C...Transform to the desired coordinate frame.
3822 310 CALL PYFRAM(MSTP(124))
3827 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3828 &1X,'Execution stopped.')
3834 C***********************************************************************
3837 C...Prints out information about cross-sections, decay widths, branching
3838 C...ratios, kinematical limits, status codes and parameter values.
3840 SUBROUTINE PYSTAT(MSTAT)
3842 C...Double precision and integer declarations.
3843 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3844 IMPLICIT INTEGER(I-N)
3845 INTEGER PYK,PYCHGE,PYCOMP
3846 C...Parameter statement to help give large particle numbers.
3847 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3848 &KEXCIT=4000000,KDIMEN=5000000)
3849 PARAMETER (EPS=1D-3)
3851 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3852 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3853 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3854 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3855 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3856 COMMON/PYINT1/MINT(400),VINT(400)
3857 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3858 COMMON/PYINT4/MWID(500),WIDS(500,5)
3859 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3860 COMMON/PYINT6/PROC(0:500)
3861 CHARACTER PROC*28, CHTMP*16
3862 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3863 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
3864 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
3865 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
3866 C...Local arrays, character variables and data.
3867 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
3868 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
3869 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
3870 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
3871 CHARACTER*24 CHD0, CHDC(10)
3872 CHARACTER*6 DNAME(3)
3874 &'VMD/hadron * VMD ','VMD/hadron * direct ',
3875 &'VMD/hadron * anomalous ','direct * direct ',
3876 &'direct * anomalous ','anomalous * anomalous '/
3877 DATA DISGA/'e * VMD','e * anomalous'/
3879 &'direct * direct ','direct * VMD ',
3880 &'direct * anomalous ','VMD * direct ',
3881 &'VMD * VMD ','VMD * anomalous ',
3882 &'anomalous * direct ','anomalous * VMD ',
3883 &'anomalous * anomalous ','DIS * VMD ',
3884 &'DIS * anomalous ','VMD * DIS ',
3885 &'anomalous * DIS '/
3887 &'direct * direct ','direct * resolved ',
3888 &'resolved * direct ','resolved * resolved '/
3890 &'direct * hadron ','resolved * hadron '/
3892 &'VMD * hadron ','direct * hadron ',
3893 &'anomalous * hadron ','DIS * hadron '/
3894 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
3895 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
3896 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
3897 &' y*_small ',' eta*_large ',' eta*_small ',
3898 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
3899 &' x_2 ',' x_F ',' cos(theta_hard) ',
3900 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
3901 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
3903 DATA DNAME /'q ','lepton','nu '/
3907 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
3908 WRITE(MSTU(11),5000)
3909 WRITE(MSTU(11),5100)
3910 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
3912 IF(MSUB(I).NE.1) GOTO 100
3913 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
3915 IF(MINT(121).GT.1) THEN
3916 WRITE(MSTU(11),5300)
3917 DO 110 IGA=1,MINT(121)
3919 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3920 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
3922 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3923 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
3925 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
3926 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
3928 ELSEIF(MINT(121).EQ.4) THEN
3929 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
3931 ELSEIF(MINT(121).EQ.2) THEN
3932 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
3935 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
3941 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
3942 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
3944 C...Decay widths and branching ratios.
3945 ELSEIF(MSTAT.EQ.2) THEN
3946 WRITE(MSTU(11),5500)
3947 WRITE(MSTU(11),5600)
3950 CALL PYNAME(KF,CHKF)
3953 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
3954 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
3955 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
3956 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
3957 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
3959 IF(MWID(KC).LE.0) GOTO 140
3960 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
3961 & KF/KSUSY1.EQ.2)) GOTO 140
3963 C...Off-shell branchings.
3966 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
3967 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
3968 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
3969 DO 120 J=1,MDCY(KC,3)
3972 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3973 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3975 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3976 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3977 CALL PYNAME(KFDP(IDC,1),CHD1)
3978 CALL PYNAME(KFDP(IDC,2),CHD2)
3979 IF(KFDP(IDC,3).EQ.0) THEN
3980 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3981 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3982 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3984 CALL PYNAME(KFDP(IDC,3),CHD3)
3985 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3986 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3987 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3990 C...On-shell decays.
3992 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
3994 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
3995 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
3996 & STATE(MDCY(KC,1)),BRFIN
3997 DO 130 J=1,MDCY(KC,3)
4000 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4001 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4003 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4004 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4006 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
4008 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
4009 CALL PYNAME(KFDP(IDC,1),CHD1)
4010 CALL PYNAME(KFDP(IDC,2),CHD2)
4011 IF(KFDP(IDC,3).EQ.0) THEN
4012 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4013 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4014 & CHD2(1:10),WDTP(J),BRPRI,
4015 & STATE(MDME(IDC,1)),BRFIN
4017 CALL PYNAME(KFDP(IDC,3),CHD3)
4018 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4019 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4020 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
4021 & STATE(MDME(IDC,1)),BRFIN
4026 WRITE(MSTU(11),6000)
4028 C...Allowed incoming partons/particles at hard interaction.
4029 ELSEIF(MSTAT.EQ.3) THEN
4030 WRITE(MSTU(11),6100)
4031 CALL PYNAME(MINT(11),CHAU)
4033 CALL PYNAME(MINT(12),CHAU)
4035 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
4039 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
4040 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
4042 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
4045 WRITE(MSTU(11),6400)
4047 C...User-defined limits on kinematical variables.
4048 ELSEIF(MSTAT.EQ.4) THEN
4049 WRITE(MSTU(11),6500)
4050 WRITE(MSTU(11),6600)
4052 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
4053 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
4054 PTHMIN=MAX(CKIN(3),CKIN(5))
4056 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
4057 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
4058 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
4060 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
4063 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
4064 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
4065 WRITE(MSTU(11),7000)
4067 C...Status codes and parameter values.
4068 ELSEIF(MSTAT.EQ.5) THEN
4069 WRITE(MSTU(11),7100)
4070 WRITE(MSTU(11),7200)
4072 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4076 C...List of all processes implemented in the program.
4077 ELSEIF(MSTAT.EQ.6) THEN
4078 WRITE(MSTU(11),7400)
4079 WRITE(MSTU(11),7500)
4081 IF(ISET(I).LT.0) GOTO 180
4082 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4084 WRITE(MSTU(11),7700)
4086 ELSEIF(MSTAT.EQ.7) THEN
4087 WRITE (MSTU(11),8000)
4093 KFSUSY=ILR*KSUSY1+KFSM
4096 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4102 CALL PYNAME(KFSUSY,CHTMP)
4104 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4105 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4106 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4108 DO 200 J=1,MDCY(KC,3)
4110 ID1=IABS(KFDP(IDC,1))
4111 ID2=IABS(KFDP(IDC,2))
4112 IF (KFDP(IDC,3).EQ.0) THEN
4113 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4114 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4115 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4116 NMODES(1)=NMODES(1)+1
4117 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4118 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4119 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4120 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4121 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4122 NMODES(2)=NMODES(2)+1
4123 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4124 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4125 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4126 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4127 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4128 NMODES(3)=NMODES(3)+1
4129 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4130 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4136 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4142 CALL PYNAME(KFSUSY,CHTMP)
4144 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4145 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4147 DO 220 J=1,MDCY(KC,3)
4149 ID1=IABS(KFDP(IDC,1))
4150 ID2=IABS(KFDP(IDC,2))
4151 IF (KFDP(IDC,3).EQ.0) THEN
4152 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4153 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4154 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4155 NMODES(1)=NMODES(1)+1
4156 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4157 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4158 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4159 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4160 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4161 NMODES(2)=NMODES(2)+1
4162 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4163 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4169 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4175 CALL PYNAME(KFSUSY,CHTMP)
4177 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4178 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4180 DO 240 J=1,MDCY(KC,3)
4182 ID1=IABS(KFDP(IDC,1))
4183 ID2=IABS(KFDP(IDC,2))
4184 IF (KFDP(IDC,3).EQ.0) THEN
4185 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4186 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4187 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4188 NMODES(1)=NMODES(1)+1
4189 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4190 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4192 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4193 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4194 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4195 NMODES(2)=NMODES(2)+1
4196 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4197 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4202 C...SNEUTRINO DECAYS
4203 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4210 CALL PYNAME(KFSUSY,CHTMP)
4212 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4213 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4215 DO 260 J=1,MDCY(KC,3)
4217 ID1=IABS(KFDP(IDC,1))
4218 ID2=IABS(KFDP(IDC,2))
4219 IF (KFDP(IDC,3).EQ.0) THEN
4220 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4221 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4222 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4223 NMODES(1)=NMODES(1)+1
4224 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4225 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4227 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4228 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4229 NMODES(2)=NMODES(2)+1
4230 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4231 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4232 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4237 IF (NRVDC.NE.0) THEN
4239 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4240 NMODES(0)=NMODES(0)+NMODES(I)
4248 C...NEUTRALINO DECAYS
4249 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4255 CALL PYNAME(KFSUSY,CHTMP)
4257 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4258 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4259 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4260 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4262 DO 310 J=1,MDCY(KC,3)
4264 ID1=IABS(KFDP(IDC,1))
4265 ID2=IABS(KFDP(IDC,2))
4266 ID3=IABS(KFDP(IDC,3))
4267 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4268 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4269 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4270 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4271 NMODES(1)=NMODES(1)+1
4272 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4273 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4274 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4275 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4276 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4277 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4278 NMODES(2)=NMODES(2)+1
4279 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4280 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4281 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4282 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4283 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4284 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4285 NMODES(3)=NMODES(3)+1
4286 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4287 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4288 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4289 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4290 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4291 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4292 NMODES(4)=NMODES(4)+1
4293 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4294 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4299 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4305 CALL PYNAME(KFSUSY,CHTMP)
4307 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4308 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4309 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4310 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4311 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4313 DO 330 J=1,MDCY(KC,3)
4315 ID1=IABS(KFDP(IDC,1))
4316 ID2=IABS(KFDP(IDC,2))
4317 ID3=IABS(KFDP(IDC,3))
4318 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4319 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4320 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4321 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4322 NMODES(1)=NMODES(1)+1
4323 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4324 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4325 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4326 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4327 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4328 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4329 NMODES(1)=NMODES(1)+1
4330 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4331 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4332 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4333 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4334 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4335 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4336 NMODES(2)=NMODES(2)+1
4337 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4338 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4339 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4340 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4341 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4342 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4343 NMODES(3)=NMODES(3)+1
4344 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4345 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4346 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4347 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4348 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4349 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4350 NMODES(3)=NMODES(3)+1
4351 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4352 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4353 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4354 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4355 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4356 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4357 NMODES(4)=NMODES(4)+1
4358 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4359 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4360 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4361 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4362 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4363 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4364 NMODES(4)=NMODES(4)+1
4365 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4366 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4367 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4368 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4369 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4370 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4371 NMODES(5)=NMODES(5)+1
4372 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4373 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4374 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4375 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4376 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4377 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4378 NMODES(5)=NMODES(5)+1
4379 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4380 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4385 IF (KFSM.EQ.21) THEN
4391 CALL PYNAME(KFSUSY,CHTMP)
4393 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4394 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4395 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4397 DO 350 J=1,MDCY(KC,3)
4399 ID1=IABS(KFDP(IDC,1))
4400 ID2=IABS(KFDP(IDC,2))
4401 ID3=IABS(KFDP(IDC,3))
4402 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4403 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4404 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4405 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4406 NMODES(1)=NMODES(1)+1
4407 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4408 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4409 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4410 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4411 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4412 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4413 NMODES(2)=NMODES(2)+1
4414 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4415 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4416 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4417 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4418 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4419 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4420 NMODES(3)=NMODES(3)+1
4421 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4422 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4427 IF (NRVDC.NE.0) THEN
4429 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4430 NMODES(0)=NMODES(0)+NMODES(I)
4434 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4436 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4437 WRITE (MSTU(11),8500)
4441 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4442 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4446 WRITE (MSTU(11),8600)
4450 C...Formats for printouts.
4451 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4452 &'Events and Cross-sections',1X,9('*'))
4453 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4454 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4455 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4456 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4457 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4458 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4460 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4462 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4463 &1X,'I',34X,'I',28X,'I',12X,'I')
4464 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4465 &1X,'********* Total number of errors, excluding junctions =',
4466 &1X,I8,' *************'/
4467 &1X,'********* Total number of errors, including junctions =',
4468 &1X,I8,' *************'/
4469 &1X,'********* Total number of warnings = ',
4470 &1X,I8,' *************'/
4471 &1X,'********* Fraction of events that fail fragmentation ',
4472 &'cuts =',1X,F8.5,' *********'/)
4473 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4474 &'Ratios',1X,27('*'))
4475 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4476 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4477 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4478 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4480 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4481 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4482 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4483 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4484 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4485 &1P,D10.3,0P,1X,'I')
4486 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4487 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4488 &1P,D10.3,0P,1X,'I')
4489 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4490 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4491 &'Particles at Hard Interaction',1X,7('*'))
4492 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4493 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4494 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4495 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4496 &78('=')/1X,'I',38X,'I',37X,'I')
4497 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4498 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4499 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4500 &'Kinematical Variables',1X,12('*'))
4501 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4502 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4504 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4505 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4506 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4507 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4508 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4509 &'Parameter Values',1X,12('*'))
4510 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4512 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4513 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4515 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4516 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4517 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4518 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4519 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4521 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4522 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4523 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4524 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4525 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4526 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4527 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4528 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4529 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4531 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4532 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4533 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4535 & 1X,'R-Violating couplings',1X/ 1X /
4537 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4538 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4539 & ,'I',15X,'I',15X,'I',15X,'I')
4540 8600 FORMAT(1X,55('='))
4541 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4542 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4547 C*********************************************************************
4550 C...Administers the hard-process generation required for output to the
4551 C...Les Houches event record.
4555 C...Double precision and integer declarations.
4556 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4557 IMPLICIT INTEGER(I-N)
4558 INTEGER PYK,PYCHGE,PYCOMP
4561 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4562 COMMON/PYCTAG/NCT,MCT(4000,2)
4563 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4564 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4565 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4566 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4567 COMMON/PYINT1/MINT(400),VINT(400)
4568 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4569 COMMON/PYINT4/MWID(500),WIDS(500,5)
4570 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4571 &/PYINT1/,/PYINT2/,/PYINT4/
4573 C...HEPEUP for output.
4575 PARAMETER (MAXNUP=500)
4576 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4577 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4578 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4579 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4580 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4583 C...Stop if no subprocesses on.
4584 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4585 WRITE(MSTU(11),5100)
4589 C...Special flags for hard-process generation only.
4595 C...Initial values for some counters.
4606 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4609 C...If variable energies: redo incoming kinematics and cross-section.
4611 IF(MSTP(171).EQ.1) THEN
4613 IF(MSTI(61).EQ.1) THEN
4617 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4621 C...Do not allow pileup events.
4624 C...Generate variables of hard scattering.
4628 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4633 IF(MSTI(61).EQ.1) THEN
4637 IF(MINT(51).EQ.2) RETURN
4640 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4641 C...Hard scattering (including low-pT):
4642 C...reconstruct kinematics and colour flow of hard scattering.
4647 IF(MINT(51).EQ.1) GOTO 100
4651 C...Decay of final state resonances.
4653 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4655 IF(MINT(51).EQ.1) GOTO 100
4658 C...Longitudinal boost of hard scattering.
4659 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4660 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4662 ELSEIF(ISUB.NE.99) THEN
4663 C...Diffractive and elastic scattering.
4667 C...DIS scattering (photon flux external).
4669 IF(MINT(51).EQ.1) GOTO 100
4672 C...Check that no odd resonance left undecayed.
4675 DO 120 I=MINT(84)+1,NFIX
4676 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4677 & K(I,2).NE.22) THEN
4679 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4681 IF(MINT(51).EQ.1) GOTO 100
4686 C...Boost hadronic subsystem to overall rest frame.
4687 C..(Only relevant when photon inside lepton beam.)
4688 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4690 C...Store event information and calculate Monte Carlo estimates of
4691 C...subprocess cross-sections.
4694 C...Transform to the desired coordinate frame.
4695 140 CALL PYFRAM(MSTP(124))
4699 C...Restore special flags for hard-process generation only.
4703 C...Trace colour tags; convert to LHA style labels.
4705 DO 150 I=MINT(84)+1,N
4709 DO 160 I=MINT(84)+1,N
4710 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4711 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4712 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4714 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4715 IDA=MOD(K(I,4),MSTU(5))
4716 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4717 & MCT(IMO,2).NE.0) THEN
4719 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4720 & MCT(IMO,1).NE.0) THEN
4722 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4723 & MCT(IDA,2).NE.0) THEN
4730 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4732 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4733 IDA=MOD(K(I,5),MSTU(5))
4734 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4735 & MCT(IMO,1).NE.0) THEN
4737 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4738 & MCT(IMO,2).NE.0) THEN
4740 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4741 & MCT(IDA,1).NE.0) THEN
4751 C...Put event in HEPEUP commonblock.
4759 IDUP(I)=K(I+MINT(84),2)
4764 ELSEIF(K(I+4,3).EQ.0) THEN
4770 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4773 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4774 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4775 ICOLUP(1,I)=MCT(I+MINT(84),1)
4776 ICOLUP(2,I)=MCT(I+MINT(84),2)
4778 PUP(J,I)=P(I+MINT(84),J)
4784 C...Optionally write out event to disk. Minimal size for time/spin fields.
4785 IF(MSTP(162).GT.0) THEN
4786 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4788 IF(VTIMUP(I).EQ.0D0) THEN
4789 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4790 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4793 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4794 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4799 C...Optional extra line with parton-density information.
4800 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4801 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4804 C...Error messages and other print formats.
4805 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4806 &1X,'Execution stopped.')
4807 5200 FORMAT(1P,2I6,4E14.6)
4808 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
4809 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
4810 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
4815 C*********************************************************************
4818 C...Fills the HEPRUP commonblock with info on incoming beams and allowed
4819 C...processes, and optionally stores that information on file.
4823 C...Double precision and integer declarations.
4824 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4825 IMPLICIT INTEGER(I-N)
4828 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4829 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4830 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4831 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4832 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
4834 C...User process initialization commonblock.
4836 PARAMETER (MAXPUP=100)
4837 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4838 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4839 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4840 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4844 C...Store info on incoming beams.
4854 C...Event weighting strategy.
4857 C...Info on individual processes.
4860 IF(MSUB(ISUB).EQ.1) THEN
4862 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
4863 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
4869 C...Write info to file.
4870 IF(MSTP(161).GT.0) THEN
4871 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
4872 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
4874 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
4879 C...Formats for printout.
4880 5100 FORMAT(1P,2I8,2E14.6,6I6)
4881 5200 FORMAT(1P,3E14.6,I6)
4887 C*********************************************************************
4889 C...Combine the two old-style Pythia initialization and event files
4890 C...into a single Les Houches Event File.
4894 C...Double precision and integer declarations.
4895 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4896 IMPLICIT INTEGER(I-N)
4898 C...PYTHIA commonblock: only used to provide read/write units and version.
4899 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4902 C...User process initialization commonblock.
4904 PARAMETER (MAXPUP=100)
4905 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4906 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4907 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4908 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4912 C...User process event common block.
4914 PARAMETER (MAXNUP=500)
4915 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4916 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4917 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4918 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4919 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4922 C...Lines to read in assumed never longer than 200 characters.
4923 PARAMETER (MAXLEN=200)
4924 CHARACTER*(MAXLEN) STRING
4926 C...Format for reading lines.
4929 WRITE(STRFMT(3:5),'(I3)') MAXLEN
4931 C...Rewind initialization and event files.
4935 C...Write header info.
4936 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
4937 WRITE(MSTP(163),'(A)') '<!--'
4938 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
4939 &MSTP(181),'.',MSTP(182)
4940 WRITE(MSTP(163),'(A)') '-->'
4942 C...Read first line of initialization info and get number of processes.
4943 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
4944 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
4945 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
4947 C...Copy initialization lines, omitting trailing blanks.
4948 C...Embed in <init> ... </init> block.
4949 WRITE(MSTP(163),'(A)') '<init>'
4951 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
4954 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
4955 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4957 WRITE(MSTP(163),'(A)') '</init>'
4959 C...Begin event loop. Read first line of event info or already done.
4960 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
4963 C...Look at first line to know number of particles in event.
4964 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4966 C...Begin an <event> block. Copy event lines, omitting trailing blanks.
4967 WRITE(MSTP(163),'(A)') '<event>'
4969 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
4972 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
4973 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4976 C...Copy trailing comment lines - with a # in the first column - as is.
4977 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
4978 IF(STRING(1:1).EQ.'#') THEN
4981 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
4982 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4986 C..End the <event> block. Loop back to look for next event.
4987 WRITE(MSTP(163),'(A)') '</event>'
4990 C...Successfully reached end of event loop: write closing tag
4991 C...and remove temporary intermediate files (unless asked not to).
4992 300 WRITE(MSTP(163),'(A)') '</event>'
4993 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
4994 IF(MSTP(164).EQ.1) RETURN
4995 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
4996 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
5000 400 WRITE(*,*) ' PYLHEF file joining failed!'
5005 C*********************************************************************
5008 C...Calculates full and effective widths of gauge bosons, stores
5009 C...masses and widths, rescales coefficients to be used for
5010 C...resonance production generation.
5014 C...Double precision and integer declarations.
5015 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5016 IMPLICIT INTEGER(I-N)
5017 INTEGER PYK,PYCHGE,PYCOMP
5018 C...Parameter statement to help give large particle numbers.
5019 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5020 &KEXCIT=4000000,KDIMEN=5000000)
5022 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5023 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5024 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5025 COMMON/PYDAT4/CHAF(500,2)
5027 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5028 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5029 COMMON/PYINT1/MINT(400),VINT(400)
5030 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5031 COMMON/PYINT4/MWID(500),WIDS(500,5)
5032 COMMON/PYINT6/PROC(0:500)
5034 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5035 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
5036 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
5037 C...Local arrays and data.
5038 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
5039 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
5041 C...Born level couplings in MSSM Higgs doublet sector.
5044 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
5046 IF(MSTP(4).EQ.2) THEN
5048 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
5052 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
5053 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
5055 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
5056 WRITE(MSTU(11),5000)
5059 PMAS(35,1)=SQRT(SQMHP)
5060 PMAS(36,1)=SQRT(SQMA)
5061 PMAS(37,1)=SQRT(SQMHC)
5062 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5067 PARU(161)=-SIN(ALSU)/COS(BESU)
5068 PARU(162)=COS(ALSU)/SIN(BESU)
5070 PARU(164)=SIN(BESU-ALSU)
5072 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5073 PARU(171)=COS(ALSU)/COS(BESU)
5074 PARU(172)=SIN(ALSU)/SIN(BESU)
5076 PARU(174)=COS(BESU-ALSU)
5078 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5080 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5081 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5087 PARU(186)=COS(BESU-ALSU)
5088 PARU(187)=SIN(BESU-ALSU)
5092 PARU(195)=COS(BESU-ALSU)
5095 C...Reset effective widths of gauge bosons.
5102 C...Order resonances by increasing mass (except Z0 and W+/-).
5106 IF(KF.EQ.0) GOTO 140
5107 IF(MWID(KC).EQ.0) GOTO 140
5108 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5109 IF(MSTP(1).LE.3) GOTO 140
5111 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5112 IF(IMSS(1).LE.0) GOTO 140
5116 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5117 DO 120 I1=NRES-1,1,-1
5118 IF(PMRES.GE.PMORD(I1)) GOTO 130
5119 KCORD(I1+1)=KCORD(I1)
5120 PMORD(I1+1)=PMORD(I1)
5126 C...Loop over possible resonances.
5131 C...Check that no fourth generation channels on by mistake.
5132 IF(MSTP(1).LE.3) THEN
5133 DO 150 J=1,MDCY(KC,3)
5135 KFA1=IABS(KFDP(IDC,1))
5136 KFA2=IABS(KFDP(IDC,2))
5137 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5138 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5143 C...Check that no supersymmetric channels on by mistake.
5144 IF(IMSS(1).LE.0) THEN
5145 DO 160 J=1,MDCY(KC,3)
5147 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5148 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5149 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5154 C...Find mass and evaluate width.
5156 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5157 IF(MWID(KC).EQ.3) MINT(63)=1
5158 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5161 C...Evaluate suppression factors due to non-simulated channels.
5162 IF(KCHG(KC,3).EQ.0) THEN
5164 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5165 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5166 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5167 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5168 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5173 IF(MWID(KC).EQ.3) MINT(63)=1
5174 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5177 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5178 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5179 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5180 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5181 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5182 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5183 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5184 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5185 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5186 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5187 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5188 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5189 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5192 C...Set resonance widths and branching ratios;
5193 C...also on/off switch for decays.
5194 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5196 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5197 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5198 DO 170 J=1,MDCY(KC,3)
5201 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5206 C...Flavours of leptoquark: redefine charge and name.
5207 KFLQQ=KFDP(MDCY(42,2),1)
5208 KFLQL=KFDP(MDCY(42,2),2)
5209 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5210 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5212 IF(IABS(KFLQL).EQ.13) LL=2
5213 IF(IABS(KFLQL).EQ.15) LL=3
5214 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5215 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5216 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5218 C...Special cases in treatment of gamma*/Z0: redefine process name.
5219 IF(MSTP(43).EQ.1) THEN
5220 PROC(1)='f + fbar -> gamma*'
5221 PROC(15)='f + fbar -> g + gamma*'
5222 PROC(19)='f + fbar -> gamma + gamma*'
5223 PROC(30)='f + g -> f + gamma*'
5224 PROC(35)='f + gamma -> f + gamma*'
5225 ELSEIF(MSTP(43).EQ.2) THEN
5226 PROC(1)='f + fbar -> Z0'
5227 PROC(15)='f + fbar -> g + Z0'
5228 PROC(19)='f + fbar -> gamma + Z0'
5229 PROC(30)='f + g -> f + Z0'
5230 PROC(35)='f + gamma -> f + Z0'
5231 ELSEIF(MSTP(43).EQ.3) THEN
5232 PROC(1)='f + fbar -> gamma*/Z0'
5233 PROC(15)='f + fbar -> g + gamma*/Z0'
5234 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5235 PROC(30)='f + g -> f + gamma*/Z0'
5236 PROC(35)='f + gamma -> f + gamma*/Z0'
5239 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5240 IF(MSTP(44).EQ.1) THEN
5241 PROC(141)='f + fbar -> gamma*'
5242 ELSEIF(MSTP(44).EQ.2) THEN
5243 PROC(141)='f + fbar -> Z0'
5244 ELSEIF(MSTP(44).EQ.3) THEN
5245 PROC(141)='f + fbar -> Z''0'
5246 ELSEIF(MSTP(44).EQ.4) THEN
5247 PROC(141)='f + fbar -> gamma*/Z0'
5248 ELSEIF(MSTP(44).EQ.5) THEN
5249 PROC(141)='f + fbar -> gamma*/Z''0'
5250 ELSEIF(MSTP(44).EQ.6) THEN
5251 PROC(141)='f + fbar -> Z0/Z''0'
5252 ELSEIF(MSTP(44).EQ.7) THEN
5253 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5256 C...Special cases in treatment of WW -> WW: redefine process name.
5257 IF(MSTP(45).EQ.1) THEN
5258 PROC(77)='W+ + W+ -> W+ + W+'
5259 ELSEIF(MSTP(45).EQ.2) THEN
5260 PROC(77)='W+ + W- -> W+ + W-'
5261 ELSEIF(MSTP(45).EQ.3) THEN
5262 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5265 C...Format for error information.
5266 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5267 &'combination'/1X,'Execution stopped!')
5272 C*********************************************************************
5275 C...Identifies the two incoming particles and the choice of frame.
5277 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5279 C...Double precision and integer declarations.
5280 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5281 IMPLICIT INTEGER(I-N)
5282 INTEGER PYK,PYCHGE,PYCOMP
5284 C...User process initialization commonblock.
5286 PARAMETER (MAXPUP=100)
5287 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5288 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5289 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5290 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5295 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5296 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5297 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5298 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5299 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5300 COMMON/PYINT1/MINT(400),VINT(400)
5301 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5303 C...Local arrays, character variables and data.
5304 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5305 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5306 DIMENSION LEN(3),KCDE(39),PM(2)
5307 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5308 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5309 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5310 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5311 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5312 &'nu_taubar ','pi+ ','pi- ','n0 ',
5313 &'nbar0 ','p+ ','pbar- ','gamma ',
5314 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5315 &'xi- ','xi0 ','omega- ','pi0 ',
5316 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5317 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5318 &'k+ ','k- ','ks0 ','kl0 '/
5319 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5320 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5321 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5323 C...Store initial energy. Default frame.
5327 C...Special user process initialization; convert to normal input.
5328 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5330 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5331 CALL PYNAME(IDBMUP(1),CHNAME)
5333 CALL PYNAME(IDBMUP(2),CHNAME)
5337 C...Convert character variables to lowercase and find their length.
5344 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5346 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5352 C...Fix up bar, underscore and charge in particle name (if needed).
5354 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5356 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5359 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5361 CHIDNT(I)='nu_'//CHTEMP(3:7)
5362 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5363 CHIDNT(I)(1:3)='n0 '
5364 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5365 CHIDNT(I)(1:5)='nbar0'
5366 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5367 CHIDNT(I)(1:3)='p+ '
5368 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5369 & CHIDNT(I)(1:2).EQ.'p-') THEN
5370 CHIDNT(I)(1:5)='pbar-'
5371 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5373 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5374 CHIDNT(I)(1:7)='reggeon'
5375 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5376 CHIDNT(I)(1:7)='pomeron'
5380 C...Identify free initialization.
5381 IF(CHCOM(1)(1:2).EQ.'no') THEN
5386 C...Identify incoming beam and target particles.
5389 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5391 PM(I)=PYMASS(MINT(10+I))
5394 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5395 CHTEMP=CHIDNT(I+1)(7:12)//' '
5397 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5399 PM(I)=PYMASS(MINT(140+I))
5403 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5404 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5405 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
5407 C...Identify choice of frame and input energies.
5410 C...Events defined in the CM frame.
5411 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5414 IF(MSTP(122).GE.1) THEN
5415 IF(CHCOM(2)(1:1).NE.'e') THEN
5416 LOFFS=(31-(LEN(2)+LEN(3)))/2
5417 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5418 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5421 LOFFS=(30-(LEN(2)+LEN(3)))/2
5422 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5423 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5426 WRITE(MSTU(11),5200) CHINIT
5427 WRITE(MSTU(11),5300) WIN
5430 C...Events defined in fixed target frame.
5431 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5433 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5434 IF(MSTP(122).GE.1) THEN
5435 LOFFS=(29-(LEN(2)+LEN(3)))/2
5436 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5437 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5438 & ' fixed target'//' '
5439 WRITE(MSTU(11),5200) CHINIT
5440 WRITE(MSTU(11),5400) WIN
5441 WRITE(MSTU(11),5500) SQRT(S)
5444 C...Frame defined by user three-vectors.
5445 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5449 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5450 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5451 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5452 & (P(1,3)+P(2,3))**2
5453 IF(MSTP(122).GE.1) THEN
5454 LOFFS=(22-(LEN(2)+LEN(3)))/2
5455 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5456 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5457 & ' user configuration'//' '
5458 WRITE(MSTU(11),5200) CHINIT
5459 WRITE(MSTU(11),5600)
5460 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5461 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5462 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5465 C...Frame defined by user four-vectors.
5466 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5468 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5469 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5470 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5471 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5472 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5473 & (P(1,3)+P(2,3))**2
5474 IF(MSTP(122).GE.1) THEN
5475 LOFFS=(22-(LEN(2)+LEN(3)))/2
5476 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5477 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5478 & ' user configuration'//' '
5479 WRITE(MSTU(11),5200) CHINIT
5480 WRITE(MSTU(11),5600)
5481 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5482 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5483 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5486 C...Frame defined by user five-vectors.
5487 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5489 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5490 & (P(1,3)+P(2,3))**2
5491 IF(MSTP(122).GE.1) THEN
5492 LOFFS=(22-(LEN(2)+LEN(3)))/2
5493 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5494 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5495 & ' user configuration'//' '
5496 WRITE(MSTU(11),5200) CHINIT
5497 WRITE(MSTU(11),5600)
5498 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5499 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5500 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5503 C...Frame defined by HEPRUP common block.
5504 ELSEIF(MINT(111).GE.11) THEN
5505 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5506 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5507 IF(MSTP(122).GE.1) THEN
5508 LOFFS=(22-(LEN(2)+LEN(3)))/2
5509 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5510 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5511 & ' user configuration'//' '
5512 WRITE(MSTU(11),5200) CHINIT
5513 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5514 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5517 C...Unknown frame. Error for too low CM energy.
5519 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5522 IF(S.LT.PARP(2)**2) THEN
5523 WRITE(MSTU(11),5900) SQRT(S)
5527 C...Formats for initialization and error information.
5528 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5529 &1X,'Execution stopped!')
5530 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5531 &1X,'Execution stopped!')
5532 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5533 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5534 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5535 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5536 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5537 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5538 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5539 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5540 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5541 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5542 &1X,'Execution stopped!')
5543 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5544 &'generation.'/1X,'Execution stopped!')
5545 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5546 &'GeV beam energies',13X,'I')
5551 C*********************************************************************
5554 C...Sets up kinematics, including rotations and boosts to/from CM frame.
5556 SUBROUTINE PYINKI(MODKI)
5558 C...Double precision and integer declarations.
5559 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5560 IMPLICIT INTEGER(I-N)
5561 INTEGER PYK,PYCHGE,PYCOMP
5563 C...User process initialization commonblock.
5565 PARAMETER (MAXPUP=100)
5566 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5567 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5568 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5569 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5574 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5575 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5576 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5577 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5578 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5579 COMMON/PYINT1/MINT(400),VINT(400)
5580 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5582 C...Set initial flavour state.
5587 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5590 C...Reset boost. Do kinematics for various cases.
5595 C...Set up kinematics for events defined in CM frame.
5596 IF(MINT(111).EQ.1) THEN
5598 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5602 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5603 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5608 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5611 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5612 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5614 C...Set up kinematics for fixed target events.
5615 ELSEIF(MINT(111).EQ.2) THEN
5617 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5620 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5621 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5627 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5630 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5631 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5632 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5634 C...Set up kinematics for events in user-defined frame.
5635 ELSEIF(MINT(111).EQ.3) THEN
5638 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5639 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5640 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5641 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5643 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5645 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5646 VINT(7)=PYANGL(P(1,1),P(1,2))
5647 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5648 VINT(6)=PYANGL(P(1,3),P(1,1))
5649 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5650 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5652 C...Set up kinematics for events with user-defined four-vectors.
5653 ELSEIF(MINT(111).EQ.4) THEN
5654 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5655 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5656 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5657 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5659 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5661 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5662 VINT(7)=PYANGL(P(1,1),P(1,2))
5663 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5664 VINT(6)=PYANGL(P(1,3),P(1,1))
5665 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5666 S=(P(1,4)+P(2,4))**2
5668 C...Set up kinematics for events with user-defined five-vectors.
5669 ELSEIF(MINT(111).EQ.5) THEN
5671 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5673 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5674 VINT(7)=PYANGL(P(1,1),P(1,2))
5675 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5676 VINT(6)=PYANGL(P(1,3),P(1,1))
5677 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5678 S=(P(1,4)+P(2,4))**2
5680 C...Set up kinematics for events with external user processes.
5681 ELSEIF(MINT(111).GE.11) THEN
5684 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5685 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5690 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5691 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5694 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5695 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5696 S=(P(1,4)+P(2,4))**2
5699 C...Return or error for too low CM energy.
5700 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5701 IF(MSTP(172).LE.1) THEN
5703 & '(PYINKI:) too low invariant mass in this event')
5710 C...Save information on incoming particles.
5713 IF(MINT(111).GE.4) THEN
5714 IF(MINT(141).EQ.0) THEN
5716 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5720 IF(MINT(142).EQ.0) THEN
5722 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5728 IF(MODKI.EQ.0) VINT(289)=S
5736 C...Store pT cut-off and related constants to be used in generation.
5737 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5738 IF(MSTP(82).LE.1) THEN
5739 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5741 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5743 VINT(149)=4D0*PTMN**2/S
5749 C*********************************************************************
5752 C...Selects partonic subprocesses to be included in the simulation.
5756 C...Double precision and integer declarations.
5757 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5758 IMPLICIT INTEGER(I-N)
5759 INTEGER PYK,PYCHGE,PYCOMP
5761 C...User process initialization commonblock.
5763 PARAMETER (MAXPUP=100)
5764 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5765 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5766 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5767 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5771 C...Commonblocks and character variables.
5772 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5773 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5774 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5775 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5776 COMMON/PYINT1/MINT(400),VINT(400)
5777 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5778 COMMON/PYINT6/PROC(0:500)
5780 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
5784 C...Reset processes to be included.
5791 C...Set running pTmin scale.
5792 IF(MSTP(82).LE.1) THEN
5793 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5795 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5798 C...Begin by assuming incoming photon to enter subprocess.
5799 IF(MINT(11).EQ.22) MINT(15)=22
5800 IF(MINT(12).EQ.22) MINT(16)=22
5802 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
5803 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
5805 MINT(123)=MINT(122)+1
5807 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
5809 C...Here also set a few parameters otherwise normally not touched.
5810 ELSEIF(MINT(121).GT.1) THEN
5812 C...Parton distributions dampened at small Q2; go to low energies,
5813 C...alpha_s <1; no minimum pT cut-off a priori.
5814 IF(MSTP(18).EQ.2) THEN
5822 C...Define pT cut-off parameters and whether run involves low-pT.
5826 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
5828 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
5829 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
5831 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
5832 IF(MSEL.EQ.2) IPTL=1
5834 C...Set up for p/gamma * gamma; real or virtual photons.
5835 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
5836 & MSTP(14).EQ.30)) THEN
5838 C...Set up for p/VMD * VMD.
5839 IF(MINT(122).EQ.1) THEN
5847 IF(IPTL.EQ.1) MSUB(95)=1
5854 IF(IPTL.EQ.1) CKIN(3)=0D0
5856 C...Set up for p/VMD * direct gamma.
5857 ELSEIF(MINT(122).EQ.2) THEN
5859 IF(MINT(121).EQ.6) MINT(123)=5
5864 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5866 C...Set up for p/VMD * anomalous gamma.
5867 ELSEIF(MINT(122).EQ.3) THEN
5869 IF(MINT(121).EQ.6) MINT(123)=7
5876 IF(IPTL.EQ.1) MSUB(95)=1
5883 IF(IPTL.EQ.1) CKIN(3)=0D0
5885 C...Set up for DIS * p.
5886 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
5887 & IABS(MINT(12)).GT.100)) THEN
5889 IF(IPTL.EQ.1) MSUB(99)=1
5891 C...Set up for direct * direct gamma (switch off leptons).
5892 ELSEIF(MINT(122).EQ.4) THEN
5898 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5899 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5901 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5903 C...Set up for direct * anomalous gamma.
5904 ELSEIF(MINT(122).EQ.5) THEN
5910 IF(IPTL.EQ.1) CKIN(3)=PTMANO
5912 C...Set up for anomalous * anomalous gamma.
5913 ELSEIF(MINT(122).EQ.6) THEN
5921 IF(IPTL.EQ.1) MSUB(95)=1
5928 IF(IPTL.EQ.1) CKIN(3)=0D0
5931 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
5932 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
5934 C...Set up for direct * direct gamma (switch off leptons).
5935 IF(MINT(122).EQ.1) THEN
5941 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5942 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5944 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5946 C...Set up for direct * VMD and VMD * direct gamma.
5947 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
5953 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5955 C...Set up for direct * anomalous and anomalous * direct gamma.
5956 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
5962 IF(IPTL.EQ.1) CKIN(3)=PTMANO
5964 C...Set up for VMD*VMD.
5965 ELSEIF(MINT(122).EQ.5) THEN
5973 IF(IPTL.EQ.1) MSUB(95)=1
5980 IF(IPTL.EQ.1) CKIN(3)=0D0
5982 C...Set up for VMD * anomalous and anomalous * VMD gamma.
5983 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
5991 IF(IPTL.EQ.1) MSUB(95)=1
5998 IF(IPTL.EQ.1) CKIN(3)=0D0
6000 C...Set up for anomalous * anomalous gamma.
6001 ELSEIF(MINT(122).EQ.9) THEN
6009 IF(IPTL.EQ.1) MSUB(95)=1
6016 IF(IPTL.EQ.1) CKIN(3)=0D0
6018 C...Set up for DIS * VMD and VMD * DIS gamma.
6019 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
6021 IF(IPTL.EQ.1) MSUB(99)=1
6023 C...Set up for DIS * anomalous and anomalous * DIS gamma.
6024 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
6026 IF(IPTL.EQ.1) MSUB(99)=1
6029 C...Set up for gamma* * p; virtual photons = dir, res.
6030 ELSEIF(MINT(121).EQ.2) THEN
6032 C...Set up for direct * p.
6033 IF(MINT(122).EQ.1) THEN
6039 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6041 C...Set up for resolved * p.
6042 ELSEIF(MINT(122).EQ.2) THEN
6050 IF(IPTL.EQ.1) MSUB(95)=1
6057 IF(IPTL.EQ.1) CKIN(3)=0D0
6060 C...Set up for gamma* * gamma*; virtual photons = dir, res.
6061 ELSEIF(MINT(121).EQ.4) THEN
6063 C...Set up for direct * direct gamma (switch off leptons).
6064 IF(MINT(122).EQ.1) THEN
6070 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6071 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6073 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6075 C...Set up for direct * resolved and resolved * direct gamma.
6076 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6082 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6084 C...Set up for resolved * resolved gamma.
6085 ELSEIF(MINT(122).EQ.4) THEN
6093 IF(IPTL.EQ.1) MSUB(95)=1
6100 IF(IPTL.EQ.1) CKIN(3)=0D0
6103 C...End of special set up for gamma-p and gamma-gamma.
6108 C...Flavour information for individual beams.
6111 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6112 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6113 MINT(44+I)=MINT(40+I)
6114 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6115 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6118 C...If two real gammas, whereof one direct, pick the first.
6119 C...For two virtual photons, keep requested order.
6120 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6121 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6124 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6125 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6128 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6129 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6132 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6133 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6136 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6137 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6140 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6143 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6147 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6148 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6149 IF(MINT(11).EQ.22) THEN
6157 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6158 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6161 C...Flavour information on combination of incoming particles.
6162 MINT(43)=2*MINT(41)+MINT(42)-2
6164 IF(MINT(123).LE.0) THEN
6165 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6166 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6167 ELSEIF(MINT(123).LE.3) THEN
6168 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6169 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6170 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6174 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6175 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6176 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6177 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6179 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6182 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6183 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6185 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6187 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6188 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6189 & MINT(122).EQ.10) MINT(108)=2
6190 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6191 & MINT(122).EQ.11) MINT(108)=3
6192 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6193 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6194 IF(MINT(122).GE.3) MINT(107)=1
6195 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6196 ELSEIF(MINT(121).EQ.2) THEN
6197 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6198 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6200 IF(MINT(11).EQ.22) THEN
6202 IF(MINT(123).GE.4) MINT(107)=0
6203 IF(MINT(123).EQ.7) MINT(107)=2
6204 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6205 IF(MSTP(14).EQ.28) MINT(107)=2
6206 IF(MSTP(14).EQ.29) MINT(107)=3
6207 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6210 IF(MINT(12).EQ.22) THEN
6212 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6213 IF(MINT(123).EQ.7) MINT(108)=3
6214 IF(MSTP(14).EQ.26) MINT(108)=2
6215 IF(MSTP(14).EQ.27) MINT(108)=3
6216 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6217 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6220 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6221 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6227 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6228 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6230 C...Select default processes according to incoming beams
6231 C...(already done for gamma-p and gamma-gamma with
6232 C...MSTP(14) = 10, 20, 25 or 30).
6233 IF(MINT(121).GT.1) THEN
6234 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6236 IF(MINT(43).EQ.1) THEN
6237 C...Lepton + lepton -> gamma/Z0 or W.
6238 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6239 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6241 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6242 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6243 C...Unresolved photon + lepton: Compton scattering.
6247 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6248 & .OR.MINT(12).EQ.22)) THEN
6249 C...DIS as pure gamma* + f -> f process.
6252 ELSEIF(MINT(43).LE.3) THEN
6253 C...Lepton + hadron: deep inelastic scattering.
6256 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6257 & MINT(12).EQ.22) THEN
6258 C...Two unresolved photons: fermion pair production,
6259 C...exclude lepton pairs.
6263 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6264 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6267 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6268 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6269 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6271 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6272 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6273 & MINT(12).EQ.22)) THEN
6274 C...Unresolved photon + hadron: photon-parton scattering.
6279 ELSEIF(MSEL.EQ.1) THEN
6280 C...High-pT QCD processes:
6289 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6290 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6293 C...All QCD processes:
6307 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6308 C...Heavy quark production.
6312 DO 180 J=1,MIN(8,MDCY(21,3))
6313 MDME(MDCY(21,2)+J-1,1)=0
6315 MDME(MDCY(21,2)+MSEL-1,1)=1
6317 DO 190 J=1,MIN(12,MDCY(22,3))
6318 MDME(MDCY(22,2)+J-1,1)=0
6320 MDME(MDCY(22,2)+MSEL-1,1)=1
6322 ELSEIF(MSEL.EQ.10) THEN
6323 C...Prompt photon production:
6328 ELSEIF(MSEL.EQ.11) THEN
6329 C...Z0/gamma* production:
6332 ELSEIF(MSEL.EQ.12) THEN
6333 C...W+/- production:
6336 ELSEIF(MSEL.EQ.13) THEN
6341 ELSEIF(MSEL.EQ.14) THEN
6346 ELSEIF(MSEL.EQ.15) THEN
6347 C...Z0 & W+/- pair production:
6354 ELSEIF(MSEL.EQ.16) THEN
6362 ELSEIF(MSEL.EQ.17) THEN
6363 C...h0 & Z0 or W+/- pair production:
6367 ELSEIF(MSEL.EQ.18) THEN
6368 C...h0 production; interesting processes in e+e-.
6374 ELSEIF(MSEL.EQ.19) THEN
6375 C...h0, H0 and A0 production; interesting processes in e+e-.
6389 ELSEIF(MSEL.EQ.21) THEN
6393 ELSEIF(MSEL.EQ.22) THEN
6394 C...W'+/- production:
6397 ELSEIF(MSEL.EQ.23) THEN
6398 C...H+/- production:
6401 ELSEIF(MSEL.EQ.24) THEN
6405 ELSEIF(MSEL.EQ.25) THEN
6406 C...LQ (leptoquark) production.
6412 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6413 C...Production of one heavy quark (W exchange):
6415 DO 200 J=1,MIN(8,MDCY(21,3))
6416 MDME(MDCY(21,2)+J-1,1)=0
6418 MDME(MDCY(21,2)+MSEL-31,1)=1
6420 CMRENNA++Define SUSY alternatives.
6421 ELSEIF(MSEL.EQ.39) THEN
6422 C...Turn on all SUSY processes.
6423 IF(MINT(43).EQ.4) THEN
6424 C...Hadron-hadron processes.
6426 IF(ISET(I).GE.0) MSUB(I)=1
6428 ELSEIF(MINT(43).EQ.1) THEN
6429 C...Lepton-lepton processes: QED production of squarks.
6446 ELSEIF(MSEL.EQ.40) THEN
6447 C...Gluinos and squarks.
6448 IF(MINT(43).EQ.4) THEN
6460 ELSEIF(MINT(43).EQ.1) THEN
6465 ELSEIF(MSEL.EQ.41) THEN
6466 C...Stop production.
6470 IF(MINT(43).EQ.4) THEN
6475 ELSEIF(MSEL.EQ.42) THEN
6476 C...Slepton production.
6480 IF(MINT(43).NE.4) THEN
6486 ELSEIF(MSEL.EQ.43) THEN
6487 C...Neutralino/Chargino + Gluino/Squark.
6488 IF(MINT(43).EQ.4) THEN
6498 ELSEIF(MSEL.EQ.44) THEN
6499 C...Neutralino/Chargino pair production.
6500 IF(MINT(43).EQ.4) THEN
6504 ELSEIF(MINT(43).EQ.1) THEN
6510 ELSEIF(MSEL.EQ.45) THEN
6511 C...Sbottom production.
6514 IF(MINT(43).EQ.4) THEN
6520 ELSEIF(MSEL.EQ.50) THEN
6521 C...Pair production of technipions and gauge bosons.
6525 IF(MINT(43).EQ.4) THEN
6531 ELSEIF(MSEL.EQ.51) THEN
6532 C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6537 ELSEIF(MSEL.EQ.61) THEN
6538 C...Charmonium production in colour octet model, with recoiling parton.
6543 ELSEIF(MSEL.EQ.62) THEN
6544 C...Bottomonium production in colour octet model, with recoiling parton.
6549 ELSEIF(MSEL.EQ.63) THEN
6550 C...Charmonium and bottomonium production in colour octet model.
6557 C...Find heaviest new quark flavour allowed in processes 81-84.
6559 DO 350 I=1,MIN(8,MDCY(21,3))
6561 IF(MDME(IDC,1).LE.0) GOTO 350
6564 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6575 C...Find heaviest new fermion flavour allowed in process 85.
6577 DO 360 I=1,MIN(12,MDCY(22,3))
6579 IF(MDME(IDC,1).LE.0) GOTO 360
6582 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6583 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6588 C...Import relevant information on external user processes.
6589 IF(MINT(111).GE.11) THEN
6592 C...Find next empty PYTHIA process number slot and enable it.
6594 IF(IPYPR.GT.500) CALL PYERRM(26,
6595 & '(PYINPR.) no more empty slots for user processes')
6596 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6597 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6599 C...Overwrite KFPR with references back to process number and ID.
6601 KFPR(IPYPR,2)=LPRUP(IUP)
6603 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6606 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6608 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6609 C...Switch on process.
6617 C*********************************************************************
6620 C...Parametrizes total, elastic and diffractive cross-sections
6621 C...for different energies and beams. Donnachie-Landshoff for
6622 C...total and Schuler-Sjostrand for elastic and diffractive.
6623 C...Process code IPROC:
6630 C...= 7 : J/psi + p;
6631 C...= 11 : rho + rho;
6632 C...= 12 : rho + phi;
6633 C...= 13 : rho + J/psi;
6634 C...= 14 : phi + phi;
6635 C...= 15 : phi + J/psi;
6636 C...= 16 : J/psi + J/psi;
6637 C...= 21 : gamma + p (DL);
6638 C...= 22 : gamma + p (VDM).
6639 C...= 23 : gamma + pi (DL);
6640 C...= 24 : gamma + pi (VDM);
6641 C...= 25 : gamma + gamma (DL);
6642 C...= 26 : gamma + gamma (VDM).
6646 C...Double precision and integer declarations.
6647 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6648 IMPLICIT INTEGER(I-N)
6649 INTEGER PYK,PYCHGE,PYCOMP
6651 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6652 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6653 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6654 COMMON/PYINT1/MINT(400),VINT(400)
6655 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6656 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6657 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6659 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6660 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6661 &CEFFD(10,9),SIGTMP(6,0:5)
6663 C...Common constants.
6664 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6665 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6668 C...Number of multiple processes to be evaluated (= 0 : undefined).
6669 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6670 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6671 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6672 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6673 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6675 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6676 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6677 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6679 C...Beam and target hadron class:
6680 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6681 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6682 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6683 C...Characteristic class masses, slope parameters, beta = sqrt(X).
6684 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6685 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6686 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6688 C...Fitting constants used in parametrizations of diffractive results.
6689 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6690 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6691 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6692 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6693 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6694 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6695 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6696 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6697 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6698 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6699 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6700 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6701 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6702 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6703 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6704 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6705 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6706 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6707 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6708 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6709 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6710 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6711 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6712 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6713 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6714 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6715 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6716 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6717 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6719 C...Parameters. Combinations of the energy.
6728 C...Ratio of gamma/pi (for rescaling in parton distributions).
6729 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
6730 &(XPAR(5)*SEPS+YPAR(5)*SETA)
6732 IF(MINT(50).NE.1) RETURN
6734 C...Order flavours of incoming particles: KF1 < KF2.
6735 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
6744 ISGN12=ISIGN(1,MINT(11)*MINT(12))
6746 C...Find process number (for lookup tables).
6747 IF(KF1.GT.1000) THEN
6749 IF(ISGN12.LT.0) IPROC=2
6750 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
6752 IF(ISGN12.LT.0) IPROC=4
6753 IF(KF1.EQ.111) IPROC=5
6754 ELSEIF(KF1.GT.100) THEN
6756 ELSEIF(KF2.GT.1000) THEN
6758 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
6759 ELSEIF(KF2.GT.100) THEN
6761 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
6764 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
6767 C... Number of multiple processes to be stored; beam/target side.
6773 ELSEIF(NPR.EQ.6) THEN
6778 IF(MINT(101).EQ.4) N1=4
6780 IF(MINT(102).EQ.4) N2=4
6782 C...Do not do any more for user-set or undefined cross-sections.
6783 IF(MSTP(31).LE.0) RETURN
6784 IF(NPR.EQ.0) CALL PYERRM(26,
6785 &'(PYXTOT:) cross section for this process not yet implemented')
6787 C...Parameters. Combinations of the energy.
6796 C...Loop over multiple processes (for VDM).
6800 ELSEIF(NPR.EQ.3) THEN
6802 IF(KF2.LT.1000) IPR=I+10
6803 ELSEIF(NPR.EQ.6) THEN
6807 C...Evaluate hadron species, mass, slope contribution and fit number.
6817 C...Skip if energy too low relative to masses.
6821 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
6823 C...Total cross-section. Elastic slope parameter and cross-section.
6824 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
6825 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
6826 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
6828 C...Diffractive scattering A + B -> X + B.
6831 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
6832 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
6833 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
6834 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
6835 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
6836 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
6837 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
6839 C...Diffractive scattering A + B -> A + X.
6842 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
6843 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
6844 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
6845 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
6846 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
6847 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
6848 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
6850 C...Order single diffractive correctly.
6853 SIGTMP(I,2)=SIGTMP(I,3)
6857 C...Double diffractive scattering A + B -> X1 + X2.
6858 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
6859 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
6860 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
6861 IF(YEFF.LE.0) SUM1=0D0
6862 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
6863 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
6864 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
6865 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
6867 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
6868 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
6869 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
6871 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
6872 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
6873 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
6874 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
6875 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
6877 C...Non-diffractive by unitarity.
6878 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
6882 C...Put temporary results in output array: only one process.
6883 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
6885 SIGT(0,0,J)=SIGTMP(1,J)
6888 C...Beam multiple processes.
6889 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
6890 IF(MINT(107).EQ.2) THEN
6891 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
6893 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6894 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
6896 IF(MSTP(20).GT.0) THEN
6897 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
6900 IF(MINT(107).EQ.2) THEN
6901 CONV=(AEM/PARP(160+I))*VINT(317)
6902 ELSEIF(VINT(154).GT.PARP(15)) THEN
6903 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
6904 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6910 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
6914 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
6917 C...Target multiple processes.
6918 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
6919 IF(MINT(108).EQ.2) THEN
6920 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
6922 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6923 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
6925 IF(MSTP(20).GT.0) THEN
6926 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
6929 IF(MINT(108).EQ.2) THEN
6930 CONV=(AEM/PARP(160+I))*VINT(317)
6931 ELSEIF(VINT(154).GT.PARP(15)) THEN
6932 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
6933 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6939 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
6943 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
6946 C...Both beam and target multiple processes.
6948 IF(MINT(107).EQ.2) THEN
6949 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
6951 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6952 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
6954 IF(MINT(108).EQ.2) THEN
6955 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
6957 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
6958 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
6960 IF(MSTP(20).GT.0) THEN
6961 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
6962 & VINT(308)))**MSTP(20)
6966 IF(MINT(107).EQ.2) THEN
6967 CONV=(AEM/PARP(160+I1))*VINT(317)
6968 ELSEIF(VINT(154).GT.PARP(15)) THEN
6969 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
6970 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6974 IF(MINT(108).EQ.2) THEN
6975 CONV=CONV*(AEM/PARP(160+I2))
6976 ELSEIF(VINT(154).GT.PARP(15)) THEN
6977 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
6978 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
6984 ELSEIF(I2.LE.2) THEN
6986 ELSEIF(I1.EQ.I2) THEN
6993 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
6994 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
7000 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
7001 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
7003 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7007 C...Scale up uniformly for Donnachie-Landshoff parametrization.
7008 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
7009 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
7013 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
7022 C*********************************************************************
7025 C...Finds optimal set of coefficients for kinematical variable selection
7026 C...and the maximum of the part of the differential cross-section used
7027 C...in the event weighting.
7031 C...Double precision and integer declarations.
7032 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7033 IMPLICIT INTEGER(I-N)
7034 INTEGER PYK,PYCHGE,PYCOMP
7035 C...Parameter statement to help give large particle numbers.
7036 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7037 &KEXCIT=4000000,KDIMEN=5000000)
7039 C...User process initialization commonblock.
7041 PARAMETER (MAXPUP=100)
7042 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7043 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7044 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7045 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7050 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7051 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7052 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7053 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7054 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7055 COMMON/PYINT1/MINT(400),VINT(400)
7056 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7057 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7058 COMMON/PYINT4/MWID(500),WIDS(500,5)
7059 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7060 COMMON/PYINT6/PROC(0:500)
7062 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7063 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
7064 COMMON/PYTCCO/COEFX(194:380,2)
7065 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
7066 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7067 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
7069 C...Local arrays, character variables and data.
7072 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7073 &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
7074 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
7075 DATA CVAR/'tau ','tau''','y* ','cth '/
7078 C...Initial values and loop over subprocesses.
7088 C...Find maximum weight factors for photon flux.
7089 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7090 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7093 C...Select subprocess to study: skip cases not applicable.
7094 IF(ISET(ISUB).EQ.11) THEN
7095 IF(MSUB(ISUB).NE.1) GOTO 460
7096 C...User process intialization: cross section model dependent.
7097 IF(IABS(IDWTUP).EQ.1) THEN
7098 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7099 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7100 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7102 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7103 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7104 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7105 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7106 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7107 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7109 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7110 & WTGAGA*XSEC(ISUB,1)
7113 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7114 CALL PYSIGH(NCHN,SIGS)
7116 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7117 & WTGAGA*XSEC(ISUB,1)
7118 IF(MSUB(ISUB).NE.1) GOTO 460
7121 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7122 CALL PYSIGH(NCHN,SIGS)
7124 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7125 & WTGAGA*XSEC(ISUB,1)
7126 IF(XSEC(ISUB,1).EQ.0D0) THEN
7132 ELSEIF(ISUB.EQ.96) THEN
7133 IF(MINT(50).EQ.0) GOTO 460
7134 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7136 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7137 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7138 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7139 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7140 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7141 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7143 IF(MSUB(ISUB).NE.1) GOTO 460
7146 IF(ISUB.EQ.96) ISTSB=2
7147 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7149 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7150 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7152 C...Find resonances (explicit or implicit in cross-section).
7155 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7157 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7158 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7160 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7161 & .OR.ISUB.EQ.177) THEN
7163 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7165 IF(MSTP(46).EQ.5) THEN
7168 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7172 IF(CKMX.LE.0D0) CKMX=VINT(1)
7175 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7176 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7179 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7180 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7188 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
7189 $ (ISUB.GE.361.AND.ISUB.LE.380))
7192 IF(ISUB.EQ.141) THEN
7194 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7195 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
7198 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7199 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7205 ELSEIF(ITECH.EQ.0) THEN
7206 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
7215 C...Order the resonances
7216 IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
7221 IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
7226 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7233 SHN0=PMAS(KCR1,1)**2
7235 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
7236 SHN0=PMAS(KCR2,1)**2
7238 IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
7239 SHN0=PMAS(KCR3,1)**2
7242 FAR=SQRT(AEM/ALPRHT)
7244 CALL PYTECM(SHN,S1,WIDO,1)
7249 CALL PYTECM(SHN,S1,WIDO,1)
7250 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7253 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7254 ELSEIF(IRES.EQ.0) THEN
7264 IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
7271 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7278 SHN0=PMAS(KCR1,1)**2
7280 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
7281 SHN0=PMAS(KCR2,1)**2
7284 FAR=SQRT(AEM/ALPRHT)
7286 CALL PYTECM(SHN,S1,WIDO,2)
7291 CALL PYTECM(SHN,S1,WIDO,2)
7292 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7295 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7296 ELSEIF(JRES.EQ.0) THEN
7306 IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
7309 IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
7310 & ISUB.EQ.379.OR.ISUB.EQ.380) THEN
7313 VINT(73)=XMAS(1)**2/VINT(2)
7314 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
7322 VINT(75)=XMAS(2)**2/VINT(2)
7323 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
7331 VINT(77)=XMAS(3)**2/VINT(2)
7332 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
7339 C...Charged current: rho+- and a+-
7340 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
7343 VINT(73)=YMAS(1)**2/VINT(2)
7344 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
7352 VINT(75)=YMAS(2)**2/VINT(2)
7353 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
7362 IF(ISUB.NE.141) THEN
7363 IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
7364 & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
7365 IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
7366 & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
7367 IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
7368 & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
7369 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
7371 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
7373 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
7378 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
7386 ELSEIF(KFR1.NE.0) THEN
7388 ELSEIF(KFR2.NE.0) THEN
7393 ELSEIF(KFR3.NE.0) THEN
7402 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7404 ELSEIF(KFR2.NE.0) THEN
7419 C...Find product masses and minimum pT of process.
7425 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7429 IF(KFPR(ISUB,I).EQ.0) THEN
7430 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7432 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7433 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7436 C...This prevents SUSY/t particles from becoming too light.
7438 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7441 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7442 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7443 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7444 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7445 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7446 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7447 PMMN(I)=MIN(PMMN(I),PMSUM)
7450 ELSEIF(KFLW.EQ.6) THEN
7451 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7458 CKIN(41)=MAX(PMMN(1),CKIN(41))
7459 CKIN(43)=MAX(PMMN(2),CKIN(43))
7460 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7463 IF(MINT(51).EQ.1) THEN
7464 WRITE(MSTU(11),5100) ISUB
7471 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7472 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7473 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7474 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7475 ELSEIF(ISUB.EQ.96) THEN
7476 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7482 C...Prepare for additional variable choices in 2 -> 3.
7485 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7487 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7488 VINT(204)=PMAS(23,1)
7489 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7490 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7491 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7492 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7493 & VINT(204)=VINT(201)
7495 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7498 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7500 NPTS(1)=2+2*MINT(72)
7501 IF(MINT(47).EQ.1) THEN
7502 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7503 ELSEIF(MINT(47).GE.5) THEN
7504 IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
7510 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7511 IF(MINT(47).GE.2) NPTS(2)=2
7512 IF(MINT(47).GE.5) NPTS(2)=3
7515 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7517 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7518 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7521 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7522 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7524 C...Reset coefficients of cross-section weighting.
7528 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
7529 & .AND.ISUB.LE.380)) THEN
7546 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7547 C...in grid of phase space points.
7553 IF(METAU.EQ.1) GOTO 150
7554 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7555 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7556 IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
7558 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
7562 C...Special case when both resonances have same mass,
7563 C...as is often the case in process 194.
7564 c IF(MINT(72).GE.2) THEN
7565 c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7566 c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7567 c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7569 c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7574 CALL PYKMAP(1,MTAU,RTAU)
7575 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7578 IF(METAUP.EQ.1) GOTO 150
7579 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7581 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7582 CALL PYKMAP(4,MTAUP,0.5D0)
7584 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7588 IF(MEYST.EQ.1) GOTO 150
7589 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7590 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7591 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7592 CALL PYKMAP(2,MYST,0.5D0)
7596 IF(MECTH.EQ.1) GOTO 150
7597 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7598 MCTH=1+MOD(ITRY-1,NPTS(4))
7599 CALL PYKMAP(3,MCTH,0.5D0)
7601 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7603 C...Store position and limits.
7606 IF(MINT(51).EQ.1) GOTO 150
7609 MVARPT(NACC,2)=MTAUP
7613 VINTPT(NACC,J)=VINT(10+J)
7616 C...Normal case: calculate cross-section.
7618 CALL PYSIGH(NCHN,SIGS)
7624 C..2 -> 3: find highest value out of a number of tries.
7627 DO 140 IKIN3=1,MSTP(129)
7628 CALL PYKMAP(5,0,0D0)
7629 IF(MINT(51).EQ.1) GOTO 140
7630 CALL PYSIGH(NCHN,SIGTMP)
7635 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7639 C...Store cross-section.
7641 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7642 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7643 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7646 WRITE(MSTU(11),5100) ISUB
7649 ELSEIF(SIGSAM.EQ.0D0) THEN
7650 WRITE(MSTU(11),5300) ISUB
7654 IF(ISUB.NE.96) NPOSI=NPOSI+1
7656 C...Calculate integrals in tau over maximal phase space limits.
7659 ATAU1=LOG(TAUMAX/TAUMIN)
7660 IF(NPTS(1).GE.2) THEN
7661 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7663 IF(NPTS(1).GE.4) THEN
7664 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7665 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7668 IF(NPTS(1).GE.6) THEN
7669 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7670 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7673 IF(NPTS(1).GE.8) THEN
7674 ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
7675 ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
7678 IF(IPEAK7.EQ.1) THEN
7679 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7682 C...Reset. Sum up cross-sections in points calculated.
7684 IF(NPTS(IVAR).EQ.1) GOTO 320
7685 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7696 IBIN=MVARPT(IACC,IVAR)
7698 IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
7700 ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
7704 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7705 NAREL(IBIN)=NAREL(IBIN)+1
7706 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7708 C...Sum up tau cross-section pieces in points used.
7711 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7712 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7714 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7715 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7716 & ((TAU-TAUR1)**2+GAMR1**2)
7719 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7720 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7721 & ((TAU-TAUR2)**2+GAMR2**2)
7723 IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
7724 WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
7725 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7726 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
7727 WTMAT(IBIN,7)=WTMAT(IBIN,7)
7728 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7730 IF(MINT(72).EQ.3) THEN
7731 WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
7732 & +(ATAU1/ATAU8)/(TAU+TAUR3)
7733 WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
7734 & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
7736 C...Sum up tau' cross-section pieces in points used.
7737 ELSEIF(IVAR.EQ.2) THEN
7739 TAUP=VINTPT(IACC,16)
7740 TAUPMN=VINTPT(IACC,6)
7741 TAUPMX=VINTPT(IACC,26)
7742 ATAUP1=LOG(TAUPMX/TAUPMN)
7743 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
7744 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7745 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
7746 & (1D0-TAU/TAUP)**3/TAUP
7748 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
7749 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
7750 & TAUP/MAX(2D-10,1D0-TAUP)
7753 C...Sum up y* cross-section pieces in points used.
7754 ELSEIF(IVAR.EQ.3) THEN
7756 YSTMIN=VINTPT(IACC,2)
7757 YSTMAX=VINTPT(IACC,22)
7759 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
7761 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
7762 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
7763 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
7764 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
7765 IF(MINT(45).EQ.3) THEN
7766 TAUE=VINTPT(IACC,11)
7767 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7768 YST0=-0.5D0*LOG(TAUE)
7769 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
7770 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
7771 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
7772 & MAX(1D-10,1D0-EXP(YST-YST0))
7774 IF(MINT(46).EQ.3) THEN
7775 TAUE=VINTPT(IACC,11)
7776 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7777 YST0=-0.5D0*LOG(TAUE)
7778 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
7779 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
7780 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
7781 & MAX(1D-10,1D0-EXP(-YST-YST0))
7784 C...Sum up cos(theta-hat) cross-section pieces in points used.
7786 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
7788 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
7790 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
7793 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
7794 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
7795 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
7796 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
7798 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7799 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
7800 & MAX(RM34,RSQM-CTH)
7801 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
7802 & MAX(RM34,RSQM+CTH)
7803 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
7804 & MAX(RM34,RSQM-CTH)**2
7805 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
7806 & MAX(RM34,RSQM+CTH)**2
7810 C...Check that equation system solvable.
7811 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
7815 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
7816 & IRED=1,NBIN),WTREL(IBIN)
7817 IF(NAREL(IBIN).EQ.0) MSOLV=0
7818 WTRELS=WTRELS+WTREL(IBIN)
7820 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
7822 C...Solve to find relative importance of cross-section pieces.
7825 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
7827 DO 230 IRED=1,NBIN-1
7828 DO 220 IBIN=IRED+1,NBIN
7829 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
7833 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
7834 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
7835 DO 210 ICOE=IRED,NBIN
7836 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
7840 DO 250 IRED=NBIN,1,-1
7841 DO 240 ICOE=IRED+1,NBIN
7842 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
7844 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
7848 C...Share evenly if failure.
7849 260 IF(MSOLV.EQ.0) THEN
7853 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
7854 & WTREL(IBIN)/WTRELS)
7858 C...Normalize coefficients, with piece shared democratically.
7862 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
7863 COEFSU=COEFSU+COEFU(IBIN)
7864 WTRELS=WTRELS+WTRELN(IBIN)
7866 IF(COEFSU.GT.0D0) THEN
7868 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
7869 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
7873 COEFO(IBIN)=1D0/NBIN
7876 IF(IVAR.EQ.1) IOFF=0
7877 IF(IVAR.EQ.2) IOFF=17
7878 IF(IVAR.EQ.3) IOFF=7
7879 IF(IVAR.EQ.4) IOFF=12
7883 IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
7887 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
7888 IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
7889 COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
7891 COEF(ISUB,ICOF)=COEFO(IBIN)
7895 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
7896 & (COEFO(IBIN),IBIN=1,NBIN)
7900 C...Find two most promising maxima among points previously determined.
7908 VINT(10+J)=VINTPT(IACC,J)
7911 CALL PYSIGH(NCHN,SIGS)
7918 DO 350 IKIN3=1,MSTP(129)
7919 CALL PYKMAP(5,0,0D0)
7920 IF(MINT(51).EQ.1) GOTO 350
7921 CALL PYSIGH(NCHN,SIGTMP)
7926 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7931 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
7934 DO 370 IMV=NMAX,1,-1
7936 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
7937 IACCMX(IMV+1)=IACCMX(IMV)
7938 SIGSMX(IMV+1)=SIGSMX(IMV)
7941 380 IACCMX(IIN)=IACC
7943 IF(NMAX.LE.1) NMAX=NMAX+1
7947 C...Read out starting position for search.
7948 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
7953 MTAUP=MVARPT(IACC,2)
7961 C...Starting point and step size in parameter space.
7964 IF(NPTS(IVAR).EQ.1) GOTO 420
7965 IF(IVAR.EQ.1) VVAR=VTAU
7966 IF(IVAR.EQ.2) VVAR=VTAUP
7967 IF(IVAR.EQ.3) VVAR=VYST
7968 IF(IVAR.EQ.4) VVAR=VCTH
7969 IF(IVAR.EQ.1) MVAR=MTAU
7970 IF(IVAR.EQ.2) MVAR=MTAUP
7971 IF(IVAR.EQ.3) MVAR=MYST
7972 IF(IVAR.EQ.4) MVAR=MCTH
7973 IF(IRPT.EQ.1) VDEL=0.1D0
7974 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
7976 IF(IRPT.EQ.1) VMAR=0.02D0
7977 IF(IRPT.EQ.2) VMAR=0.002D0
7979 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
7982 C...Define new point in parameter space.
7986 ELSEIF(IMOV.EQ.1) THEN
7989 ELSEIF(IMOV.EQ.2) THEN
7992 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
7993 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
7999 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
8000 & VVAR-2D0*VDEL.GT.VMAR) THEN
8006 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
8020 C...Convert to relevant variables and find derived new limits.
8024 CALL PYKMAP(1,MTAU,VTAU)
8025 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8027 IF(MINT(51).EQ.1) ILERR=1
8030 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
8032 IF(IVAR.EQ.2) VTAUP=VNEW
8033 CALL PYKMAP(4,MTAUP,VTAUP)
8035 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
8037 IF(MINT(51).EQ.1) ILERR=1
8039 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
8040 IF(IVAR.EQ.3) VYST=VNEW
8041 CALL PYKMAP(2,MYST,VYST)
8043 IF(MINT(51).EQ.1) ILERR=1
8045 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
8047 IF(IVAR.EQ.4) VCTH=VNEW
8048 CALL PYKMAP(3,MCTH,VCTH)
8050 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
8052 C...Evaluate cross-section. Save new maximum. Final maximum.
8055 ELSEIF(ISTSB.NE.5) THEN
8056 CALL PYSIGH(NCHN,SIGS)
8063 DO 400 IKIN3=1,MSTP(129)
8064 CALL PYKMAP(5,0,0D0)
8065 IF(MINT(51).EQ.1) GOTO 400
8066 CALL PYSIGH(NCHN,SIGTMP)
8071 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8075 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
8076 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
8077 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
8082 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
8083 XSEC(ISUB,1)=1.05D0*SIGSAM
8084 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
8085 & WTGAGA*XSEC(ISUB,1)
8087 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
8088 & PARP(174)*XSEC(ISUB,1)
8089 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
8093 C...Print summary table.
8094 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
8095 IF(MSTP(127).NE.1) THEN
8096 WRITE(MSTU(11),5900)
8099 WRITE(MSTU(11),6400)
8103 IF(MSTP(122).GE.1) THEN
8104 WRITE(MSTU(11),6000)
8105 WRITE(MSTU(11),6100)
8107 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
8108 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
8109 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
8111 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
8112 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
8113 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
8114 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
8115 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
8117 WRITE(MSTU(11),6300)
8120 C...Format statements for maximization results.
8121 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
8122 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
8123 &'cth',9X,'tau''',7X,'sigma')
8124 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
8125 &'phase space.'/1X,'Process switched off!')
8126 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
8127 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
8128 &'cross-section.'/1X,'Process switched off!')
8129 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
8130 5500 FORMAT(1X,1P,10D11.3)
8131 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
8132 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
8133 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
8134 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
8135 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
8136 &'cross-section.'/1X,'Execution stopped!')
8137 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
8138 &'cross-section maximum search',1X,8('*'))
8139 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
8140 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
8141 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
8142 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
8143 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
8144 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
8146 &1X,'Execution will stop if you try to generate events.')
8151 C*********************************************************************
8154 C...Initializes multiplicity distribution and selects mutliplicity
8155 C...of pileup events, i.e. several events occuring at the same
8158 SUBROUTINE PYPILE(MPILE)
8160 C...Double precision and integer declarations.
8161 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8162 IMPLICIT INTEGER(I-N)
8163 INTEGER PYK,PYCHGE,PYCOMP
8165 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8166 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8167 COMMON/PYINT1/MINT(400),VINT(400)
8168 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8169 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
8170 C...Local arrays and saved variables.
8171 DIMENSION WTI(0:200)
8172 SAVE IMIN,IMAX,WTI,WTS
8174 C...Sum of allowed cross-sections for pileup events.
8176 VINT(131)=SIGT(0,0,5)
8177 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
8178 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
8179 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
8180 IF(MSTP(133).LE.0) RETURN
8182 C...Initialize multiplicity distribution at maximum.
8183 XNAVE=VINT(131)*PARP(131)
8184 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
8185 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
8188 WTN=WTI(INAVE)*INAVE
8190 C...Find shape of multiplicity distribution below maximum.
8192 DO 100 I=INAVE-1,1,-1
8193 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
8194 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
8195 IF(WTI(I).LT.1D-6) GOTO 110
8201 C...Find shape of multiplicity distribution above maximum.
8203 DO 120 I=INAVE+1,200
8204 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
8205 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
8206 IF(WTI(I).LT.1D-6) GOTO 130
8213 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
8214 & WTS/(WTS+WTI(1)/XNAVE)
8215 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
8216 IF(MSTP(133).GE.2) VINT(134)=XNAVE
8218 C...Pick multiplicity of pileup events.
8220 IF(MSTP(133).LE.0) THEN
8221 MINT(81)=MAX(1,MSTP(134))
8227 IF(WTR.LE.0D0) GOTO 150
8233 C...Format statement for error message.
8234 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
8235 &'crossing too large, ',1P,D12.4)
8240 C*********************************************************************
8243 C...Saves and restores parameter and cross section values for the
8244 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8245 C...Also makes random choice between alternatives.
8247 SUBROUTINE PYSAVE(ISAVE,IGA)
8249 C...Double precision and integer declarations.
8250 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8251 IMPLICIT INTEGER(I-N)
8252 INTEGER PYK,PYCHGE,PYCOMP
8254 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8255 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8256 COMMON/PYINT1/MINT(400),VINT(400)
8257 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8258 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8259 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8260 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
8261 C...Local arrays and saved variables.
8262 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
8263 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
8264 &INTCP(15,20),RECP(15,20)
8265 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
8267 C...Save list of subprocesses and cross-section information.
8271 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
8274 MSUBCP(IGA,ICP)=MSUB(I)
8276 COEFCP(IGA,ICP,J)=COEF(I,J)
8279 NGENCP(IGA,ICP,J)=NGEN(I,J)
8280 XSECCP(IGA,ICP,J)=XSEC(I,J)
8285 NGENCP(IGA,0,J)=NGEN(0,J)
8286 XSECCP(IGA,0,J)=XSEC(0,J)
8291 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
8296 C...Save various common process variables.
8298 INTCP(IGA,J)=MINT(40+J)
8300 INTCP(IGA,11)=MINT(101)
8301 INTCP(IGA,12)=MINT(102)
8302 INTCP(IGA,13)=MINT(107)
8303 INTCP(IGA,14)=MINT(108)
8304 INTCP(IGA,15)=MINT(123)
8306 RECP(IGA,2)=VINT(318)
8308 C...Save cross-section information only.
8309 ELSEIF(ISAVE.EQ.2) THEN
8310 DO 190 ICP=1,NCP(IGA)
8313 NGENCP(IGA,ICP,J)=NGEN(I,J)
8314 XSECCP(IGA,ICP,J)=XSEC(I,J)
8318 NGENCP(IGA,0,J)=NGEN(0,J)
8319 XSECCP(IGA,0,J)=XSEC(0,J)
8322 C...Choose between allowed alternatives.
8323 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8326 DO 210 IG=1,MINT(121)
8327 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8329 XSUMCP=XSUMCP*PYR(0)
8330 DO 220 IG=1,MINT(121)
8332 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8333 IF(XSUMCP.LE.0D0) GOTO 230
8338 C...Restore cross-section information.
8342 DO 270 ICP=1,NCP(IGA)
8344 MSUB(I)=MSUBCP(IGA,ICP)
8346 COEF(I,J)=COEFCP(IGA,ICP,J)
8349 NGEN(I,J)=NGENCP(IGA,ICP,J)
8350 XSEC(I,J)=XSECCP(IGA,ICP,J)
8354 NGEN(0,J)=NGENCP(IGA,0,J)
8355 XSEC(0,J)=XSECCP(IGA,0,J)
8360 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8365 C...Restore various common process variables.
8367 MINT(40+J)=INTCP(IGA,J)
8369 MINT(101)=INTCP(IGA,11)
8370 MINT(102)=INTCP(IGA,12)
8371 MINT(107)=INTCP(IGA,13)
8372 MINT(108)=INTCP(IGA,14)
8373 MINT(123)=INTCP(IGA,15)
8376 VINT(318)=RECP(IGA,2)
8378 C...Sum up cross-section info (for PYSTAT).
8379 ELSEIF(ISAVE.EQ.5) THEN
8390 DO 350 IG=1,MINT(121)
8391 DO 340 ICP=1,NCP(IG)
8393 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8394 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8395 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8396 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8398 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8399 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8400 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8401 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8408 C*********************************************************************
8411 C...For lepton beams it gives photon-hadron or photon-photon systems
8412 C...to be treated with the ordinary machinery and combines this with a
8413 C...description of the lepton -> lepton + photon branching.
8415 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8417 C...Double precision and integer declarations.
8418 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8419 IMPLICIT INTEGER(I-N)
8420 INTEGER PYK,PYCHGE,PYCOMP
8422 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8423 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8424 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8425 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8426 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8427 COMMON/PYINT1/MINT(400),VINT(400)
8428 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8429 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8431 C...Local variables and data statement.
8432 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8433 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8434 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8437 C...Initialize generation of photons inside leptons.
8440 C...Save quantities on incoming lepton system.
8444 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8446 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8447 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8448 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8450 C...Calculate range of x and Q2 values allowed in generation.
8452 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8453 IF(MINT(140+I).NE.0) THEN
8454 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8455 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8457 YMIN=MAX(CKIN(71+2*I),EPS)
8458 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8459 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8460 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8461 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8462 THEMIN=MAX(CKIN(67+2*I),0D0)
8463 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8464 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8465 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8466 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8467 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8468 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8469 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8470 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8471 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8472 C...W limits when lepton on one side only.
8473 IF(MINT(143-I).EQ.0) THEN
8474 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8475 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8476 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8481 C...W limits when lepton on both sides.
8482 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8483 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8484 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8485 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8486 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8487 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8488 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8489 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8490 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8491 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8493 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8494 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8498 C...Q2 and W values and photon flux weight factors for initialization.
8499 ELSEIF(IGAGA.EQ.2) THEN
8504 C...W value for photon on one or both sides, and for processes
8505 C...with gamma-gamma cross section peaked at small shat.
8506 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8507 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8508 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8509 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8510 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8511 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8512 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8514 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8515 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8517 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8519 C...Upper estimate of photon flux weight factor.
8520 C...Initialization Q2 scale. Flag incoming unresolved photon.
8523 IF(MINT(140+I).NE.0) THEN
8524 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8525 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8526 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8528 Q2INIT=5D0+Q2MIN(3-I)
8529 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8530 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8531 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8532 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8533 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8534 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8536 ELSEIF(ISUB.EQ.140) THEN
8541 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8542 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8544 VINT(306+I)=VINT(2+I)**2
8549 C...Update pTmin and cross section information.
8550 IF(MSTP(82).LE.1) THEN
8551 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8553 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8555 VINT(149)=4D0*PTMN**2/VINT(2)
8560 C...Generate photons inside leptons and
8561 C...calculate photon flux weight factors.
8562 ELSEIF(IGAGA.EQ.3) THEN
8567 C...Generate phase space point and check against cuts.
8571 IF(MINT(140+I).NE.0) THEN
8573 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8574 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8575 C...Cuts on internal consistency in x and Q2.
8576 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8577 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8578 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8579 C...Cuts on y and theta.
8580 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8581 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8582 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8583 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8584 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8585 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8586 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8589 C...Phi angle isotropic. Reconstruct pT.
8590 PHI(I)=PARU(2)*PYR(0)
8591 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8592 & PMS(I))*SIN(THETA(I))
8594 C...Store info on variables selected, for documentation purposes.
8595 VINT(2+I)=-SQRT(Q2(I))
8599 VINT(310+I)=THETA(I)
8610 C...Cut on W combines info from two sides.
8611 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8612 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8613 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8614 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8615 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8616 IF(W2.LT.W2MIN) GOTO 120
8617 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8620 ELSEIF(MINT(141).NE.0) THEN
8621 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8624 ELSEIF(MINT(142).NE.0) THEN
8625 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8630 C...Store kinematics info for photon(s) in subsystem cm frame.
8635 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8636 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8637 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8640 VINT(298)=-VINT(293)
8641 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8642 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8644 C...Assign weight for photon flux; different for transverse and
8645 C...longitudinal photons. Flag incoming unresolved photon.
8648 IF(MINT(140+I).NE.0) THEN
8649 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8650 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8651 IF(MSTP(16).EQ.0) THEN
8654 WTGAGA=WTGAGA*X(I)/Y(I)
8657 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8658 WTGAGA=WTGAGA*(1D0-XY)
8659 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
8660 WTGAGA=WTGAGA*(1D0-XY)
8661 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
8662 WTGAGA=WTGAGA*(1D0-XY)
8664 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
8665 & PMS(I)*XY**2/Q2(I))
8667 IF(MINT(106+I).EQ.0) MINT(14+I)=22
8673 C...Update pTmin and cross section information.
8674 IF(MSTP(82).LE.1) THEN
8675 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8677 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8679 VINT(149)=4D0*PTMN**2/VINT(2)
8683 C...Reconstruct kinematics of photons inside leptons.
8684 ELSEIF(IGAGA.EQ.4) THEN
8686 C...Make place for incoming particles and scattered leptons.
8688 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
8689 MINT(4)=MINT(4)+MOVE
8690 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
8691 IF(K(I,1).EQ.21) THEN
8697 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8698 & K(I+MOVE,3)=K(I,3)+MOVE
8699 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
8700 & K(I+MOVE,4)=K(I,4)+MOVE
8701 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
8702 & K(I+MOVE,5)=K(I,5)+MOVE
8705 DO 170 I=MINT(84)+1,N
8706 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8707 & K(I,3)=K(I,3)+MOVE
8710 C...Fill in incoming particles.
8711 DO 190 I=MINT(83)+1,MINT(83)+MOVE
8720 IF(MINT(140+I).NE.0) THEN
8721 K(MINT(83)+I,2)=MINT(140+I)
8722 P(MINT(83)+I,5)=VINT(302+I)
8724 K(MINT(83)+I,2)=MINT(10+I)
8725 P(MINT(83)+I,5)=VINT(2+I)
8727 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
8728 & VINT(302))*(-1D0)**(I+1)
8729 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
8732 C...New mother-daughter relations in documentation section.
8733 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8734 K(MINT(83)+1,4)=MINT(83)+3
8735 K(MINT(83)+1,5)=MINT(83)+5
8736 K(MINT(83)+2,4)=MINT(83)+4
8737 K(MINT(83)+2,5)=MINT(83)+6
8738 K(MINT(83)+3,3)=MINT(83)+1
8739 K(MINT(83)+5,3)=MINT(83)+1
8740 K(MINT(83)+4,3)=MINT(83)+2
8741 K(MINT(83)+6,3)=MINT(83)+2
8742 ELSEIF(MINT(141).NE.0) THEN
8743 K(MINT(83)+1,4)=MINT(83)+3
8744 K(MINT(83)+1,5)=MINT(83)+4
8745 K(MINT(83)+2,4)=MINT(83)+5
8746 K(MINT(83)+3,3)=MINT(83)+1
8747 K(MINT(83)+4,3)=MINT(83)+1
8748 K(MINT(83)+5,3)=MINT(83)+2
8749 ELSEIF(MINT(142).NE.0) THEN
8750 K(MINT(83)+1,4)=MINT(83)+4
8751 K(MINT(83)+2,4)=MINT(83)+3
8752 K(MINT(83)+2,5)=MINT(83)+5
8753 K(MINT(83)+3,3)=MINT(83)+2
8754 K(MINT(83)+4,3)=MINT(83)+1
8755 K(MINT(83)+5,3)=MINT(83)+2
8758 C...Fill scattered lepton(s).
8760 IF(MINT(140+I).NE.0) THEN
8761 LSC=MINT(83)+MIN(I+2,MOVE)
8763 K(LSC,2)=MINT(140+I)
8764 P(LSC,1)=PT(I)*COS(PHI(I))
8765 P(LSC,2)=PT(I)*SIN(PHI(I))
8766 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
8767 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
8769 P(LSC,5)=VINT(302+I)
8773 C...Find incoming four-vectors to subprocess.
8775 IF(MINT(141).NE.0) THEN
8777 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
8781 P(N+1,J)=P(MINT(83)+1,J)
8785 IF(MINT(142).NE.0) THEN
8787 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
8791 P(N+2,J)=P(MINT(83)+2,J)
8795 C...Define boost and rotation between hadronic subsystem and
8796 C...collision rest frame; boost hadronic subsystem to this frame.
8798 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
8800 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
8801 BPHI=PYANGL(P(N+1,1),P(N+1,2))
8802 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
8803 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
8804 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
8807 C...Add on scattered leptons to final state.
8809 IF(MINT(140+I).NE.0) THEN
8810 LSC=MINT(83)+MIN(I+2,MOVE)
8826 C*********************************************************************
8829 C...Generates quantities characterizing the high-pT scattering at the
8830 C...parton level according to the matrix elements. Chooses incoming,
8831 C...reacting partons, their momentum fractions and one of the possible
8836 C...Double precision and integer declarations.
8837 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8838 IMPLICIT INTEGER(I-N)
8839 INTEGER PYK,PYCHGE,PYCOMP
8840 C...Parameter statement to help give large particle numbers.
8841 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
8842 &KEXCIT=4000000,KDIMEN=5000000)
8844 C...User process initialization and event commonblocks.
8846 PARAMETER (MAXPUP=100)
8847 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
8848 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
8849 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
8850 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
8853 PARAMETER (MAXNUP=500)
8854 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
8855 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
8856 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
8857 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
8858 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
8859 SAVE /HEPRUP/,/HEPEUP/
8862 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8863 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8864 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
8865 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8866 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8867 COMMON/PYINT1/MINT(400),VINT(400)
8868 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8869 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8870 COMMON/PYINT4/MWID(500),WIDS(500,5)
8871 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8872 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8873 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
8874 COMMON/PYTCCO/COEFX(194:380,2)
8875 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
8876 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
8877 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
8880 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
8882 C...Parameters and data used in elastic/diffractive treatment.
8883 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
8884 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
8886 C...Initial values, specifically for (first) semihard interaction.
8895 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
8904 C...Start by assuming incoming photon is entering subprocess.
8905 IF(MINT(11).EQ.22) THEN
8907 VINT(307)=VINT(3)**2
8909 IF(MINT(12).EQ.22) THEN
8911 VINT(308)=VINT(4)**2
8916 C...Choice of process type - first event of pileup.
8918 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
8919 ELSEIF(MINT(82).EQ.1) THEN
8921 C...For gamma-p or gamma-gamma first pick between alternatives.
8923 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
8926 C...For real gamma + gamma with different nature, flip at random.
8927 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
8928 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
8938 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
8941 C...Pick process type, possibly by user process machinery.
8942 C...(If the latter, also event will be picked here.)
8943 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
8946 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
8951 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
8952 & ISUB.LT.500) GOTO 110
8954 RSUB=XSEC(0,1)*PYR(0)
8956 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
8959 IF(RSUB.LE.0D0) GOTO 130
8961 130 IF(ISUB.EQ.95) ISUB=96
8962 IF(ISUB.EQ.96) INMULT=1
8963 IF(ISET(ISUB).EQ.11) THEN
8970 C...Choice of inclusive process type - pileup events.
8971 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
8972 RSUB=VINT(131)*PYR(0)
8974 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
8975 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
8976 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
8977 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
8979 IF(ISUB.EQ.96) INMULT=1
8982 C...Choice of photon energy and flux factor inside lepton.
8983 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
8984 CALL PYGAGA(3,WTGAGA)
8985 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
8986 CKIN(3)=MAX(VINT(285),VINT(154))
8989 C...When necessary set direct/resolved photon by hand.
8990 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
8991 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
8992 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
8995 C...Restrict direct*resolved processes to pTmin >= Q,
8996 C...to avoid doublecounting with DIS.
8997 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
8998 IF(MINT(15).EQ.22) THEN
8999 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
9001 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
9006 C...Set up for multiple interactions (may include impact parameter).
9007 IF(INMULT.EQ.1) THEN
9008 IF(MINT(35).LE.1) CALL PYMULT(2)
9009 IF(MINT(35).GE.2) CALL PYMIGN(2)
9012 C...Loopback point for minimum bias in photon physics.
9015 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
9016 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
9017 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
9018 &NGEN(97,1)=NGEN(97,1)+MINT(143)
9022 C...Random choice of flavour for some SUSY processes.
9023 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
9024 C...~e_L ~nu_e or ~mu_L ~nu_mu.
9025 IF(ISUB.EQ.210) THEN
9026 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
9027 KFPR(ISUB,2)=KFPR(ISUB,1)+1
9028 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9029 ELSEIF(ISUB.EQ.213) THEN
9030 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
9031 KFPR(ISUB,2)=KFPR(ISUB,1)
9032 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9033 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
9035 IF(ISUB.GE.258) THEN
9040 IF(MOD(ISUB,2).EQ.0) THEN
9041 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
9043 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
9045 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9046 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
9047 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
9050 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
9053 ELSEIF(PYR(0).LT.0.5D0) THEN
9060 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
9061 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
9062 C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9063 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
9064 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
9065 KFPR(ISUB,2)=KFPR(ISUB,1)
9066 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
9067 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
9068 KFPR(ISUB,2)=KFPR(ISUB,1)
9069 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9070 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
9071 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
9074 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
9077 ELSEIF(PYR(0).LT.0.5D0) THEN
9084 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
9089 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
9093 C...Find resonances (explicit or implicit in cross-section).
9096 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
9098 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
9099 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
9101 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
9104 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
9106 IF(MSTP(46).EQ.5) THEN
9109 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
9113 IF(CKMX.LE.0D0) CKMX=VINT(1)
9116 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
9117 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
9120 TAUR1=PMAS(KCR1,1)**2/VINT(2)
9121 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
9129 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
9130 $(ISUB.GE.361.AND.ISUB.LE.380))
9133 IF(ISUB.EQ.141) THEN
9135 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
9136 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
9139 TAUR2=PMAS(KCR2,1)**2/VINT(2)
9140 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
9146 C...3 resonances at work: rho, omega, a
9147 ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
9148 & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
9151 VINT(73)=XMAS(1)**2/VINT(2)
9152 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
9158 VINT(75)=XMAS(2)**2/VINT(2)
9159 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
9165 VINT(77)=XMAS(3)**2/VINT(2)
9166 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
9171 C...Charged current: rho+- and a+-
9172 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
9175 VINT(73)=YMAS(1)**2/VINT(2)
9176 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
9182 VINT(75)=YMAS(2)**2/VINT(2)
9183 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
9190 IF(ISUB.NE.141) THEN
9191 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
9193 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
9195 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
9200 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
9208 ELSEIF(KFR1.NE.0) THEN
9210 ELSEIF(KFR2.NE.0) THEN
9215 ELSEIF(KFR3.NE.0) THEN
9224 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
9226 ELSEIF(KFR2.NE.0) THEN
9241 C...Find product masses and minimum pT of process,
9242 C...optionally with broadening according to a truncated Breit-Wigner.
9247 IF(MINT(82).GE.2) VINT(71)=0D0
9249 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9253 IF(KFPR(ISUB,I).EQ.0) THEN
9254 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
9256 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
9259 C...This prevents SUSY/t particles from becoming too light.
9261 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9264 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9265 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9266 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9267 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9268 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9269 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9270 PMMN(I)=MIN(PMMN(I),PMSUM)
9273 ELSEIF(KFLW.EQ.6) THEN
9274 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9281 CKIN(41)=MAX(PMMN(1),CKIN(41))
9282 CKIN(43)=MAX(PMMN(2),CKIN(43))
9283 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
9286 IF(MINT(51).EQ.1) THEN
9287 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9297 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
9298 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
9301 C...Prepare for additional variable choices in 2 -> 3.
9304 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
9306 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
9307 VINT(204)=PMAS(23,1)
9308 IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
9309 & VINT(204)=PMAS(24,1)
9310 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
9311 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
9312 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
9313 & VINT(204)=VINT(201)
9315 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
9318 C...Select incoming VDM particle (rho/omega/phi/J/psi).
9319 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
9320 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
9321 VRN=PYR(0)*SIGT(0,0,5)
9322 IF(MINT(101).LE.1) THEN
9329 IF(MINT(102).LE.1) THEN
9340 VRN=VRN-SIGT(I1,I2,5)
9341 IF(VRN.LE.0D0) GOTO 190
9344 190 IF(MINT(101).GE.2) MINT(103)=KFV1
9345 IF(MINT(102).GE.2) MINT(104)=KFV2
9349 C...Elastic scattering or single or double diffractive scattering.
9351 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9356 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
9358 VRN=PYR(0)*SIGT(0,0,JJ)
9359 IF(MINT(101).LE.1) THEN
9366 IF(MINT(102).LE.1) THEN
9377 VRN=VRN-SIGT(I1,I2,JJ)
9378 IF(VRN.LE.0D0) GOTO 220
9381 220 IF(MINT(101).GE.2) THEN
9385 IF(MINT(102).GE.2) THEN
9393 C...Select mass for GVMD states (rejecting previous assignment).
9395 Q1S=4D0*VINT(154)**2
9399 IF(MINT(106+JT).EQ.3) THEN
9401 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
9402 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
9403 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9404 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9407 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9408 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9413 C...Side/sides of diffractive system.
9416 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9417 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9419 C...Find masses of particles and minimal masses of diffractive states.
9422 VINT(68+JT)=PDIF(JT)
9423 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9430 SMRES1=(PMM(1)+PMRC)**2
9431 SMRES2=(PMM(2)+PMRC)**2
9433 C...Find elastic slope and lower limit diffractive slope.
9434 IHA=MAX(2,IABS(MINT(103))/110)
9436 IHB=MAX(2,IABS(MINT(104))/110)
9439 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9440 ELSEIF(ISUB.EQ.92) THEN
9441 BMN=MAX(2D0,2D0*BHAD(IHB))
9442 ELSEIF(ISUB.EQ.93) THEN
9443 BMN=MAX(2D0,2D0*BHAD(IHA))
9444 ELSEIF(ISUB.EQ.94) THEN
9448 C...Determine maximum possible t range and coefficient of generation.
9449 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9450 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9451 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9452 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9453 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9454 & (SQM1*SQM4-SQM2*SQM3)/SH
9455 THL=-0.5D0*(THA+THB)
9457 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9459 C...Select diffractive mass/masses according to dm^2/m^2.
9463 IF(MINT(16+JT).EQ.0) THEN
9467 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9468 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9474 C..Additional mass factors, including resonance enhancement.
9475 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9476 IF(LOOP3.LT.100) GOTO 260
9480 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9481 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9482 ELSEIF(ISUB.EQ.93) THEN
9483 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9484 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9485 ELSEIF(ISUB.EQ.94) THEN
9486 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9487 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9488 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9489 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9492 C...Select t according to exp(Bmn*t) and correct to right slope.
9493 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9496 BADD=2D0*ALP*LOG(SH/SQM3)
9497 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9498 ELSEIF(ISUB.EQ.93) THEN
9499 BADD=2D0*ALP*LOG(SH/SQM4)
9500 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9501 ELSEIF(ISUB.EQ.94) THEN
9502 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9504 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9507 C...Check whether m^2 and t choices are consistent.
9508 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9509 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9510 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9511 IF(THB.LE.1D-8) GOTO 260
9512 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9513 & (SQM1*SQM4-SQM2*SQM3)/SH
9514 THLM=-0.5D0*(THA+THB)
9516 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9518 C...Information to output.
9521 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9523 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9526 VINT(283)=PMM(1)**2/4D0
9527 VINT(284)=PMM(2)**2/4D0
9529 C...Note: in the following, by In is meant the integral over the
9530 C...quantity multiplying coefficient cn.
9531 C...Choose tau according to h1(tau)/tau, where
9532 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9533 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9534 C...I1/I5*c5*1/(tau+tau_R') +
9535 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9536 C...I1/I7*c7*tau/(1.-tau), and
9537 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9538 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9540 IF(MINT(51).NE.0) THEN
9541 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9550 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9551 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9552 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9553 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9555 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9556 & COEF(ISUB,5)) MTAU=6
9557 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9558 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9559 C...Additional check to handle techni-processes with extra resonance
9560 C....Only modify tau treatment
9561 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
9563 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9564 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
9565 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9566 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
9567 & +COEFX(ISUB,1)) MTAU=9
9569 CALL PYKMAP(1,MTAU,PYR(0))
9571 C...2 -> 3, 4 processes:
9572 C...Choose tau' according to h4(tau,tau')/tau', where
9573 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9574 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9575 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9577 IF(MINT(51).NE.0) THEN
9578 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9587 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9588 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9589 CALL PYKMAP(4,MTAUP,PYR(0))
9592 C...Choose y* according to h2(y*), where
9593 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9594 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9595 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9596 C...and c1 + c2 + c3 + c4 + c5 = 1.
9598 IF(MINT(51).NE.0) THEN
9599 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9608 IF(RYST.GT.COEF(ISUB,8)) MYST=2
9609 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
9610 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
9611 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
9612 & COEF(ISUB,11)) MYST=5
9613 CALL PYKMAP(2,MYST,PYR(0))
9615 C...2 -> 2 processes:
9616 C...Choose cos(theta-hat) (cth) according to h3(cth), where
9617 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
9618 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
9619 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
9620 C...and c0 + c1 + c2 + c3 + c4 = 1.
9622 IF(MINT(51).NE.0) THEN
9623 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9630 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9633 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
9634 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
9635 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
9636 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
9637 & COEF(ISUB,16)) MCTH=5
9638 CALL PYKMAP(3,MCTH,PYR(0))
9641 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
9643 CALL PYKMAP(5,0,0D0)
9644 IF(MINT(51).NE.0) THEN
9645 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9654 C...DIS as f + gamma* -> f process: set dummy values.
9655 ELSEIF(ISTSB.EQ.8) THEN
9662 C...Low-pT or multiple interactions (first semihard interaction).
9663 ELSEIF(ISTSB.EQ.9) THEN
9664 IF(MINT(35).LE.1) CALL PYMULT(3)
9665 IF(MINT(35).GE.2) CALL PYMIGN(3)
9668 C...Study user-defined process: kinematics plus weight.
9669 ELSEIF(ISTSB.EQ.11) THEN
9670 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
9671 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
9676 IF(MINT(82).EQ.1) THEN
9677 NGEN(0,1)=NGEN(0,1)-1
9678 NGEN(ISUB,1)=NGEN(ISUB,1)-1
9680 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9684 C...Extract cross section event weight.
9685 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
9688 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
9690 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
9691 VINT(97)=SIGN(1D0,XWGTUP)
9693 VINT(97)=1D-9*XWGTUP
9696 C...Construct 'trivial' kinematical variables needed.
9699 VINT(41)=PUP(4,1)/EBMUP(1)
9700 VINT(42)=PUP(4,2)/EBMUP(2)
9701 IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
9702 CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
9703 & '(listing follows):')
9706 VINT(21)=VINT(41)*VINT(42)
9707 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
9708 VINT(44)=VINT(21)*VINT(2)
9709 VINT(43)=SQRT(MAX(0D0,VINT(44)))
9711 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
9712 VINT(56)=VINT(55)**2
9716 C...Construct other kinematical variables needed (approximately).
9719 VINT(45)=-0.5D0*VINT(44)
9720 VINT(46)=-0.5D0*VINT(44)
9729 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
9730 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
9732 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
9733 & '(PYRAND:) unacceptable ISTUP code for particles')
9734 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
9735 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
9736 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
9739 VINT(47)=SQRT(VINT(48))
9742 C...Choose azimuthal angle.
9744 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
9746 C...Check against user cuts on kinematics at parton level.
9748 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
9749 IF(MINT(51).NE.0) THEN
9750 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9757 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
9759 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
9762 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9771 C...Calculate differential cross-section for different subprocesses.
9772 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
9774 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
9776 C...Multiply cross section by lepton -> photon flux factor.
9777 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9780 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
9782 SIGLPT=WTGAGA*SIGLPT
9785 C...Multiply cross-section by user-defined weights.
9786 IF(MSTP(173).EQ.1) THEN
9789 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
9791 SIGLPT=PARP(173)*SIGLPT
9797 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
9798 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
9799 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
9802 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
9805 C...Calculations for Monte Carlo estimate of all cross-sections.
9806 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
9807 IF(MSTP(142).LE.1) THEN
9808 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
9810 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
9812 ELSEIF(MINT(82).EQ.1) THEN
9813 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
9815 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
9816 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
9818 C...Multiple interactions: store results of cross-section calculation.
9819 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
9821 IF(MINT(35).LE.1) CALL PYMULT(4)
9822 IF(MINT(35).GE.2) CALL PYMIGN(4)
9825 C...Ratio of actual to maximum cross section.
9826 IF(ISTSB.NE.11) THEN
9827 VIOL=SIGSWT/XSEC(ISUB,1)
9828 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
9829 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
9830 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
9831 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
9832 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
9837 C...Check that weight not negative.
9838 IF(MSTP(123).LE.0) THEN
9839 IF(VIOL.LT.-1D-3) THEN
9840 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
9841 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
9842 & VINT(22),VINT(23),VINT(26)
9846 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
9848 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
9849 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
9850 & VINT(22),VINT(23),VINT(26)
9854 C...Weighting using estimate of maximum of differential cross-section.
9856 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
9857 IF(VIOL.LT.PYR(0)) THEN
9858 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9859 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
9862 ELSEIF(MFAIL.EQ.0) THEN
9863 RATND=SIGLPT/XSEC(95,1)
9865 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
9866 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
9867 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
9868 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9872 IF(VIOL.LT.PYR(0)) THEN
9875 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
9876 IF(VIOL.LT.PYR(0)) THEN
9878 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9882 RATND=SIGLPT/XSEC(95,1)
9883 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
9885 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9889 IF(VIOL.LT.PYR(0)) THEN
9890 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9895 C...Check for possible violation of estimated maximum of differential
9896 C...cross-section used in weighting.
9897 IF(MSTP(123).LE.0) THEN
9898 IF(VIOL.GT.1D0) THEN
9899 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
9900 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9901 & VINT(22),VINT(23),VINT(26)
9904 ELSEIF(MSTP(123).EQ.1) THEN
9905 IF(VIOL.GT.VINT(108)) THEN
9907 IF(VIOL.GT.1.0001D0) THEN
9909 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
9910 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9911 & VINT(22),VINT(23),VINT(26)
9914 ELSEIF(VIOL.GT.VINT(108)) THEN
9916 IF(VIOL.GT.1D0) THEN
9918 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
9919 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
9921 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
9922 IF(KFPR(ISUB,1).LE.9) THEN
9923 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
9924 & XMAXUP(KFPR(ISUB,1))
9925 ELSEIF(KFPR(ISUB,1).LE.99) THEN
9926 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
9927 & XMAXUP(KFPR(ISUB,1))
9929 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
9930 & XMAXUP(KFPR(ISUB,1))
9933 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
9934 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
9935 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
9936 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
9937 & XSEC(0,1)=XSEC(0,1)+XDIF
9938 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9939 & VINT(22),VINT(23),VINT(26)
9941 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
9942 ELSEIF(ISUB.LE.99) THEN
9943 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
9945 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
9952 C...Multiple interactions: choose impact parameter (if not already done).
9953 IF(MINT(39).EQ.0) VINT(148)=1D0
9954 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
9955 &MSTP(82).GE.3) THEN
9956 IF(MINT(35).LE.1) CALL PYMULT(5)
9957 IF(MINT(35).GE.2) CALL PYMIGN(5)
9958 IF(VINT(150).LT.PYR(0)) THEN
9959 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9967 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
9968 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
9969 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
9970 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
9972 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
9974 C...Choose flavour of reacting partons (and subprocess).
9975 IF(ISTSB.GE.11) GOTO 320
9978 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
9979 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
9980 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
9981 &PYR(0).GT.RQQBAR)) THEN
9985 MINT(2)=ISIG(ICHN,3)
9986 RSIGS=RSIGS-SIGH(ICHN)
9987 IF(RSIGS.LE.0D0) GOTO 320
9990 C...Multiple interactions: choose qqbar preferentially at small pT.
9991 ELSEIF(ISUB.EQ.96) THEN
9994 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
9997 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
10000 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
10002 C...Low-pT: choose string drawing configuration.
10008 IF(RSIGS.GT.1D0) MINT(2)=2
10009 IF(RSIGS.GT.2D0) MINT(2)=3
10012 C...Reassign QCD process. Partons before initial state radiation.
10013 320 IF(MINT(2).GT.10) THEN
10015 MINT(2)=MOD(MINT(2),10)
10017 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
10028 C...Calculate x value of photon for parton inside photon inside e.
10033 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
10034 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
10035 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
10036 IF(MSPLI.EQ.2) THEN
10040 MINT(105)=MINT(102+JT)
10041 MINT(109)=MINT(106+JT)
10042 VINT(120)=VINT(2+JT)
10043 IF(MSTP(57).LE.1) THEN
10044 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
10046 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
10049 IF(MSTP(13).EQ.2) THEN
10050 Q2PMS=Q2HRD/PMAS(11,1)**2
10051 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
10053 330 XE=XHRD**PYR(0)
10054 XG=MIN(1D0-1D-10,XHRD/XE)
10055 IF(MSTP(57).LE.1) THEN
10056 CALL PYPDFU(22,XG,Q2HRD,XPQ)
10058 CALL PYPDFL(22,XG,Q2HRD,XPQ)
10060 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
10061 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
10062 IF(WT.LT.PYR(0)*WTMX) GOTO 330
10066 XSFX(JT,KFLS)=XPQ(KFLS)
10071 C...Pick scale where photon is resolved.
10075 IF(MINT(107).EQ.3) THEN
10076 IF(MSTP(66).EQ.1) THEN
10077 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
10078 ELSEIF(MSTP(66).EQ.2) THEN
10080 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10081 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10082 Q2INT=SQRT(Q0S*Q2EFF)
10083 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10084 ELSEIF(MSTP(66).EQ.3) THEN
10085 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
10086 ELSEIF(MSTP(66).GE.4) THEN
10087 PS=0.25D0*VINT(3)**2
10088 VINT(283)=(Q0S+PS)*(Q1S+PS)/
10089 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10093 IF(MINT(108).EQ.3) THEN
10094 IF(MSTP(66).EQ.1) THEN
10095 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
10096 ELSEIF(MSTP(66).EQ.2) THEN
10098 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10099 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10100 Q2INT=SQRT(Q0S*Q2EFF)
10101 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10102 ELSEIF(MSTP(66).EQ.3) THEN
10103 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
10104 ELSEIF(MSTP(66).GE.4) THEN
10105 PS=0.25D0*VINT(4)**2
10106 VINT(284)=(Q0S+PS)*(Q1S+PS)/
10107 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10110 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10112 C...Format statements for differential cross-section maximum violations.
10113 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
10114 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10115 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
10116 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
10117 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
10119 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
10120 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10121 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
10123 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
10124 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
10125 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
10126 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
10127 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
10128 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
10133 C*********************************************************************
10136 C...Finds outgoing flavours and event type; sets up the kinematics
10137 C...and colour flow of the hard scattering
10141 C...Double precision and integer declarations
10142 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10143 IMPLICIT INTEGER(I-N)
10144 INTEGER PYK,PYCHGE,PYCOMP
10145 C...Parameter statement to help give large particle numbers.
10146 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
10147 &KEXCIT=4000000,KDIMEN=5000000)
10148 C...Parameter statement for maximum size of showers.
10149 PARAMETER (MAXNUR=1000)
10151 C...User process event common block.
10153 PARAMETER (MAXNUP=500)
10154 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10155 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10156 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
10157 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
10158 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
10162 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
10163 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10164 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10165 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10166 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
10167 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10168 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10169 COMMON/PYINT1/MINT(400),VINT(400)
10170 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10171 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10172 COMMON/PYINT4/MWID(500),WIDS(500,5)
10173 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10174 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
10175 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
10176 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
10177 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
10178 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
10180 C...Local arrays and saved variables
10181 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
10182 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
10185 C...Read out process
10189 C...Restore information for low-pT processes
10190 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
10192 100 VINT(J)=VINTSV(J)
10195 C...Convert H' or A process into equivalent H one
10198 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
10199 &ISUB.LE.190)) THEN
10201 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
10203 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
10204 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
10205 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
10206 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
10207 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
10208 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
10209 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
10210 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
10211 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
10212 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
10213 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
10214 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
10217 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
10219 C...Convert bottomonium process into equivalent charmonium ones.
10220 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
10222 C...Choice of subprocess, number of documentation lines
10224 IF(ISUB.EQ.95) IDOC=8
10225 IF(ISET(ISUB).EQ.5) IDOC=9
10226 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
10228 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
10237 C...Reset K, P and V vectors. Store incoming particles
10238 DO 120 JT=1,MSTP(126)+100
10240 IF(I.GT.MSTU(4)) GOTO 120
10252 P(I,J)=VINT(285+5*JT+J)
10258 C...Store incoming partons in their CM-frame. Save pdf value.
10261 SHP=VINT(26)*VINT(2)
10264 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
10269 K(I,3)=MINT(83)+2+JT
10270 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
10271 P(I,4)=0.5D0*SHUSER
10272 VINT(38+JT)=XSFX(JT,MINT(14+JT))
10275 C...Copy incoming partons to documentation lines
10287 C...Choose new quark/lepton flavour for relevant annihilation graphs
10288 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
10289 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
10291 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
10292 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
10293 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
10294 DO 190 I=1,MDCY(IGLGA,3)
10295 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
10296 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
10297 IF(RKFL.LE.0D0) GOTO 200
10300 IF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.2) THEN
10301 IF(KFLF.GE.4) GOTO 180
10302 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.4) THEN
10305 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385) THEN
10308 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
10309 & .AND.IABS(KFLF).GE.3) THEN
10310 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
10312 FACCIB=VINT(46)**2/RTCM(41)**4
10313 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
10314 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
10317 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
10318 IF(KFLF.EQ.5) GOTO 180
10319 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10320 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
10321 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
10322 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
10326 C...Final state flavours and colour flow: default values
10333 KCS=ISIGN(1,MINT(15))
10335 IF(ISET(ISUB).EQ.11) THEN
10336 C...User-defined processes: find products
10339 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
10340 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
10341 MINT(21+IUP)=IDUP(IUP)
10342 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
10343 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
10344 ELSEIF(IDUP(IUP).EQ.0) THEN
10347 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
10351 ELSEIF(ISUB.LE.10) THEN
10353 C...f + fbar -> gamma*/Z0
10356 ELSEIF(ISUB.EQ.2) THEN
10357 C...f + fbar' -> W+/-
10358 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10359 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10360 KFRES=ISIGN(24,KCH1+KCH2)
10362 ELSEIF(ISUB.EQ.3) THEN
10363 C...f + fbar -> h0 (or H0, or A0)
10366 ELSEIF(ISUB.EQ.4) THEN
10367 C...gamma + W+/- -> W+/-
10369 ELSEIF(ISUB.EQ.5) THEN
10374 PMQ(1)=PYMASS(MINT(21))
10375 PMQ(2)=PYMASS(MINT(22))
10376 220 JT=INT(1.5D0+PYR(0))
10377 ZMIN=2D0*PMQ(JT)/SHPR
10378 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10379 & (SHPR*(SHPR-PMQ(3-JT)))
10380 ZMAX=MIN(1D0-XH,ZMAX)
10381 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10382 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10383 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
10384 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10385 IF(SQC1.LT.1D-8) GOTO 220
10387 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10388 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10389 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10390 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10391 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10392 IF(SQC1.LT.1D-8) GOTO 220
10394 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10395 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10396 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10397 PHIR=PARU(2)*PYR(0)
10399 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10400 & SQRT(1D0-CTHE(2)**2)*CPHI
10402 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10403 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10404 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10405 & PMQ(3-JT)**2/SHP))
10406 ZMIN=2D0*PMQ(3-JT)/SHPR
10407 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10408 ZMAX=MIN(1D0-XH,ZMAX)
10409 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10413 ELSEIF(ISUB.EQ.6) THEN
10414 C...Z0 + W+/- -> W+/-
10416 ELSEIF(ISUB.EQ.7) THEN
10419 ELSEIF(ISUB.EQ.8) THEN
10426 RVCKM=VINT(180+I)*PYR(0)
10429 IPM=(5-ISIGN(1,I))/2
10431 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10432 MINT(20+JT)=ISIGN(IB,I)
10433 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10434 IF(RVCKM.LE.0D0) GOTO 250
10437 IB=2*((IA+1)/2)-1+MOD(IA,2)
10438 MINT(20+JT)=ISIGN(IB,I)
10440 250 PMQ(JT)=PYMASS(MINT(20+JT))
10442 JT=INT(1.5D0+PYR(0))
10443 ZMIN=2D0*PMQ(JT)/SHPR
10444 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10445 & (SHPR*(SHPR-PMQ(3-JT)))
10446 ZMAX=MIN(1D0-XH,ZMAX)
10447 IF(ZMIN.GE.ZMAX) GOTO 230
10448 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10449 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10450 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10451 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10452 IF(SQC1.LT.1D-8) GOTO 230
10454 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10455 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10456 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10457 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10458 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10459 IF(SQC1.LT.1D-8) GOTO 230
10461 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10462 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10463 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10464 PHIR=PARU(2)*PYR(0)
10466 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10467 & SQRT(1D0-CTHE(2)**2)*CPHI
10469 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10470 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10471 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10472 & PMQ(3-JT)**2/SHP))
10473 ZMIN=2D0*PMQ(3-JT)/SHPR
10474 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10475 ZMAX=MIN(1D0-XH,ZMAX)
10476 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10480 ELSEIF(ISUB.EQ.10) THEN
10481 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10482 IF(MINT(2).EQ.1) THEN
10485 C...W exchange: need to mix flavours according to CKM matrix
10490 RVCKM=VINT(180+I)*PYR(0)
10493 IPM=(5-ISIGN(1,I))/2
10495 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10496 MINT(20+JT)=ISIGN(IB,I)
10497 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10498 IF(RVCKM.LE.0D0) GOTO 280
10501 IB=2*((IA+1)/2)-1+MOD(IA,2)
10502 MINT(20+JT)=ISIGN(IB,I)
10509 ELSEIF(ISUB.LE.20) THEN
10510 IF(ISUB.EQ.11) THEN
10511 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10513 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10515 ELSEIF(ISUB.EQ.12) THEN
10516 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10517 MINT(21)=ISIGN(KFLF,MINT(15))
10521 ELSEIF(ISUB.EQ.13) THEN
10522 C...f + fbar -> g + g; th arbitrary
10527 ELSEIF(ISUB.EQ.14) THEN
10528 C...f + fbar -> g + gamma; th arbitrary
10529 IF(PYR(0).GT.0.5D0) JS=2
10534 ELSEIF(ISUB.EQ.15) THEN
10535 C...f + fbar -> g + Z0; th arbitrary
10536 IF(PYR(0).GT.0.5D0) JS=2
10541 ELSEIF(ISUB.EQ.16) THEN
10542 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10543 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10544 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10545 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10547 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10550 ELSEIF(ISUB.EQ.17) THEN
10551 C...f + fbar -> g + h0; th arbitrary
10552 IF(PYR(0).GT.0.5D0) JS=2
10557 ELSEIF(ISUB.EQ.18) THEN
10558 C...f + fbar -> gamma + gamma; th arbitrary
10562 ELSEIF(ISUB.EQ.19) THEN
10563 C...f + fbar -> gamma + Z0; th arbitrary
10564 IF(PYR(0).GT.0.5D0) JS=2
10568 ELSEIF(ISUB.EQ.20) THEN
10569 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
10570 C...(p(fbar')-p(W+))**2
10571 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10572 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10573 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10575 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10578 ELSEIF(ISUB.LE.30) THEN
10579 IF(ISUB.EQ.21) THEN
10580 C...f + fbar -> gamma + h0; th arbitrary
10581 IF(PYR(0).GT.0.5D0) JS=2
10585 ELSEIF(ISUB.EQ.22) THEN
10586 C...f + fbar -> Z0 + Z0; th arbitrary
10590 ELSEIF(ISUB.EQ.23) THEN
10591 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10592 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10593 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10594 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10596 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10598 ELSEIF(ISUB.EQ.24) THEN
10599 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
10600 IF(PYR(0).GT.0.5D0) JS=2
10604 ELSEIF(ISUB.EQ.25) THEN
10605 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
10606 MINT(21)=-ISIGN(24,MINT(15))
10609 ELSEIF(ISUB.EQ.26) THEN
10610 C...f + fbar' -> W+/- + h0 (or H0, or A0);
10611 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10612 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10613 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10614 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10615 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
10618 ELSEIF(ISUB.EQ.27) THEN
10619 C...f + fbar -> h0 + h0
10621 ELSEIF(ISUB.EQ.28) THEN
10622 C...f + g -> f + g; th = (p(f)-p(f))**2
10623 IF(MINT(15).EQ.21) JS=2
10625 IF(MINT(15).EQ.21) KCC=KCC+2
10626 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10627 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10629 ELSEIF(ISUB.EQ.29) THEN
10630 C...f + g -> f + gamma; th = (p(f)-p(f))**2
10631 IF(MINT(15).EQ.21) JS=2
10634 KCS=ISIGN(1,MINT(14+JS))
10636 ELSEIF(ISUB.EQ.30) THEN
10637 C...f + g -> f + Z0; th = (p(f)-p(f))**2
10638 IF(MINT(15).EQ.21) JS=2
10641 KCS=ISIGN(1,MINT(14+JS))
10644 ELSEIF(ISUB.LE.40) THEN
10645 IF(ISUB.EQ.31) THEN
10646 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
10647 IF(MINT(15).EQ.21) JS=2
10650 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10651 RVCKM=VINT(180+I)*PYR(0)
10654 IPM=(5-ISIGN(1,I))/2
10656 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
10657 MINT(20+JS)=ISIGN(IB,I)
10658 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10659 IF(RVCKM.LE.0D0) GOTO 300
10662 KCS=ISIGN(1,MINT(14+JS))
10664 ELSEIF(ISUB.EQ.32) THEN
10665 C...f + g -> f + h0; th = (p(f)-p(f))**2
10666 IF(MINT(15).EQ.21) JS=2
10669 KCS=ISIGN(1,MINT(14+JS))
10671 ELSEIF(ISUB.EQ.33) THEN
10672 C...f + gamma -> f + g; th=(p(f)-p(f))**2
10673 IF(MINT(15).EQ.22) JS=2
10676 KCS=ISIGN(1,MINT(14+JS))
10678 ELSEIF(ISUB.EQ.34) THEN
10679 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
10680 IF(MINT(15).EQ.22) JS=2
10682 KCS=ISIGN(1,MINT(14+JS))
10684 ELSEIF(ISUB.EQ.35) THEN
10685 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
10686 IF(MINT(15).EQ.22) JS=2
10690 ELSEIF(ISUB.EQ.36) THEN
10691 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
10692 IF(MINT(15).EQ.22) JS=2
10695 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10697 RVCKM=VINT(180+I)*PYR(0)
10700 IPM=(5-ISIGN(1,I))/2
10702 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
10703 MINT(20+JS)=ISIGN(IB,I)
10704 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10705 IF(RVCKM.LE.0D0) GOTO 320
10708 IB=2*((IA+1)/2)-1+MOD(IA,2)
10709 MINT(20+JS)=ISIGN(IB,I)
10713 ELSEIF(ISUB.EQ.37) THEN
10714 C...f + gamma -> f + h0
10716 ELSEIF(ISUB.EQ.38) THEN
10717 C...f + Z0 -> f + g
10719 ELSEIF(ISUB.EQ.39) THEN
10720 C...f + Z0 -> f + gamma
10722 ELSEIF(ISUB.EQ.40) THEN
10723 C...f + Z0 -> f + Z0
10726 ELSEIF(ISUB.LE.50) THEN
10727 IF(ISUB.EQ.41) THEN
10728 C...f + Z0 -> f' + W+/-
10730 ELSEIF(ISUB.EQ.42) THEN
10731 C...f + Z0 -> f + h0
10733 ELSEIF(ISUB.EQ.43) THEN
10734 C...f + W+/- -> f' + g
10736 ELSEIF(ISUB.EQ.44) THEN
10737 C...f + W+/- -> f' + gamma
10739 ELSEIF(ISUB.EQ.45) THEN
10740 C...f + W+/- -> f' + Z0
10742 ELSEIF(ISUB.EQ.46) THEN
10743 C...f + W+/- -> f' + W+/-
10745 ELSEIF(ISUB.EQ.47) THEN
10746 C...f + W+/- -> f' + h0
10748 ELSEIF(ISUB.EQ.48) THEN
10749 C...f + h0 -> f + g
10751 ELSEIF(ISUB.EQ.49) THEN
10752 C...f + h0 -> f + gamma
10754 ELSEIF(ISUB.EQ.50) THEN
10755 C...f + h0 -> f + Z0
10758 ELSEIF(ISUB.LE.60) THEN
10759 IF(ISUB.EQ.51) THEN
10760 C...f + h0 -> f' + W+/-
10762 ELSEIF(ISUB.EQ.52) THEN
10763 C...f + h0 -> f + h0
10765 ELSEIF(ISUB.EQ.53) THEN
10766 C...g + g -> f + fbar; th arbitrary
10767 KCS=(-1)**INT(1.5D0+PYR(0))
10768 MINT(21)=ISIGN(KFLF,KCS)
10772 ELSEIF(ISUB.EQ.54) THEN
10773 C...g + gamma -> f + fbar; th arbitrary
10774 KCS=(-1)**INT(1.5D0+PYR(0))
10775 MINT(21)=ISIGN(KFLF,KCS)
10778 IF(MINT(16).EQ.21) KCC=28
10780 ELSEIF(ISUB.EQ.55) THEN
10781 C...g + Z0 -> f + fbar
10783 ELSEIF(ISUB.EQ.56) THEN
10784 C...g + W+/- -> f + fbar'
10786 ELSEIF(ISUB.EQ.57) THEN
10787 C...g + h0 -> f + fbar
10789 ELSEIF(ISUB.EQ.58) THEN
10790 C...gamma + gamma -> f + fbar; th arbitrary
10791 KCS=(-1)**INT(1.5D0+PYR(0))
10792 MINT(21)=ISIGN(KFLF,KCS)
10796 ELSEIF(ISUB.EQ.59) THEN
10797 C...gamma + Z0 -> f + fbar
10799 ELSEIF(ISUB.EQ.60) THEN
10800 C...gamma + W+/- -> f + fbar'
10803 ELSEIF(ISUB.LE.70) THEN
10804 IF(ISUB.EQ.61) THEN
10805 C...gamma + h0 -> f + fbar
10807 ELSEIF(ISUB.EQ.62) THEN
10808 C...Z0 + Z0 -> f + fbar
10810 ELSEIF(ISUB.EQ.63) THEN
10811 C...Z0 + W+/- -> f + fbar'
10813 ELSEIF(ISUB.EQ.64) THEN
10814 C...Z0 + h0 -> f + fbar
10816 ELSEIF(ISUB.EQ.65) THEN
10817 C...W+ + W- -> f + fbar
10819 ELSEIF(ISUB.EQ.66) THEN
10820 C...W+/- + h0 -> f + fbar'
10822 ELSEIF(ISUB.EQ.67) THEN
10823 C...h0 + h0 -> f + fbar
10825 ELSEIF(ISUB.EQ.68) THEN
10826 C...g + g -> g + g; th arbitrary
10828 KCS=(-1)**INT(1.5D0+PYR(0))
10830 ELSEIF(ISUB.EQ.69) THEN
10831 C...gamma + gamma -> W+ + W-; th arbitrary
10836 ELSEIF(ISUB.EQ.70) THEN
10837 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
10838 IF(MINT(15).EQ.22) MINT(21)=23
10839 IF(MINT(16).EQ.22) MINT(22)=23
10843 ELSEIF(ISUB.LE.80) THEN
10844 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
10845 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
10849 PMQ(1)=PYMASS(MINT(21))
10850 PMQ(2)=PYMASS(MINT(22))
10851 330 JT=INT(1.5D0+PYR(0))
10852 ZMIN=2D0*PMQ(JT)/SHPR
10853 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10854 & (SHPR*(SHPR-PMQ(3-JT)))
10855 ZMAX=MIN(1D0-XH,ZMAX)
10856 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10857 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10858 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
10859 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10860 IF(SQC1.LT.1D-8) GOTO 330
10862 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10863 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10864 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10865 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10866 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10867 IF(SQC1.LT.1D-8) GOTO 330
10869 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10870 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10871 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10872 PHIR=PARU(2)*PYR(0)
10874 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10875 & SQRT(1D0-CTHE(2)**2)*CPHI
10877 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10878 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10879 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10880 & PMQ(3-JT)**2/SHP))
10881 ZMIN=2D0*PMQ(3-JT)/SHPR
10882 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10883 ZMAX=MIN(1D0-XH,ZMAX)
10884 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
10887 ELSEIF(ISUB.EQ.73) THEN
10888 C...Z0 + W+/- -> Z0 + W+/-
10895 RVCKM=VINT(180+I)*PYR(0)
10898 IPM=(5-ISIGN(1,I))/2
10900 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
10901 MINT(20+JT)=ISIGN(IB,I)
10902 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10903 IF(RVCKM.LE.0D0) GOTO 360
10906 IB=2*((IA+1)/2)-1+MOD(IA,2)
10907 MINT(20+JT)=ISIGN(IB,I)
10909 360 PMQ(JT)=PYMASS(MINT(20+JT))
10910 MINT(23-JT)=MINT(17-JT)
10911 PMQ(3-JT)=PYMASS(MINT(23-JT))
10912 JT=INT(1.5D0+PYR(0))
10913 ZMIN=2D0*PMQ(JT)/SHPR
10914 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10915 & (SHPR*(SHPR-PMQ(3-JT)))
10916 ZMAX=MIN(1D0-XH,ZMAX)
10917 IF(ZMIN.GE.ZMAX) GOTO 340
10918 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10919 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10920 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
10921 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10922 IF(SQC1.LT.1D-8) GOTO 340
10924 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10925 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10926 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10927 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10928 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10929 IF(SQC1.LT.1D-8) GOTO 340
10931 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10932 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10933 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10934 PHIR=PARU(2)*PYR(0)
10936 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10937 & SQRT(1D0-CTHE(2)**2)*CPHI
10939 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10940 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10941 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10942 & PMQ(3-JT)**2/SHP))
10943 ZMIN=2D0*PMQ(3-JT)/SHPR
10944 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10945 ZMAX=MIN(1D0-XH,ZMAX)
10946 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
10949 ELSEIF(ISUB.EQ.74) THEN
10950 C...Z0 + h0 -> Z0 + h0
10952 ELSEIF(ISUB.EQ.75) THEN
10953 C...W+ + W- -> gamma + gamma
10955 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
10956 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
10962 RVCKM=VINT(180+I)*PYR(0)
10965 IPM=(5-ISIGN(1,I))/2
10967 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
10968 MINT(20+JT)=ISIGN(IB,I)
10969 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10970 IF(RVCKM.LE.0D0) GOTO 390
10973 IB=2*((IA+1)/2)-1+MOD(IA,2)
10974 MINT(20+JT)=ISIGN(IB,I)
10976 390 PMQ(JT)=PYMASS(MINT(20+JT))
10978 JT=INT(1.5D0+PYR(0))
10979 ZMIN=2D0*PMQ(JT)/SHPR
10980 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10981 & (SHPR*(SHPR-PMQ(3-JT)))
10982 ZMAX=MIN(1D0-XH,ZMAX)
10983 IF(ZMIN.GE.ZMAX) GOTO 370
10984 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10985 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10986 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
10987 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10988 IF(SQC1.LT.1D-8) GOTO 370
10990 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10991 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10992 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10993 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10994 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10995 IF(SQC1.LT.1D-8) GOTO 370
10997 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10998 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10999 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11000 PHIR=PARU(2)*PYR(0)
11002 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11003 & SQRT(1D0-CTHE(2)**2)*CPHI
11005 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11006 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11007 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11008 & PMQ(3-JT)**2/SHP))
11009 ZMIN=2D0*PMQ(3-JT)/SHPR
11010 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11011 ZMAX=MIN(1D0-XH,ZMAX)
11012 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
11015 ELSEIF(ISUB.EQ.78) THEN
11016 C...W+/- + h0 -> W+/- + h0
11018 ELSEIF(ISUB.EQ.79) THEN
11019 C...h0 + h0 -> h0 + h0
11021 ELSEIF(ISUB.EQ.80) THEN
11022 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11023 IF(MINT(15).EQ.22) JS=2
11026 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
11028 MINT(20+JS)=ISIGN(IB,I)
11032 ELSEIF(ISUB.LE.90) THEN
11033 IF(ISUB.EQ.81) THEN
11034 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11035 MINT(21)=ISIGN(MINT(55),MINT(15))
11039 ELSEIF(ISUB.EQ.82) THEN
11040 C...g + g -> Q + Qbar; th arbitrary
11041 KCS=(-1)**INT(1.5D0+PYR(0))
11042 MINT(21)=ISIGN(MINT(55),KCS)
11046 ELSEIF(ISUB.EQ.83) THEN
11047 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11049 IF(MINT(2).EQ.2) KFOLD=MINT(15)
11051 IF(KFAOLD.GT.10) THEN
11052 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
11054 RCKM=VINT(180+KFOLD)*PYR(0)
11055 IPM=(5-ISIGN(1,KFOLD))/2
11056 KFANEW=-MOD(KFAOLD+1,2)
11057 410 KFANEW=KFANEW+2
11058 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
11059 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
11060 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
11061 & VCKM(KFAOLD/2,(KFANEW+1)/2)
11062 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
11063 & VCKM(KFANEW/2,(KFAOLD+1)/2)
11065 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
11067 IF(MINT(2).EQ.1) THEN
11068 MINT(21)=ISIGN(MINT(55),MINT(15))
11069 MINT(22)=ISIGN(KFANEW,MINT(16))
11071 MINT(21)=ISIGN(KFANEW,MINT(15))
11072 MINT(22)=ISIGN(MINT(55),MINT(16))
11077 ELSEIF(ISUB.EQ.84) THEN
11078 C...g + gamma -> Q + Qbar; th arbitary
11079 KCS=(-1)**INT(1.5D0+PYR(0))
11080 MINT(21)=ISIGN(MINT(55),KCS)
11083 IF(MINT(16).EQ.21) KCC=28
11085 ELSEIF(ISUB.EQ.85) THEN
11086 C...gamma + gamma -> F + Fbar; th arbitary
11087 KCS=(-1)**INT(1.5D0+PYR(0))
11088 MINT(21)=ISIGN(MINT(56),KCS)
11092 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
11093 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11094 MINT(21)=KFPR(ISUB,1)
11095 MINT(22)=KFPR(ISUB,2)
11097 KCS=(-1)**INT(1.5D0+PYR(0))
11100 ELSEIF(ISUB.LE.100) THEN
11101 IF(ISUB.EQ.95) THEN
11102 C...Low-pT ( = energyless g + g -> g + g)
11104 KCS=(-1)**INT(1.5D0+PYR(0))
11106 ELSEIF(ISUB.EQ.96) THEN
11107 C...Multiple interactions (should be reassigned to QCD process)
11110 ELSEIF(ISUB.LE.110) THEN
11111 IF(ISUB.EQ.101) THEN
11112 C...g + g -> gamma*/Z0
11116 ELSEIF(ISUB.EQ.102) THEN
11117 C...g + g -> h0 (or H0, or A0)
11121 ELSEIF(ISUB.EQ.103) THEN
11122 C...gamma + gamma -> h0 (or H0, or A0)
11126 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
11127 C...g + g -> chi_0c or chi_2c.
11131 ELSEIF(ISUB.EQ.106) THEN
11132 C...g + g -> J/Psi + gamma
11133 MINT(21)=KFPR(ISUB,1)
11134 MINT(22)=KFPR(ISUB,2)
11137 ELSEIF(ISUB.EQ.107) THEN
11138 C...g + gamma -> J/Psi + g
11139 MINT(21)=KFPR(ISUB,1)
11140 MINT(22)=KFPR(ISUB,2)
11142 IF(MINT(16).EQ.22) KCC=33
11144 ELSEIF(ISUB.EQ.108) THEN
11145 C...gamma + gamma -> J/Psi + gamma
11146 MINT(21)=KFPR(ISUB,1)
11147 MINT(22)=KFPR(ISUB,2)
11149 ELSEIF(ISUB.EQ.110) THEN
11150 C...f + fbar -> gamma + h0; th arbitrary
11151 IF(PYR(0).GT.0.5D0) JS=2
11156 ELSEIF(ISUB.LE.120) THEN
11157 IF(ISUB.EQ.111) THEN
11158 C...f + fbar -> g + h0; th arbitrary
11159 IF(PYR(0).GT.0.5D0) JS=2
11164 ELSEIF(ISUB.EQ.112) THEN
11165 C...f + g -> f + h0; th = (p(f) - p(f))**2
11166 IF(MINT(15).EQ.21) JS=2
11169 KCS=ISIGN(1,MINT(14+JS))
11171 ELSEIF(ISUB.EQ.113) THEN
11172 C...g + g -> g + h0; th arbitrary
11173 IF(PYR(0).GT.0.5D0) JS=2
11176 KCS=(-1)**INT(1.5D0+PYR(0))
11178 ELSEIF(ISUB.EQ.114) THEN
11179 C...g + g -> gamma + gamma; th arbitrary
11180 IF(PYR(0).GT.0.5D0) JS=2
11185 ELSEIF(ISUB.EQ.115) THEN
11186 C...g + g -> g + gamma; th arbitrary
11187 IF(PYR(0).GT.0.5D0) JS=2
11190 KCS=(-1)**INT(1.5D0+PYR(0))
11192 ELSEIF(ISUB.EQ.116) THEN
11193 C...g + g -> gamma + Z0
11195 ELSEIF(ISUB.EQ.117) THEN
11196 C...g + g -> Z0 + Z0
11198 ELSEIF(ISUB.EQ.118) THEN
11199 C...g + g -> W+ + W-
11202 ELSEIF(ISUB.LE.140) THEN
11203 IF(ISUB.EQ.121) THEN
11204 C...g + g -> Q + Qbar + h0
11205 KCS=(-1)**INT(1.5D0+PYR(0))
11206 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11208 KCC=11+INT(0.5D0+PYR(0))
11211 ELSEIF(ISUB.EQ.122) THEN
11212 C...q + qbar -> Q + Qbar + h0
11213 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
11218 ELSEIF(ISUB.EQ.123) THEN
11219 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11224 ELSEIF(ISUB.EQ.124) THEN
11225 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11231 RVCKM=VINT(180+I)*PYR(0)
11234 IPM=(5-ISIGN(1,I))/2
11236 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
11237 MINT(20+JT)=ISIGN(IB,I)
11238 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11239 IF(RVCKM.LE.0D0) GOTO 430
11242 IB=2*((IA+1)/2)-1+MOD(IA,2)
11243 MINT(20+JT)=ISIGN(IB,I)
11249 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
11250 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11251 IF(MINT(15).EQ.22) JS=2
11254 KCS=ISIGN(1,MINT(14+JS))
11256 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
11257 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11258 IF(MINT(15).EQ.22) JS=2
11260 KCS=ISIGN(1,MINT(14+JS))
11262 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
11263 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11264 KCS=(-1)**INT(1.5D0+PYR(0))
11265 MINT(21)=ISIGN(KFLF,KCS)
11268 IF(MINT(16).EQ.21) KCC=28
11270 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
11271 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11272 KCS=(-1)**INT(1.5D0+PYR(0))
11273 MINT(21)=ISIGN(KFLF,KCS)
11279 ELSEIF(ISUB.LE.160) THEN
11280 IF(ISUB.EQ.141) THEN
11281 C...f + fbar -> gamma*/Z0/Z'0
11284 ELSEIF(ISUB.EQ.142) THEN
11285 C...f + fbar' -> W'+/-
11286 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11287 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11288 KFRES=ISIGN(34,KCH1+KCH2)
11290 ELSEIF(ISUB.EQ.143) THEN
11291 C...f + fbar' -> H+/-
11292 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11293 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11294 KFRES=ISIGN(37,KCH1+KCH2)
11296 ELSEIF(ISUB.EQ.144) THEN
11298 KFRES=ISIGN(41,MINT(15)+MINT(16))
11300 ELSEIF(ISUB.EQ.145) THEN
11301 C...q + l -> LQ (leptoquark)
11302 IF(IABS(MINT(16)).LE.8) JS=2
11303 KFRES=ISIGN(42,MINT(14+JS))
11305 KCS=ISIGN(1,MINT(14+JS))
11307 ELSEIF(ISUB.EQ.146) THEN
11308 C...e + gamma -> e* (excited lepton)
11309 IF(MINT(15).EQ.22) JS=2
11310 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11313 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
11314 C...q + g -> q* (excited quark)
11315 IF(MINT(15).EQ.21) JS=2
11316 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11318 KCS=ISIGN(1,MINT(14+JS))
11320 ELSEIF(ISUB.EQ.149) THEN
11321 C...g + g -> eta_tc
11324 KCS=(-1)**INT(1.5D0+PYR(0))
11327 ELSEIF(ISUB.LE.200) THEN
11328 IF(ISUB.EQ.161) THEN
11329 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11330 IF(MINT(15).EQ.21) JS=2
11333 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
11334 IB=IA+MOD(IA,2)-MOD(IA+1,2)
11335 MINT(20+JS)=ISIGN(IB,I)
11337 KCS=ISIGN(1,MINT(14+JS))
11339 ELSEIF(ISUB.EQ.162) THEN
11340 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11341 IF(MINT(15).EQ.21) JS=2
11342 MINT(20+JS)=ISIGN(42,MINT(14+JS))
11343 KFLQL=KFDP(MDCY(42,2),2)
11344 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
11346 KCS=ISIGN(1,MINT(14+JS))
11348 ELSEIF(ISUB.EQ.163) THEN
11349 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11350 KCS=(-1)**INT(1.5D0+PYR(0))
11351 MINT(21)=ISIGN(42,KCS)
11355 ELSEIF(ISUB.EQ.164) THEN
11356 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11357 MINT(21)=ISIGN(42,MINT(15))
11361 ELSEIF(ISUB.EQ.165) THEN
11362 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11363 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11366 ELSEIF(ISUB.EQ.166) THEN
11367 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11368 IF(MOD(MINT(15),2).EQ.0) THEN
11369 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11370 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11372 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11373 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11376 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
11377 C...q + q' -> q" + q* (excited quark)
11378 KFQSTR=KFPR(ISUB,2)
11379 KFQEXC=MOD(KFQSTR,KEXCIT)
11381 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11382 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
11383 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11387 ELSEIF(ISUB.EQ.169) THEN
11388 C...q + qbar -> e + e* (excited lepton)
11389 KFQSTR=KFPR(ISUB,2)
11390 KFQEXC=MOD(KFQSTR,KEXCIT)
11392 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11393 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11396 ELSEIF(ISUB.EQ.191) THEN
11397 C...f + fbar -> rho_tc0.
11400 ELSEIF(ISUB.EQ.192) THEN
11401 C...f + fbar' -> rho_tc+/-
11402 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11403 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11404 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11406 ELSEIF(ISUB.EQ.193) THEN
11407 C...f + fbar -> omega_tc0.
11410 ELSEIF(ISUB.EQ.194) THEN
11411 C...f + fbar -> f' + fbar' via mixture of s-channel
11412 C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11413 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11416 ELSEIF(ISUB.EQ.195) THEN
11417 C...f + fbar' -> f'' + fbar''' via s-channel
11418 C...rho_tc+ th=(p(f)-p(f'))**2
11419 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11420 IF(MOD(MINT(15),2).EQ.0) THEN
11421 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11422 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11424 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11425 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11430 ELSEIF(ISUB.LE.215) THEN
11431 IF(ISUB.EQ.201) THEN
11432 C...f + fbar -> ~e_L + ~e_Lbar
11433 MINT(21)=ISIGN(KSUSY1+11,KCS)
11436 ELSEIF(ISUB.EQ.202) THEN
11437 C...f + fbar -> ~e_R + ~e_Rbar
11438 MINT(21)=ISIGN(KSUSY2+11,KCS)
11441 ELSEIF(ISUB.EQ.203) THEN
11442 C...f + fbar -> ~e_L + ~e_Rbar
11443 IF(MINT(15).LT.0) JS=2
11444 IF(MINT(2).EQ.1) THEN
11445 MINT(20+JS)=KFPR(ISUB,1)
11446 MINT(23-JS)=-KFPR(ISUB,2)
11448 MINT(20+JS)=-KFPR(ISUB,1)
11449 MINT(23-JS)=KFPR(ISUB,2)
11452 ELSEIF(ISUB.EQ.204) THEN
11453 C...f + fbar -> ~mu_L + ~mu_Lbar
11454 MINT(21)=ISIGN(KSUSY1+13,KCS)
11457 ELSEIF(ISUB.EQ.205) THEN
11458 C...f + fbar -> ~mu_R + ~mu_Rbar
11459 MINT(21)=ISIGN(KSUSY2+13,KCS)
11462 ELSEIF(ISUB.EQ.206) THEN
11463 C...f + fbar -> ~mu_L + ~mu_Rbar
11464 IF(MINT(15).LT.0) JS=2
11465 IF(MINT(2).EQ.1) THEN
11466 MINT(20+JS)=KFPR(ISUB,1)
11467 MINT(23-JS)=-KFPR(ISUB,2)
11469 MINT(20+JS)=-KFPR(ISUB,1)
11470 MINT(23-JS)=KFPR(ISUB,2)
11473 ELSEIF(ISUB.EQ.207) THEN
11474 C...f + fbar -> ~tau_1 + ~tau_1bar
11475 MINT(21)=ISIGN(KSUSY1+15,KCS)
11478 ELSEIF(ISUB.EQ.208) THEN
11479 C...f + fbar -> ~tau_2 + ~tau_2bar
11480 MINT(21)=ISIGN(KSUSY2+15,KCS)
11483 ELSEIF(ISUB.EQ.209) THEN
11484 C...f + fbar -> ~tau_1 + ~tau_2bar
11485 IF(MINT(15).LT.0) JS=2
11486 IF(MINT(2).EQ.1) THEN
11487 MINT(20+JS)=KFPR(ISUB,1)
11488 MINT(23-JS)=-KFPR(ISUB,2)
11490 MINT(20+JS)=-KFPR(ISUB,1)
11491 MINT(23-JS)=KFPR(ISUB,2)
11494 ELSEIF(ISUB.EQ.210) THEN
11495 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11496 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11497 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11498 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11499 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11501 ELSEIF(ISUB.EQ.211) THEN
11502 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11503 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11504 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11505 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11506 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11508 ELSEIF(ISUB.EQ.212) THEN
11509 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11510 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11511 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11512 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11513 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11515 ELSEIF(ISUB.EQ.213) THEN
11516 C...f + fbar -> ~nul + ~nulbar
11517 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11520 ELSEIF(ISUB.EQ.214) THEN
11521 C...f + fbar -> ~nutau + ~nutaubar
11522 MINT(21)=ISIGN(KSUSY1+16,KCS)
11526 ELSEIF(ISUB.LE.225) THEN
11527 IF(ISUB.EQ.216) THEN
11528 C...f + fbar -> ~chi01 + ~chi01
11532 ELSEIF(ISUB.EQ.217) THEN
11533 C...f + fbar -> ~chi02 + ~chi02
11537 ELSEIF(ISUB.EQ.218 ) THEN
11538 C...f + fbar -> ~chi03 + ~chi03
11542 ELSEIF(ISUB.EQ.219 ) THEN
11543 C...f + fbar -> ~chi04 + ~chi04
11547 ELSEIF(ISUB.EQ.220 ) THEN
11548 C...f + fbar -> ~chi01 + ~chi02
11549 IF(MINT(15).LT.0) JS=2
11550 C IF(PYR(0).GT.0.5D0) JS=2
11551 MINT(20+JS)=KSUSY1+22
11552 MINT(23-JS)=KSUSY1+23
11554 ELSEIF(ISUB.EQ.221 ) THEN
11555 C...f + fbar -> ~chi01 + ~chi03
11556 IF(MINT(15).LT.0) JS=2
11557 C IF(PYR(0).GT.0.5D0) JS=2
11558 MINT(20+JS)=KSUSY1+22
11559 MINT(23-JS)=KSUSY1+25
11561 ELSEIF(ISUB.EQ.222) THEN
11562 C...f + fbar -> ~chi01 + ~chi04
11563 IF(MINT(15).LT.0) JS=2
11564 C IF(PYR(0).GT.0.5D0) JS=2
11565 MINT(20+JS)=KSUSY1+22
11566 MINT(23-JS)=KSUSY1+35
11568 ELSEIF(ISUB.EQ.223) THEN
11569 C...f + fbar -> ~chi02 + ~chi03
11570 IF(MINT(15).LT.0) JS=2
11571 C IF(PYR(0).GT.0.5D0) JS=2
11572 MINT(20+JS)=KSUSY1+23
11573 MINT(23-JS)=KSUSY1+25
11575 ELSEIF(ISUB.EQ.224) THEN
11576 C...f + fbar -> ~chi02 + ~chi04
11577 IF(MINT(15).LT.0) JS=2
11578 C IF(PYR(0).GT.0.5D0) JS=2
11579 MINT(20+JS)=KSUSY1+23
11580 MINT(23-JS)=KSUSY1+35
11582 ELSEIF(ISUB.EQ.225) THEN
11583 C...f + fbar -> ~chi03 + ~chi04
11584 IF(MINT(15).LT.0) JS=2
11585 C IF(PYR(0).GT.0.5D0) JS=2
11586 MINT(20+JS)=KSUSY1+25
11587 MINT(23-JS)=KSUSY1+35
11590 ELSEIF(ISUB.LE.236) THEN
11591 IF(ISUB.EQ.226) THEN
11592 C...f + fbar -> ~chi+-1 + ~chi-+1
11593 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
11594 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11595 MINT(21)=ISIGN(KSUSY1+24,KCH1)
11598 ELSEIF(ISUB.EQ.227) THEN
11599 C...f + fbar -> ~chi+-2 + ~chi-+2
11600 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11601 MINT(21)=ISIGN(KSUSY1+37,KCH1)
11604 ELSEIF(ISUB.EQ.228) THEN
11605 C...f + fbar -> ~chi+-1 + ~chi-+2
11606 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
11607 C...js=1 if pyr<.5, js=2 if pyr>.5
11608 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
11609 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
11610 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
11611 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
11612 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11614 IF(MINT(2).EQ.1) THEN
11615 MINT(21)= ISIGN(KSUSY1+24,KCH1)
11616 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
11617 c IF(KCH2.EQ.0) JS=2
11619 MINT(21)= ISIGN(KSUSY1+37,KCH1)
11620 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
11622 c IF(KCH2.EQ.1) JS=2
11625 ELSEIF(ISUB.EQ.229) THEN
11626 C...q + qbar' -> ~chi01 + ~chi+-1
11627 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
11628 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11629 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11631 IF(MOD(MINT(15),2).EQ.0) JS=2
11632 MINT(20+JS)=KSUSY1+22
11633 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11635 ELSEIF(ISUB.EQ.230) THEN
11636 C...q + qbar' -> ~chi02 + ~chi+-1
11637 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11638 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11639 IF(MOD(MINT(15),2).EQ.0) JS=2
11640 MINT(20+JS)=KSUSY1+23
11641 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11643 ELSEIF(ISUB.EQ.231) THEN
11644 C...q + qbar' -> ~chi03 + ~chi+-1
11645 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11646 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11647 IF(MOD(MINT(15),2).EQ.0) JS=2
11648 MINT(20+JS)=KSUSY1+25
11649 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11651 ELSEIF(ISUB.EQ.232) THEN
11652 C...q + qbar' -> ~chi04 + ~chi+-1
11653 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11654 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11655 IF(MOD(MINT(15),2).EQ.0) JS=2
11656 MINT(20+JS)=KSUSY1+35
11657 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11659 ELSEIF(ISUB.EQ.233) THEN
11660 C...q + qbar' -> ~chi01 + ~chi+-2
11661 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11662 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11663 IF(MOD(MINT(15),2).EQ.0) JS=2
11664 MINT(20+JS)=KSUSY1+22
11665 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11667 ELSEIF(ISUB.EQ.234) THEN
11668 C...q + qbar' -> ~chi02 + ~chi+-2
11669 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11670 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11671 IF(MOD(MINT(15),2).EQ.0) JS=2
11672 MINT(20+JS)=KSUSY1+23
11673 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11675 ELSEIF(ISUB.EQ.235) THEN
11676 C...q + qbar' -> ~chi03 + ~chi+-2
11677 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11678 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11679 IF(MOD(MINT(15),2).EQ.0) JS=2
11680 MINT(20+JS)=KSUSY1+25
11681 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11683 ELSEIF(ISUB.EQ.236) THEN
11684 C...q + qbar' -> ~chi04 + ~chi+-2
11685 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11686 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11687 IF(MOD(MINT(15),2).EQ.0) JS=2
11688 MINT(20+JS)=KSUSY1+35
11689 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11692 ELSEIF(ISUB.LE.245) THEN
11693 IF(ISUB.EQ.237) THEN
11694 C...q + qbar -> ~chi01 + ~g
11696 IF(PYR(0).GT.0.5D0) JS=2
11697 MINT(20+JS)=KSUSY1+21
11698 MINT(23-JS)=KSUSY1+22
11701 ELSEIF(ISUB.EQ.238) THEN
11702 C...q + qbar -> ~chi02 + ~g
11704 IF(PYR(0).GT.0.5D0) JS=2
11705 MINT(20+JS)=KSUSY1+21
11706 MINT(23-JS)=KSUSY1+23
11709 ELSEIF(ISUB.EQ.239) THEN
11710 C...q + qbar -> ~chi03 + ~g
11712 IF(PYR(0).GT.0.5D0) JS=2
11713 MINT(20+JS)=KSUSY1+21
11714 MINT(23-JS)=KSUSY1+25
11717 ELSEIF(ISUB.EQ.240) THEN
11718 C...q + qbar -> ~chi04 + ~g
11720 IF(PYR(0).GT.0.5D0) JS=2
11721 MINT(20+JS)=KSUSY1+21
11722 MINT(23-JS)=KSUSY1+35
11725 ELSEIF(ISUB.EQ.241) THEN
11726 C...q + qbar' -> ~chi+-1 + ~g
11727 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
11728 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
11729 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
11730 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
11731 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
11732 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11733 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11735 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11736 MINT(20+JS)=KSUSY1+21
11737 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11740 ELSEIF(ISUB.EQ.242) THEN
11741 C...q + qbar' -> ~chi+-2 + ~g
11742 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
11743 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
11744 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
11745 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
11746 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
11747 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11748 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11750 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11751 MINT(20+JS)=KSUSY1+21
11752 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11755 ELSEIF(ISUB.EQ.243) THEN
11756 C...q + qbar -> ~g + ~g ; th arbitrary
11761 ELSEIF(ISUB.EQ.244) THEN
11762 C...g + g -> ~g + ~g ; th arbitrary
11764 KCS=(-1)**INT(1.5D0+PYR(0))
11769 ELSEIF(ISUB.LE.260) THEN
11770 IF(ISUB.EQ.246) THEN
11771 C...qj + g -> ~qj_L + ~chi01
11772 IF(MINT(15).EQ.21) JS=2
11775 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11776 MINT(23-JS)=KSUSY1+22
11778 KCS=ISIGN(1,MINT(14+JS))
11780 ELSEIF(ISUB.EQ.247) THEN
11781 C...qj + g -> ~qj_R + ~chi01
11782 IF(MINT(15).EQ.21) JS=2
11785 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11786 MINT(23-JS)=KSUSY1+22
11788 KCS=ISIGN(1,MINT(14+JS))
11790 ELSEIF(ISUB.EQ.248) THEN
11791 C...qj + g -> ~qj_L + ~chi02
11792 IF(MINT(15).EQ.21) JS=2
11795 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11796 MINT(23-JS)=KSUSY1+23
11798 KCS=ISIGN(1,MINT(14+JS))
11800 ELSEIF(ISUB.EQ.249) THEN
11801 C...qj + g -> ~qj_R + ~chi02
11802 IF(MINT(15).EQ.21) JS=2
11805 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11806 MINT(23-JS)=KSUSY1+23
11808 KCS=ISIGN(1,MINT(14+JS))
11810 ELSEIF(ISUB.EQ.250) THEN
11811 C...qj + g -> ~qj_L + ~chi03
11812 IF(MINT(15).EQ.21) JS=2
11815 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11816 MINT(23-JS)=KSUSY1+25
11818 KCS=ISIGN(1,MINT(14+JS))
11820 ELSEIF(ISUB.EQ.251) THEN
11821 C...qj + g -> ~qj_R + ~chi03
11822 IF(MINT(15).EQ.21) JS=2
11825 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11826 MINT(23-JS)=KSUSY1+25
11828 KCS=ISIGN(1,MINT(14+JS))
11830 ELSEIF(ISUB.EQ.252) THEN
11831 C...qj + g -> ~qj_L + ~chi04
11832 IF(MINT(15).EQ.21) JS=2
11835 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11836 MINT(23-JS)=KSUSY1+35
11838 KCS=ISIGN(1,MINT(14+JS))
11840 ELSEIF(ISUB.EQ.253) THEN
11841 C...qj + g -> ~qj_R + ~chi04
11842 IF(MINT(15).EQ.21) JS=2
11845 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11846 MINT(23-JS)=KSUSY1+35
11848 KCS=ISIGN(1,MINT(14+JS))
11850 ELSEIF(ISUB.EQ.254) THEN
11851 C...qj + g -> ~qk_L + ~chi+-1
11852 IF(MINT(15).EQ.21) JS=2
11855 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
11856 IB=-IA+INT((IA+1)/2)*4-1
11857 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
11859 KCS=ISIGN(1,MINT(14+JS))
11861 ELSEIF(ISUB.EQ.255) THEN
11862 C...qj + g -> ~qk_L + ~chi+-1
11863 IF(MINT(15).EQ.21) JS=2
11866 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
11867 IB=-IA+INT((IA+1)/2)*4-1
11868 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
11870 KCS=ISIGN(1,MINT(14+JS))
11872 ELSEIF(ISUB.EQ.256) THEN
11873 C...qj + g -> ~qk_L + ~chi+-2
11874 IF(MINT(15).EQ.21) JS=2
11877 IB=-IA+INT((IA+1)/2)*4-1
11878 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
11879 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
11881 KCS=ISIGN(1,MINT(14+JS))
11883 ELSEIF(ISUB.EQ.257) THEN
11884 C...qj + g -> ~qk_R + ~chi+-2
11885 IF(MINT(15).EQ.21) JS=2
11888 IB=-IA+INT((IA+1)/2)*4-1
11889 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
11890 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
11892 KCS=ISIGN(1,MINT(14+JS))
11894 ELSEIF(ISUB.EQ.258) THEN
11895 C...qj + g -> ~qj_L + ~g
11896 IF(MINT(15).EQ.21) JS=2
11899 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11900 MINT(23-JS)=KSUSY1+21
11902 IF(JS.EQ.2) KCC=KCC+2
11905 ELSEIF(ISUB.EQ.259) THEN
11906 C...qj + g -> ~qj_R + ~g
11907 IF(MINT(15).EQ.21) JS=2
11910 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11911 MINT(23-JS)=KSUSY1+21
11913 IF(JS.EQ.2) KCC=KCC+2
11917 ELSEIF(ISUB.LE.270) THEN
11918 IF(ISUB.EQ.261) THEN
11919 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
11921 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11922 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11924 C...Correct color combination
11925 IF(MINT(43).EQ.4) KCC=4
11927 ELSEIF(ISUB.EQ.262) THEN
11928 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
11930 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11931 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11933 C...Correct color combination
11934 IF(MINT(43).EQ.4) KCC=4
11936 ELSEIF(ISUB.EQ.263) THEN
11937 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
11938 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
11939 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
11940 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11941 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
11944 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
11945 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
11947 C...Correct color combination
11948 IF(MINT(43).EQ.4) KCC=4
11950 ELSEIF(ISUB.EQ.264) THEN
11951 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
11952 KCS=(-1)**INT(1.5D0+PYR(0))
11953 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11957 ELSEIF(ISUB.EQ.265) THEN
11958 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
11959 KCS=(-1)**INT(1.5D0+PYR(0))
11960 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11965 ELSEIF(ISUB.LE.296) THEN
11966 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
11967 C...qi + qj -> ~qi_L + ~qj_L
11969 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11970 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
11971 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
11973 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
11974 C...qi + qj -> ~qi_R + ~qj_R
11976 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11977 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
11978 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
11980 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
11981 C...qi + qj -> ~qi_L + ~qj_R
11982 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11983 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
11985 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11987 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
11988 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
11989 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
11990 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
11992 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11994 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
11995 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
11996 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
11997 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
11999 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12001 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
12002 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12003 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12004 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12006 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12008 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
12009 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12011 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12012 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12014 IF(MINT(43).EQ.4) KCC=4
12016 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
12017 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12019 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12020 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12022 IF(MINT(43).EQ.4) KCC=4
12024 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
12025 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12027 KCS=(-1)**INT(1.5D0+PYR(0))
12028 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12032 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
12033 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12034 KCS=(-1)**INT(1.5D0+PYR(0))
12035 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12039 ELSEIF(ISUB.EQ.294) THEN
12040 C...qj + g -> ~qj_L + ~g
12041 IF(MINT(15).EQ.21) JS=2
12044 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12045 MINT(23-JS)=KSUSY1+21
12047 IF(JS.EQ.2) KCC=KCC+2
12050 ELSEIF(ISUB.EQ.295) THEN
12051 C...qj + g -> ~qj_R + ~g
12052 IF(MINT(15).EQ.21) JS=2
12055 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12056 MINT(23-JS)=KSUSY1+21
12058 IF(JS.EQ.2) KCC=KCC+2
12062 ELSEIF(ISUB.LE.340) THEN
12064 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
12065 C...q + qbar' -> H+ + H0
12066 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12067 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12068 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12069 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
12070 MINT(23-JS)=KFPR(ISUB,2)
12071 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
12072 C...f + fbar -> A0 + H0; th arbitrary
12073 IF(PYR(0).GT.0.5D0) JS=2
12074 MINT(20+JS)=KFPR(ISUB,1)
12075 MINT(23-JS)=KFPR(ISUB,2)
12076 ELSEIF(ISUB.EQ.301) THEN
12077 C...f + fbar -> H+ H-
12078 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12083 ELSEIF(ISUB.LE.360) THEN
12085 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
12086 C...l + l -> H_L++/--, H_R++/--
12087 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12088 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12089 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12091 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
12092 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12093 IF(MINT(15).EQ.22) JS=2
12094 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
12095 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
12098 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
12099 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12100 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
12103 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
12104 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12105 C...as inner process).
12110 RVCKM=VINT(180+I)*PYR(0)
12113 IPM=(5-ISIGN(1,I))/2
12115 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
12116 MINT(20+JT)=ISIGN(IB,I)
12117 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12118 IF(RVCKM.LE.0D0) GOTO 450
12121 IB=2*((IA+1)/2)-1+MOD(IA,2)
12122 MINT(20+JT)=ISIGN(IB,I)
12126 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
12127 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
12129 ELSEIF(ISUB.EQ.353) THEN
12130 C...f + fbar -> Z_R0
12133 ELSEIF(ISUB.EQ.354) THEN
12134 C...f + fbar' -> W+/-
12135 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12136 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12137 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12141 ELSEIF(ISUB.LE.380) THEN
12143 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
12144 C...f + fbar -> charged+ charged- technicolor
12145 KSW=(-1)**INT(1.5D0+PYR(0))
12146 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
12147 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
12149 ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
12150 C...f + fbar -> neutral neutral technicolor
12151 MINT(21)=KFPR(ISUB,1)
12152 MINT(22)=KFPR(ISUB,2)
12154 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
12155 C...f + fbar' -> neutral charged technicolor
12158 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12159 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12160 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12161 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12162 MINT(20+JS)=KFPR(ISUB,IN)
12164 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
12165 C...f + fbar' -> charged neutral technicolor
12168 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12169 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12170 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12171 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12172 MINT(23-JS)=KFPR(ISUB,IN)
12175 ELSEIF(ISUB.LE.400) THEN
12176 IF(ISUB.EQ.381) THEN
12177 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12179 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12181 ELSEIF(ISUB.EQ.382) THEN
12182 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12183 MINT(21)=ISIGN(KFLF,MINT(15))
12187 ELSEIF(ISUB.EQ.383) THEN
12188 C...f + fbar -> g + g; th arbitrary, TC extensions
12193 ELSEIF(ISUB.EQ.384) THEN
12194 C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12195 IF(MINT(15).EQ.21) JS=2
12197 IF(MINT(15).EQ.21) KCC=KCC+2
12198 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12199 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12201 ELSEIF(ISUB.EQ.385) THEN
12202 C...g + g -> f + fbar; th arbitrary, TC extensions
12203 KCS=(-1)**INT(1.5D0+PYR(0))
12204 MINT(21)=ISIGN(KFLF,KCS)
12208 ELSEIF(ISUB.EQ.386) THEN
12209 C...g + g -> g + g; th arbitrary, TC extensions
12211 KCS=(-1)**INT(1.5D0+PYR(0))
12213 ELSEIF(ISUB.EQ.387) THEN
12214 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12215 MINT(21)=ISIGN(MINT(55),MINT(15))
12219 ELSEIF(ISUB.EQ.388) THEN
12220 C...g + g -> Q + Qbar; th arbitrary, TC extensions
12221 KCS=(-1)**INT(1.5D0+PYR(0))
12222 MINT(21)=ISIGN(MINT(55),KCS)
12226 ELSEIF(ISUB.EQ.391) THEN
12227 C...f + fbar -> G*.
12230 ELSEIF(ISUB.EQ.392) THEN
12235 ELSEIF(ISUB.EQ.393) THEN
12236 C...q + qbar -> g + G*; th arbitrary.
12237 IF(PYR(0).GT.0.5D0) JS=2
12238 MINT(20+JS)=KFPR(ISUB,1)
12239 MINT(23-JS)=KFPR(ISUB,2)
12242 ELSEIF(ISUB.EQ.394) THEN
12243 C...q + g -> q + G*; th = (p(f) - p(f))**2
12244 IF(MINT(15).EQ.21) JS=2
12245 MINT(23-JS)=KFPR(ISUB,2)
12247 KCS=ISIGN(1,MINT(14+JS))
12249 ELSEIF(ISUB.EQ.395) THEN
12250 C...g + g -> G* + g; th arbitrary.
12251 IF(PYR(0).GT.0.5D0) JS=2
12252 MINT(23-JS)=KFPR(ISUB,2)
12256 ELSEIF(ISUB.LE.420) THEN
12257 IF(ISUB.EQ.401) THEN
12258 C...g + g -> t + b + H+/-
12259 KCS=(-1)**INT(1.5D0+PYR(0))
12260 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
12261 MINT(22)=ISIGN(5,-KCS)
12262 KCC=11+INT(0.5D0+PYR(0))
12263 KFRES=ISIGN(KFHIGG,-KCS)
12265 ELSEIF(ISUB.EQ.402) THEN
12266 C...q + qbar -> t + b + H+/-
12267 KFL=(-1)**INT(1.5D0+PYR(0))
12268 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
12269 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
12271 KFRES=ISIGN(KFHIGG,-KFL*KCS)
12275 C...Additional code by Stefan Wolf
12276 ELSEIF(ISUB.LE.430) THEN
12277 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
12278 C...g + g -> QQ~[n] + g
12279 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12280 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12281 C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12282 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12283 C...or from ISUB.EQ.68 (for ISUB.NE.421)
12284 C...[g + g -> g + g; th arbitrary]
12285 MINT(21)=KFPR(ISUBSV,1)
12286 MINT(22)=KFPR(ISUBSV,2)
12287 IF(ISUB.EQ.421) THEN
12289 KCS=(-1)**INT(1.5D0+PYR(0))
12292 KCS=(-1)**INT(1.5D0+PYR(0))
12295 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
12296 C...q + g -> q + QQ~[n]
12297 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12298 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12299 C...KCC copied from ISUB.EQ.28
12300 C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12301 IF(MINT(15).EQ.21) JS=2
12302 MINT(23-JS)=KFPR(ISUBSV,2)
12304 IF(MINT(15).EQ.21) KCC=KCC+2
12305 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12306 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12308 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
12309 C...q + q~ -> g + QQ~[n]
12310 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12311 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12312 C...KCC copied from ISUB.EQ.13
12313 C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12314 IF(PYR(0).GT.0.5) JS=2
12316 MINT(23-JS)=KFPR(ISUBSV,2)
12320 ELSEIF(ISUB.LE.440) THEN
12321 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
12322 C...g + g -> QQ~[n] + g
12323 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12324 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12325 C...KCC and KCS copied from ISUB.EQ.86-89
12326 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12327 MINT(21)=KFPR(ISUBSV,1)
12328 MINT(22)=KFPR(ISUBSV,2)
12330 KCS=(-1)**INT(1.5D0+PYR(0))
12332 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
12333 C...q + g -> q + QQ~[n]
12334 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12335 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12336 C...KCC and KCS copied from ISUB.EQ.112
12337 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12338 IF(MINT(15).EQ.21) JS=2
12339 MINT(23-JS)=KFPR(ISUBSV,2)
12341 KCS=ISIGN(1,MINT(14+JS))
12343 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
12344 C...q + q~ -> g + QQ~[n]
12345 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12346 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12347 C...KCC copied from ISUB.EQ.111
12348 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12349 IF(PYR(0).GT.0.5) JS=2
12351 MINT(23-JS)=KFPR(ISUBSV,2)
12358 IF(ISET(ISUB).EQ.11) THEN
12359 C...Store documentation for user-defined processes
12360 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
12361 KUPPO(1)=MINT(83)+5
12362 KUPPO(2)=MINT(83)+6
12366 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
12375 IF(IDUP(IUP).EQ.0) K(I,2)=90
12377 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
12385 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
12388 C...Store final state partons for user-defined processes
12393 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
12395 IF(IDUP(IUP).EQ.0) K(N,2)=90
12396 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
12399 K(N,3)=MINT(84)+MOTHUP(1,IUP)
12403 C...Search for daughters of intermediate colourless particles.
12404 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
12405 DO 475 IUPDAU=IUP+1,NUP
12406 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
12408 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
12416 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
12418 C...Arrange colour flow for user-defined processes
12422 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
12423 IF(K(I1,1).EQ.1) K(I1,1)=3
12424 IF(K(I1,1).EQ.11) K(I1,1)=14
12425 C...Find a not yet considered colour/anticolour line.
12427 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
12430 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
12434 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
12435 C...Find all others belonging to same line.
12438 DO 520 IUP2=IUP1+1,NUP
12441 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
12442 IF(ISDE2.EQ.ISDE1) THEN
12443 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
12444 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
12446 ELSEIF(I4.NE.0) THEN
12447 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
12448 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
12450 ELSEIF(IUP2.LE.2) THEN
12451 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
12452 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
12455 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
12456 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
12466 ELSEIF(IDOC.EQ.7) THEN
12467 C...Resonance not decaying; store kinematics
12482 C...Special cases: colour flow in coloured resonances
12483 KCRES=PYCOMP(KFRES)
12484 IF(KCHG(KCRES,2).NE.0) THEN
12488 IF(KCS.EQ.-1) JC=3-J
12489 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12490 & MINT(84)+ICOL(KCC,1,JC)
12491 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12492 & MINT(84)+ICOL(KCC,2,JC)
12493 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12494 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12503 ELSEIF(IDOC.EQ.8) THEN
12504 C...2 -> 2 processes: store outgoing partons in their CM-frame
12507 KCA=PYCOMP(MINT(20+JT))
12509 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12511 K(I,3)=MINT(83)+IDOC+JT-2
12513 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
12514 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12516 P(I,5)=PYMASS(K(I,2))
12518 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
12519 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
12521 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
12522 KFA1=IABS(MINT(21))
12523 KFA2=IABS(MINT(22))
12524 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
12532 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
12533 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
12534 P(IPU4,4)=SHR-P(IPU3,4)
12535 P(IPU4,3)=-P(IPU3,3)
12540 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
12541 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
12543 ELSEIF(IDOC.EQ.9) THEN
12544 C...2 -> 3 processes: store outgoing partons in their CM frame
12547 KCA=PYCOMP(MINT(20+JT))
12549 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12551 K(I,3)=MINT(83)+IDOC+JT-3
12553 C...t and b in opposide order in event list as compared to
12554 C...matrix element?
12555 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
12556 IF(IABS(K(I,2)).LE.22) THEN
12557 P(I,5)=PYMASS(K(I,2))
12559 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
12561 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
12562 P(I,1)=PT*COS(VINT(198+5*JTA))
12563 P(I,2)=PT*SIN(VINT(198+5*JTA))
12567 K(IPU5,3)=MINT(83)+IDOC
12569 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
12570 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
12571 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
12572 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
12573 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
12575 P(IPU5,3)=PMT3*SINH(VINT(211))
12576 P(IPU5,4)=PMT3*COSH(VINT(211))
12577 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
12578 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
12579 IF(SQL12.LE.0D0) THEN
12583 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
12584 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
12585 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
12586 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
12587 C...t and b in opposide order in event list as compared to
12589 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
12590 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
12591 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
12593 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
12594 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
12600 ELSEIF(IDOC.EQ.11) THEN
12601 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
12602 PHI(1)=PARU(2)*PYR(0)
12607 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
12609 K(I,3)=MINT(83)+IDOC+JT-2
12610 P(I,5)=PYMASS(K(I,2))
12611 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
12615 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
12616 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
12617 P(I,1)=PTABS*COS(PHI(JT))
12618 P(I,2)=PTABS*SIN(PHI(JT))
12619 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12620 P(I,4)=0.5D0*SHPR*Z(JT)
12624 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
12628 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12629 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
12630 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12637 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
12638 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
12639 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
12640 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
12649 ELSEIF(IDOC.EQ.12) THEN
12650 C...Z0 and W+/- scattering: store bosons and outgoing partons
12651 PHI(1)=PARU(2)*PYR(0)
12653 JTRAN=INT(1.5D0+PYR(0))
12657 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
12659 K(I,3)=MINT(83)+IDOC+JT-2
12660 P(I,5)=PYMASS(K(I,2))
12661 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
12662 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
12663 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
12664 P(I,1)=PTABS*COS(PHI(JT))
12665 P(I,2)=PTABS*SIN(PHI(JT))
12666 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12667 P(I,4)=0.5D0*SHPR*Z(JT)
12670 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
12673 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
12678 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12679 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
12680 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12683 K(IPU,2)=KFPR(ISUB,JT)
12684 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
12685 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
12686 K(IPU,3)=MINT(83)+8+JT
12687 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
12688 P(IPU,5)=PYMASS(K(IPU,2))
12690 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12692 MINT(22+JT)=K(IPU,2)
12694 C...Find rotation and boost for hard scattering subsystem
12697 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
12698 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
12699 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
12700 GAMCM=(P(I1,4)+P(I2,4))/SHR
12701 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
12702 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
12703 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
12704 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
12705 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
12706 PHICM=PYANGL(PX,PY)
12707 C...Store hard scattering subsystem. Rotate and boost it
12708 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
12710 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
12712 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
12713 PHIWZ=VINT(24)-PHICM
12714 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
12715 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
12716 P(IPU5,3)=PABS*CTHWZ
12717 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
12718 P(IPU6,1)=-P(IPU5,1)
12719 P(IPU6,2)=-P(IPU5,2)
12720 P(IPU6,3)=-P(IPU5,3)
12721 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
12722 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
12734 MINT(8)=MINT(83)+10
12737 IF(ISET(ISUB).EQ.11) THEN
12738 ELSEIF(IDOC.GE.8) THEN
12739 C...Store colour connection indices
12742 IF(KCS.EQ.-1) JC=3-J
12743 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12744 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
12745 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12746 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
12747 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12748 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12749 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
12750 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
12753 C...Copy outgoing partons to documentation lines
12755 IF(IDOC.EQ.9) IMAX=3
12757 I1=MINT(83)+IDOC-IMAX+I
12761 IF(IDOC.LE.9) K(I1,3)=0
12762 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
12768 ELSEIF(IDOC.EQ.9) THEN
12769 C...Store colour connection indices
12772 IF(KCS.EQ.-1) JC=3-J
12773 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12774 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
12775 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
12776 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12777 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
12778 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
12779 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
12780 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12781 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
12782 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
12785 C...Copy outgoing partons to documentation lines
12787 I1=MINT(83)+IDOC-3+I
12798 C...Copy outgoing partons to list of allowed radiators.
12800 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
12801 DO 690 I=MINT(84)+3,N
12804 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
12808 C...Low-pT events: remove gluons used for string drawing purposes
12809 IF(ISUB.EQ.95) THEN
12810 IF(MINT(35).LE.1) THEN
12811 K(IPU3,1)=K(IPU3,1)+10
12812 K(IPU4,1)=K(IPU4,1)+10
12818 DO 720 I=MINT(83)+5,MINT(83)+8
12828 C***********************************************************************
12831 C...Handles intertwined pT-ordered spacelike initial-state parton
12832 C...and multiple interactions.
12834 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
12835 C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
12836 C...MODE = 0 : (Re-)initialize ISR/MI evolution.
12837 C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
12839 C...Double precision and integer declarations.
12840 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12841 IMPLICIT INTEGER(I-N)
12842 INTEGER PYK,PYCHGE,PYCOMP
12845 DOUBLE PRECISION PYALPS
12846 C...Parameter statement for maximum size of showers.
12847 PARAMETER (MAXNUR=1000)
12849 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
12850 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12851 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12852 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12853 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12854 COMMON/PYINT1/MINT(400),VINT(400)
12855 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12856 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
12857 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
12858 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
12859 & XMI(2,240),PT2MI(240),IMISEP(0:240)
12860 COMMON/PYCTAG/NCT,MCT(4000,2)
12861 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
12862 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
12863 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
12864 C...Local arrays and saved variables.
12865 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
12866 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
12869 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
12870 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
12872 C----------------------------------------------------------------------
12873 C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
12874 C...done only once per event, while MODE=0 is repeated each time the
12875 C...evolution needs to be restarted.
12876 IF (MODE.EQ.-1) THEN
12880 C...Store hard scattering variables
12897 C...Set shat for hardest scattering
12899 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
12902 C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
12906 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
12907 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
12908 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
12910 C----------------------------------------------------------------------
12911 C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
12912 C...interaction initiators, with no previous evolution. Check the input
12913 C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
12914 C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
12915 C...smaller than the CM energy / 2.)
12916 ELSEIF (MODE.EQ.0) THEN
12917 C...Reset counters and switches
12923 C...Reset hard scattering variables
12934 P(MINT(83)+4+IS,J)=PSAV(IS,J)
12935 V(MINT(83)+4+IS,J)=VSAV(IS,J)
12938 C...Reset statistics on activity in event.
12943 C...Reset extra companion reweighting factor
12946 C...We do not generate MI for soft process (ISUB=95), but the
12947 C...initialization must be done regardless, for later purposes.
12950 C...Initialize multiple interactions.
12951 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
12952 IF(MINT(51).NE.0) RETURN
12954 C...Decide whether quarks in hard scattering were valence or sea
12958 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
12959 IF(MINT(51).NE.0) RETURN
12962 C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
12964 IF(MSTP(70).EQ.0) THEN
12966 PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
12967 ELSEIF(MSTP(70).EQ.1) THEN
12968 PT20=(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2
12969 PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
12971 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
12972 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
12974 C...Also store PT2MIN in VINT(17).
12975 180 VINT(17)=PT2MIN
12977 C...Set FS masses zero now.
12981 C...Initialize IS showers with VINT(56) as max scale.
12983 CALL PYPTIS(-1,PT2ISR,PT2MIN,PT2DUM,IFAIL)
12984 IF(MINT(51).NE.0) RETURN
12988 C----------------------------------------------------------------------
12989 C...MODE= 1: Evolve event from PTMAX to PTMIN.
12990 ELSEIF (MODE.EQ.1) THEN
12992 C...Skip if no phase space.
12993 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
12995 C...Starting pT2 max scale (to be udpated successively).
12998 C...Evolve two sides of the event to find which branches at highest pT.
13003 C...Loop over current shower initiators.
13004 IF (MSTP(61).GE.1) THEN
13005 DO 230 MI=1,MINT(31)
13006 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
13008 IF (MI.EQ.1) ISUB=ISUBHD
13011 C...Set up shat, initiator x values, and x remaining in BR.
13013 VINT(141)=XMI(1,MI)
13014 VINT(142)=XMI(2,MI)
13017 DO 210 JI=1,MINT(31)
13018 IF (JI.EQ.MINT(36)) GOTO 210
13019 VINT(143)=VINT(143)-XMI(1,JI)
13020 VINT(144)=VINT(144)-XMI(2,JI)
13022 C...Loop over sides.
13023 C...Generate trial branchings for this interaction. The hardest
13024 C...branching so far is automatically updated if necessary in /PYISMX/.
13027 CALL PYPTIS(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13028 IF (MINT(51).NE.0) RETURN
13033 C...Generate trial additional interaction.
13034 MINT(36)=MINT(31)+1
13035 240 IF (MOD(MSTP(81),10).GE.1) THEN
13037 C...Set up X remaining in BR.
13040 DO 250 JI=1,MINT(31)
13041 VINT(143)=VINT(143)-XMI(1,JI)
13042 VINT(144)=VINT(144)-XMI(2,JI)
13044 C...Generate trial interaction
13045 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13046 IF (MINT(51).EQ.1) RETURN
13049 C...And the winner is:
13050 IF (PT2MX.LT.PT2MIN) THEN
13052 ELSEIF (JSMX.EQ.0) THEN
13053 C...Accept additional interaction (may still fail).
13054 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13055 IF(MINT(51).NE.0) RETURN
13056 IF (IFAIL.EQ.0) THEN
13057 SHAT(MINT(36))=VINT(44)
13058 C...Decide on flavours (valence/sea/companion).
13061 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13062 IF(MINT(51).NE.0) RETURN
13065 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
13066 C...Reconstruct kinematics of acceptable ISR branching.
13067 C...Set up shat, initiator x values, and x remaining in BR.
13070 VINT(44)=SHAT(MINT(36))
13071 VINT(141)=XMI(1,MINT(36))
13072 VINT(142)=XMI(2,MINT(36))
13075 DO 280 JI=1,MINT(31)
13076 IF (JI.EQ.MINT(36)) GOTO 280
13077 VINT(143)=VINT(143)-XMI(1,JI)
13078 VINT(144)=VINT(144)-XMI(2,JI)
13081 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
13082 IF (MINT(51).EQ.1) RETURN
13083 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
13084 C...Bookeep joining. Cannot (yet) be constructed kinematically.
13085 MINT(354)=MINT(354)+1
13086 VINT(354)=VINT(354)+SQRT(PT2MX)
13087 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
13088 MJOIND(JSMX-2,MJN1MX)=MJN2MX
13089 MJOIND(JSMX-2,MJN2MX)=MJN1MX
13092 C...Update PT2 iteration scale.
13095 C...Loop back to continue evolution.
13096 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13097 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
13099 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
13102 C----------------------------------------------------------------------
13103 C...MODE= 2: (Re-)store user information on hardest interaction etc.
13104 ELSEIF (MODE.EQ.2) THEN
13106 C...Revert to "ordinary" meanings of some parameters.
13108 MINT(12+JS)=K(IMI(JS,1,1),2)
13109 VINT(140+JS)=XMI(JS,1)
13110 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
13112 DO 300 MI=1,MINT(31)
13113 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
13117 C...Restore saved quantities for hardest interaction.
13132 C*********************************************************************
13135 C...Generates spacelike parton showers.
13137 SUBROUTINE PYSSPA(IPU1,IPU2)
13139 C...Double precision and integer declarations.
13140 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13141 IMPLICIT INTEGER(I-N)
13142 INTEGER PYK,PYCHGE,PYCOMP
13144 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13145 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13146 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13147 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13148 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13149 COMMON/PYINT1/MINT(400),VINT(400)
13150 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13151 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13152 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
13154 C...Local arrays and data.
13155 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
13156 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
13157 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
13158 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
13159 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
13162 C...Read out basic information; set global Q^2 scale.
13167 VINT2R=VINT(2)*VINT(143)*VINT(144)
13168 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
13169 &MIN(VINT2R,PARP(67)*VINT(56))
13172 C...Define which processes ME corrections have been implemented for.
13174 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13175 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
13176 & ISUB.EQ.144) MECOR=1
13177 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13178 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
13181 C...Initialize QCD evolution and check phase space.
13185 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
13188 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13189 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13190 Q2INT=SQRT(Q0S*Q2EFF)
13191 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
13192 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
13193 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
13195 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
13198 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13199 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13200 Q2INT=SQRT(Q0S*Q2EFF)
13201 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
13202 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
13203 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
13210 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
13212 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
13213 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
13214 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
13215 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
13219 C...Initialize QED evolution and check phase space.
13223 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
13224 &SPME=PMAS(13,1)**2
13225 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
13226 &SPME=PMAS(15,1)**2
13227 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
13230 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
13232 TEMX=LOG(Q2MX/SPME)
13233 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
13235 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13240 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
13242 C...Loopback point in case of failure to reconstruct kinematics.
13250 IF(LOOP.GT.100) THEN
13260 C...Initial values: flavours, momenta, virtualities.
13263 KFBEAM(JT)=MINT(10+JT)
13264 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
13265 KFLS(JT)=MINT(14+JT)
13266 KFLS(JT+2)=KFLS(JT)
13268 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
13269 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
13271 Q2S(JT)=FCQ2MX*Q2MX
13278 C...Calculate initial parton distribution weights.
13279 MINT(105)=MINT(102+JT)
13280 MINT(109)=MINT(106+JT)
13281 VINT(120)=VINT(2+JT)
13283 C.... Store side in MINT(124)
13286 IF(XS(JT).LT.1D0-XEE) THEN
13287 IF(MINT(31).GE.2) MINT(30)=JT
13288 IF(MSTP(57).LE.1) THEN
13289 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13291 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13295 XFS(JT,KFL)=XFB(KFL)
13297 C...Special kinematics check for c/b quarks (that g -> c cbar or
13298 C...b bbar kinematically possible).
13299 KFLCB=IABS(KFLS(JT))
13300 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
13301 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
13308 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
13310 C...Find if interference with final state partons.
13312 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
13316 KCA=PYCOMP(IABS(KFLS(I)))
13317 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
13319 IF(KCFI(I).NE.0) THEN
13320 IF(I.EQ.1) IPFS=IPUS1
13321 IF(I.EQ.2) IPFS=IPUS2
13323 ICSI=MOD(K(IPFS,3+J),MSTU(5))
13324 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
13325 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
13327 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
13329 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
13334 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
13337 C...Pick up leg with highest virtuality.
13341 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
13342 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
13343 IF(MORE(JT).EQ.0) JT=3-JT
13348 XFB(KFL)=XFS(JT,KFL)
13353 C...Check if allowed to branch.
13355 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
13357 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
13358 IF(XB.GE.1D0-2D0*XEC) MCEV=0
13361 IF(MINT(44+JT).EQ.3) THEN
13363 IF(XB.GE.1D0-2D0*XEE) MEEV=0
13364 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
13366 C***Currently kill QED shower for resolved photoproduction.
13367 IF(MINT(18+JT).EQ.1) MEEV=0
13368 C***Currently kill shower for W inside electron.
13369 IF(IABS(KFLB).EQ.24) THEN
13374 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
13376 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13381 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
13385 IF(MSTP(62).LE.1) THEN
13386 IF(ZS(JT).GT.0.99999D0) THEN
13389 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
13390 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
13391 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
13393 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13394 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13397 ALSDUM=PYALPS(FQ2C*Q2B)
13398 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
13400 B0=(33D0-2D0*MSTU(118))/6D0
13402 IF(MEEV.EQ.2) TEVEB=TEVCB
13406 C...Select side for interference with final state partons.
13407 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
13410 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
13412 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
13413 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
13414 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
13416 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
13420 C...Calculate preweighting factor for ME-corrected processes.
13421 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
13423 C...Calculate Altarelli-Parisi weights.
13429 C...q -> q (g or gamma emission), g -> q.
13430 IF(IABS(KFLB).LE.10) THEN
13431 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
13432 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
13434 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
13435 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
13437 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13438 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
13439 WTAPC(21)=WTGF*WTAPC(21)
13440 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13442 C...f -> f, gamma -> f.
13443 ELSEIF(IABS(KFLB).LE.20) THEN
13444 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
13445 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
13446 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
13447 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
13448 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13449 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13450 WTAPE(22)=WTGF*WTAPE(22)
13452 C...f -> g, g -> g.
13453 ELSEIF(KFLB.EQ.21) THEN
13454 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
13455 DO 180 KFL=1,MSTP(58)
13459 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
13460 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13461 DO 190 KFL=1,MSTP(58)
13462 WTAPC(KFL)=WTFG*WTAPC(KFL)
13463 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
13465 WTAPC(21)=WTGG*WTAPC(21)
13467 C...f -> gamma, W+, W-.
13468 ELSEIF(KFLB.EQ.22) THEN
13469 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
13472 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13473 WTAPE(11)=WTFG*WTAPE(11)
13474 WTAPE(-11)=WTFG*WTAPE(-11)
13476 ELSEIF(KFLB.EQ.24) THEN
13477 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13478 & (XEE*(XB+XEE)))/XB
13479 ELSEIF(KFLB.EQ.-24) THEN
13480 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13481 & (XEE*(XB+XEE)))/XB
13484 C...Calculate parton distribution weights and sum.
13487 IF(NTRY.GT.500) THEN
13493 XFBO=MAX(1D-10,XFB(KFLB))
13495 WTSF(KFL)=XFB(KFL)/XFBO
13496 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
13497 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
13499 WTSUMC=MAX(0.0001D0,WTSUMC)
13500 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
13502 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
13505 IF(NTRY2.GT.500) THEN
13510 IF(MSTP(64).LE.0) THEN
13511 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
13512 ELSEIF(MSTP(64).EQ.1) THEN
13513 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
13515 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
13519 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
13520 & (PARU(101)*FWTE*WTSUME*TEMX)))
13521 ELSEIF(MEEV.EQ.2) THEN
13522 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
13525 C...Translate t into Q2 scale; choose between QCD and QED evolution.
13526 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
13527 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
13528 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
13529 C...Ensure that Q2 is above threshold for charm/bottom.
13531 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
13533 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
13534 Q2CB=1.1D0*PMAS(KFLCB,1)**2
13535 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13536 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
13539 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
13541 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
13544 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13545 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13546 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
13547 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
13548 IF(Q2EB.GT.Q2MNE) MCE=2
13549 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
13550 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
13551 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
13552 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
13553 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
13554 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
13556 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
13557 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
13560 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
13561 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
13564 C...Evolution possibly ended. Update t values.
13568 ELSEIF(MCE.EQ.1) THEN
13571 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13572 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13576 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13579 C...Select flavour for branching parton.
13580 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
13581 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
13584 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
13585 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
13586 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
13587 IF(KFLA.EQ.25) THEN
13592 C...Choose z value and corrective weight.
13594 C...q -> q + g or q -> q + gamma.
13595 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
13596 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
13597 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
13598 WTZ=0.5D0*(1D0+Z**2)
13600 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
13601 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
13602 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
13603 C...f -> f + gamma.
13604 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
13605 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
13606 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
13607 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
13609 Z=XB+XB*(XEE/(1D0-XEE))*
13610 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13612 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
13613 C...f -> gamma + f.
13614 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) 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
13619 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
13620 Z=XB+XB*(XEE/(1D0-XEE))*
13621 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13622 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
13623 & (Q2B/(Q2B+PMAS(24,1)**2))
13625 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
13626 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
13627 WTZ=1D0-2D0*Z*(1D0-Z)
13629 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
13630 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
13631 WTZ=(1D0-Z*(1D0-Z))**2
13632 C...gamma -> f + fbar.
13633 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
13634 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
13635 WTZ=1D0-2D0*Z*(1D0-Z)
13637 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
13639 C...Option with resummation of soft gluon emission as effective z shift.
13641 IF(MSTP(65).GE.1) THEN
13643 IF(KFLB.NE.21) RSOFT=8D0/3D0
13644 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
13645 IF(Z.LE.XB) GOTO 220
13648 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
13649 IF(MSTP(64).GE.2) THEN
13650 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
13651 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
13652 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
13653 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
13657 C...Remove kinematically impossible branchings.
13658 UHAT=Q2B-DSH*(1D0-Z)/Z
13659 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
13661 C...Select phi angle of branching at random.
13662 PHIBR=PARU(2)*PYR(0)
13664 C...Matrix-element corrections for some processes.
13665 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13666 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
13667 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
13669 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
13670 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
13672 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
13673 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
13675 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
13676 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
13681 C...Impose angular constraint in first branching from interference
13682 C...with final state partons.
13684 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
13685 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
13686 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
13687 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
13688 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
13689 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
13693 C...Option with angular ordering requirement.
13694 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
13695 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
13696 IF(THE2T.GT.THE2(JT)) GOTO 220
13700 C...Weighting with new parton distributions.
13701 MINT(105)=MINT(102+JT)
13702 MINT(109)=MINT(106+JT)
13703 VINT(120)=VINT(2+JT)
13705 C.... Store side in MINT(124)
13708 IF(MINT(31).GE.2) MINT(30)=JT
13709 IF(MSTP(57).LE.1) THEN
13710 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
13712 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
13715 IF(XFBN.LT.1D-20) THEN
13716 IF(KFLA.EQ.KFLB) THEN
13722 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
13723 TEVCB=0.5D0*(TEVCBS+TEVCB)
13725 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
13726 TEVEB=0.5D0*(TEVEBS+TEVEB)
13738 C.... Store side in MINT(124)
13741 IF(MINT(31).GE.2) MINT(30)=JT
13742 IF(MSTP(57).LE.1) THEN
13743 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
13745 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
13748 IF(XFAN.LT.1D-20) GOTO 200
13750 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
13752 C...Define two hard scatterers in their CM-frame.
13753 260 IF(N.EQ.NS+2) THEN
13755 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
13758 IF(JR.EQ.1) IPO=IPUS1
13759 IF(JR.EQ.2) IPO=IPUS2
13769 P(I,3)=DPLCM*(-1)**(JR+1)
13770 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
13771 P(I,5)=-SQRT(DQ2(JR))
13774 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
13775 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
13778 C...Find maximum allowed mass of timelike parton.
13779 ELSEIF(N.GT.NS+2) THEN
13784 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
13785 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
13786 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
13787 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
13788 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
13790 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
13791 & 1D-10*DPD(1)) IKIN=1
13792 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
13793 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
13794 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
13795 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
13797 C...Generate timelike parton shower (if required).
13804 C...f -> f + g (gamma).
13805 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
13807 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
13808 C...f -> g (gamma, W+-) + f.
13809 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
13811 IF(KFLS(JT+2).EQ.24) THEN
13813 ELSEIF(KFLS(JT+2).EQ.-24) THEN
13816 C...g (gamma) -> f + fbar, g + g.
13818 K(IT,2)=-KFLS(JT+2)
13819 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
13822 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
13823 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
13824 P(IT,5)=PYMASS(K(IT,2))
13825 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
13826 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
13829 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
13830 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
13831 IF(MSTP(63).EQ.1) THEN
13833 ELSEIF(MSTP(63).EQ.2) THEN
13834 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
13838 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13839 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
13840 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
13841 PARJ(85)=SQRT(MAX(0D0,DPT2))*
13842 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
13844 if(parj(200).ne.1.) CALL PYSHOW(IT,0,SQRT(Q2TIM))
13845 if(parj(200).eq.1.) CALL PYSHOWQ(IT,0,SQRT(Q2TIM))
13848 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
13851 C...Reconstruct kinematics of branching: timelike parton shower.
13853 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13854 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
13855 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
13856 & (4D0*DSH*DPC(3)**2)
13857 IF(DPT2.LT.0D0) GOTO 100
13858 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
13859 & DSHR)/DPC(3)-DPC(3)
13861 P(IT,3)=DPB(1)*(-1)**(JT+1)
13862 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
13864 DPB(1)=SQRT(DPB(1)**2+DPT2)
13865 DPB(2)=SQRT(DPB(1)**2+DMS)
13867 DPB(4)=SQRT(DPB(3)**2+DMS)
13868 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
13870 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
13871 THE=PYANGL(P(IT,3),P(IT,1))
13872 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
13875 C...Reconstruct kinematics of branching: spacelike parton.
13884 P(N+1,3)=P(IT,3)+P(IS(JT),3)
13885 P(N+1,4)=P(IT,4)+P(IS(JT),4)
13886 P(N+1,5)=-SQRT(DQ2(3))
13888 C...Define colour flow of branching.
13893 C...f -> f + gamma (Z, W).
13894 IF(IABS(K(IT,2)).GE.22) THEN
13898 C...f -> gamma (Z, W) + f.
13899 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
13902 C...gamma -> q + qbar, g + g.
13903 ELSEIF(K(N+1,2).EQ.22) THEN
13909 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
13913 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
13916 C...qbar -> qbar + g.
13917 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
13920 C...qbar -> g + qbar.
13921 ELSEIF(K(N+1,2).LT.0) THEN
13924 C...g -> g + g; g -> q + qbar.
13925 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
13932 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
13933 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
13934 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
13935 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
13936 IF(ID1.NE.ID2) THEN
13937 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
13938 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
13941 IF(K(IT,1).EQ.1) THEN
13946 C...Boost to new CM-frame.
13947 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
13948 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
13949 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
13950 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
13951 IR=N+(JT-1)*(IS(1)-N)
13952 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
13955 C...Global statistics.
13956 MINT(352)=MINT(352)+1
13957 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
13958 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
13961 C...Update kinematics variables.
13964 IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
13967 C...Save quantities; loop back.
13971 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
13972 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
13973 KFLS(JT+2)=KFLS(JT)
13978 XFS(JT,KFL)=XFA(KFL)
13987 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13988 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
13989 IF(MSTU(21).GE.1) N=NS
13990 IF(MSTU(21).GE.1) RETURN
13992 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
13994 C...Boost hard scattering partons to frame of shower initiators.
13996 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
14002 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
14003 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
14004 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
14006 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
14007 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
14008 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
14010 C...Store user information. Reset Lambda value.
14011 IF(MINT(31).LE.1) THEN
14012 K(IPU1,3)=MINT(83)+3
14013 K(IPU2,3)=MINT(83)+4
14015 K(IPU1,3)=MINT(83)+1
14016 K(IPU2,3)=MINT(83)+2
14019 MINT(12+JT)=KFLS(JT)
14020 VINT(140+JT)=XS(JT)
14021 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
14022 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
14028 C*********************************************************************
14031 C...Generates pT-ordered spacelike initial-state parton showers and
14032 C...trial joinings.
14033 C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14034 C... interaction initiators at PT2NOW.
14035 C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14036 C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14037 C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14038 C... is below PT2CUT.
14039 C... (Also generate test joinings if MSTP(96)=1.)
14040 C...MODE= 1: Accept stored shower branching. Update event record etc.
14041 C...PT2NOW : Starting (max) PT2 scale for evolution.
14042 C...PT2CUT : Lower limit for evolution.
14043 C...PT2 : Result of evolution. Generated PT2 for trial emission.
14044 C...IFAIL : Status return code. IFAIL=0 when all is well.
14046 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14048 C...Double precision and integer declarations.
14049 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14050 IMPLICIT INTEGER(I-N)
14051 INTEGER PYK,PYCHGE,PYCOMP
14052 C...Parameter statement for maximum size of showers.
14053 PARAMETER (MAXNUR=1000)
14055 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14056 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14057 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14058 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14059 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14060 COMMON/PYINT1/MINT(400),VINT(400)
14061 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14062 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14063 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14064 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14065 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14066 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14067 COMMON/PYCTAG/NCT,MCT(4000,2)
14068 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
14069 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
14070 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
14071 C...Local variables
14072 DIMENSION ZSAV(2,240),PT2SAV(2,240),
14073 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
14074 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
14075 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
14076 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
14077 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
14078 C...For check on excessive weights.
14081 C...Only give errors for very large weights, otherwise just warnings
14082 DATA WTEMAX /1.5D0/
14083 C...Only give errors for large pT, otherwise just warnings
14088 C----------------------------------------------------------------------
14089 C...MODE=-1: Initialize initial state showers from scratch, i.e.
14090 C...starting from the hardest interaction initiators.
14091 IF (MODE.EQ.-1) THEN
14092 C...Set hard scattering SHAT.
14094 C...Mass thresholds and Lambda for QCD evolution.
14095 AEM2PI=PARU(101)/PARU(2)
14099 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
14100 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
14101 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
14102 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
14105 C...Massive quark forced creation threshold (in M**2).
14107 C...Set upper limit for X (ensures some X left for beam remnant).
14108 XMXC=1D0-2D0*PARP(111)/VINT(1)
14110 IF (MSTP(61).GE.1) THEN
14111 C...Initial values: flavours, momenta, virtualities.
14115 C...Special kinematics check for c/b quarks (that g -> c cbar or
14116 C...b bbar kinematically possible).
14117 KFLB=K(IMI(JS,1,1),2)
14119 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14120 C...Check PT2MAX > mQ^2
14121 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
14122 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14123 & 'No Q creation possible.')
14127 C...Check for physical z values (m == MQ / sqrt(s))
14128 C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14129 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
14130 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
14131 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
14132 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
14143 C...Zero joining array
14149 C----------------------------------------------------------------------
14150 C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14151 C...MINT(30). Store if emission PT2 scale is largest so far.
14152 C...Also generate test joinings if MSTP(96)=1.
14153 ELSEIF(MODE.EQ.0) THEN
14158 C...No shower for structureless beam
14159 IF (MINT(44+JS).EQ.1) RETURN
14162 C...Absolute shower max scale = VINT(56)
14163 PT2=MIN(PT2NOW,VINT(56))
14164 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
14165 C...Define for which processes ME corrections have been implemented.
14166 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
14167 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
14168 & .142.OR.ISUB.EQ.144) MECOR=1
14169 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
14170 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
14171 C...Calculate preweighting factor for ME-corrected processes.
14172 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14174 C...Basic info on daughter for which to find mother.
14175 KFLB=K(IMI(JS,MI,1),2)
14177 C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14178 C...second companion.
14179 KSVCB=MAX(-1,IMI(JS,MI,2))
14180 C...Treat "first" companion of a pair like an ordinary sea quark
14181 C...(except that creation diagram is not allowed)
14182 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
14183 C...X (rescaled to [0,1])
14184 XB=XMI(JS,MI)/VINT(142+JS)
14185 C...Massive quarks (use physical masses.)
14188 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14190 IF (KFLBA.EQ.5) RMQ2=RMB2
14191 C...Special threshold treatment for non-photon beams
14192 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
14195 C...Flags for parton distribution calls.
14196 MINT(105)=MINT(102+JS)
14197 MINT(109)=MINT(106+JS)
14198 VINT(120)=VINT(2+JS)
14200 C...Calculate initial parton distribution weights.
14201 IF(XB.GE.XMXC) THEN
14203 ELSEIF(MQMASS.EQ.0) THEN
14204 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14206 C...Initialize massive quark PT2 dependent pdf underestimate.
14208 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
14209 C.!.Tentative treatment of massive valence quarks.
14210 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
14212 TPM0=LOG(PT20/RMQ2)
14215 IF (KFLBA.LE.6) THEN
14216 C...For quarks, only include respective sea, val, or cmp part.
14217 IF (KSVCB.LE.0) THEN
14218 XFB(KFLB)=XPSVC(KFLB,KSVCB)
14220 C...Find companion's companion
14223 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
14227 C...Momentum fraction of the companion quark.
14228 C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
14230 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14234 C...Determine overestimated z range: switch at c and b masses.
14235 130 IF (PT2.GT.TMIN*RMB2) THEN
14237 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
14240 ELSEIF(PT2.GT.TMIN*RMC2) THEN
14242 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
14251 C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
14252 ALAM2=ALAM2/PARP(64)
14253 C...Overestimated ZMAX:
14254 IF (MQMASS.EQ.0) THEN
14256 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
14259 C...Massive (limit for bremsstrahlung diagram > creation)
14260 FMQ=SQRT(RMQ2/SHTNOW(MI))
14265 C...If kinematically impossible then do not evolve.
14266 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
14268 C...Reset Altarelli-Parisi and PDF weights.
14275 C...Zero joining weights and compute X(partner) and X(mother) values.
14276 IF (MSTP(96).NE.0) THEN
14278 DO 150 MJ=1,MINT(31)
14281 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
14282 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
14287 C...Approximate Altarelli-Parisi weights (integrated AP dz).
14288 C...q -> q, g -> q or q -> q + gamma (already set which).
14289 IF(KFLBA.LE.5) THEN
14290 C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
14291 IF (KSVCB.LT.0) THEN
14292 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14294 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
14295 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
14296 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
14298 WTAP(21)=0.5D0*(ZMAX-ZMIN)
14299 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14300 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
14301 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14302 WTAP(KFLB)=WTFF*WTAP(KFLB)
14303 WTAP(21)=WTGF*WTAP(21)
14306 IF (KSVCB.GE.1) THEN
14307 C...Kill normal creation but add joining diagrams for cmp quark.
14309 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14310 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
14311 & " quark here. Not handled yet, giving up!")
14316 C...Check for possible joinings
14317 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
14318 C...Find companion's companion.
14321 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
14322 IF (MJOIND(JS,MJ).EQ.0) THEN
14325 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
14326 IF (WTAPJ(MJ).GT.1D-6) THEN
14332 C...Add trial gluon joinings.
14333 DO 170 MJ=1,MINT(31)
14334 KFLC=K(IMI(JS,MJ,1),2)
14335 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
14336 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14337 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14338 IF (WTAPJ(MJ).GT.1D-6) THEN
14345 ELSEIF (IMI(JS,MI,2).GE.0) THEN
14346 C...Kill creation diagram for val quarks and sea quarks with companions.
14348 ELSEIF (MQMASS.EQ.0) THEN
14349 C...Extra safety factor for massless sea quark creation.
14350 WTAP(21)=WTAP(21)*1.25D0
14353 C... q -> g, g -> g.
14354 ELSEIF(KFLB.EQ.21) THEN
14355 C...Here we decide later whether a quark picked up is valence or
14356 C...sea, so we maintain the extra factor sqrt(z) since we deal
14357 C...with the *sum* of sea and valence in this context.
14358 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
14359 C...new: do not allow backwards evol to pick up heavy flavour.
14360 DO 180 KFL=1,MIN(3,MSTP(58))
14364 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
14365 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14367 WTAP(21)=WTGG*WTAP(21)
14369 C...Check for possible joinings (companions handled separately above)
14370 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
14372 DO 190 MJ=1,MINT(31)
14373 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
14375 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14376 IF (KSVCC.GE.1) GOTO 190
14377 KFLC=K(IMI(JS,MJ,1),2)
14378 C...Only try g -> g + g once.
14379 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
14380 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14381 IF (KFLC.EQ.21) THEN
14382 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14384 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
14386 IF (WTAPJ(MJ).GT.1D-6) THEN
14395 C...Initialize massive quark evolution
14396 IF (MQMASS.NE.0) THEN
14397 RML=(RMQ2+VINT(18))/ALAM2
14399 TPL=LOG((PT2+VINT(18))/ALAM2)
14400 TPM=LOG((PT2+VINT(18))/RMQ2)
14401 WN=WTAP(21)*WPDF0/B0
14405 C...Loopback point for iteration
14409 IF(NTRY.GT.500) THEN
14410 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
14415 C... Calculate PDF weights and sum for evolution rate.
14417 XFBO=MAX(1D-10,XFB(KFLB))
14419 WTPDF(KFL)=XFB(KFL)/XFBO
14420 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
14422 C...Only add gluon mother diagram for massless KFLB.
14423 IF(MQMASS.EQ.0) THEN
14424 WTPDF(21)=XFB(21)/XFBO
14425 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
14427 WTSUM=MAX(0.0001D0,WTSUM)
14429 C...Add joining diagrams where applicable.
14431 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14432 DO 220 MJ=1,MINT(31)
14433 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
14434 WTPDFJ(MJ)=1D0/XFBO
14435 C...x and x*pdf (+ sea/val) for parton C.
14436 KFLC=K(IMI(JS,MJ,1),2)
14438 KSVCC=MAX(-1,IMI(JS,MJ,2))
14439 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14442 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14444 IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
14445 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14446 ELSEIF (KSVCC.GE.1) THEN
14447 print*, 'error! parton C is companion!'
14449 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
14450 C...x and x*pdf (+ sea/val) for parton A.
14453 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14456 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14461 IF (KSVCA.LE.0) THEN
14462 C...Consider C the "evolved" parton if B is gluon. Val/sea
14463 C...counting will then be done correctly in PYPDFU.
14464 IF (KFLBA.EQ.21) MINT(36)=MJ
14465 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
14467 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
14469 C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
14470 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
14472 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
14473 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
14477 C...Pick normal pT2 (in overestimated z range).
14480 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
14483 C...Evolve q -> q gamma separately, pick it if larger pT.
14484 IF(KFLBA.LE.5) THEN
14485 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
14486 IF(PT2QED.GT.PT2) THEN
14493 C... Evolve massive quark creation separately.
14495 IF (MQMASS.NE.0) THEN
14496 PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
14498 C... Ensure mininimum PT2CR and force creation near threshold.
14499 IF (PT2CR.LT.TMIN*RMQ2) THEN
14501 IF (NTHRES.GT.50) THEN
14502 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
14503 & 'massive quark creation. Gave up trying.')
14511 C... Select largest PT2 (brems or creation):
14512 IF (PT2CR.GT.PT2) THEN
14521 C... Compute logarithms for this PT2
14522 TPL=LOG((PT2+VINT(18))/ALAM2)
14523 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
14524 WTCRQQ=TPM/LOG(PT2/RMQ2)
14527 C...Evolve joining separately
14529 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14530 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
14532 IF (PT2JN.GE.PT2) THEN
14538 C...Loopback if crossed c/b mass thresholds.
14539 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
14542 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
14547 C...Speed up shower. Skip if higher-PT acceptable branching
14548 C...already found somewhere else.
14549 C...Also finish if below lower cutoff.
14551 IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
14553 C...Select parton A flavour (massive Q handled above.)
14554 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
14558 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
14559 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
14560 IF(KFLA.EQ.6) KFLA=21
14561 ELSEIF (MJOIN.EQ.1) THEN
14562 C...Tentative joining accept/reject.
14563 WTRAN=PYR(0)*WTJOIN
14566 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
14567 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
14568 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
14569 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
14573 C...x*pdf (+ sea/val) at new pT2 for parton B.
14574 IF (KSVCB.LE.0) THEN
14576 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14577 IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
14579 C...Companion distributions do not evolve.
14582 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
14583 KFLC=K(IMI(JS,MJ,1),2)
14585 KSVCC=MAX(-1,IMI(JS,MJ,2))
14586 IF (KSVCB.GE.1) KSVCC=-1
14587 C...x*pdf (+ sea/val) at new pT2 for parton C.
14590 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14592 IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14593 WTVETO=WTVETO/XFJ(KFLC)
14594 C...x and x*pdf (+ sea/val) at new pT2 for parton A.
14597 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14600 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14604 IF (KSVCA.LE.0) THEN
14606 IF (KFLB.EQ.21) MINT(36)=MJ
14607 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
14609 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
14611 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
14613 WTVETO=WTVETO*XFJ(KFLA)
14614 C...Monte Carlo veto.
14615 IF (WTVETO.LT.PYR(0)) GOTO 200
14616 C...If accept, save PT2 of this joining.
14617 IF (PT2.GT.PT2MX) THEN
14625 C...Exit and continue evolution.
14630 C...Choose z value (still in overestimated range) and corrective weight.
14631 C...Unphysical z will be rejected below when Q2 has is computed.
14634 C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
14635 C...q -> q + g or q -> q + gamma (already set which).
14636 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
14637 IF (KSVCB.LT.0) THEN
14638 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
14640 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
14641 Z=((1-ZFAC)/(1+ZFAC))**2
14643 WTZ=0.5D0*(1D0+Z**2)
14644 C...Massive weight correction.
14645 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
14646 C...Valence quark weight correction (extra sqrt)
14647 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
14650 C...NB: MQ>0 not yet implemented. Forced absent above.
14651 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
14653 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
14654 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14657 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
14659 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
14660 WTZ=Z**2+(1D0-Z)**2
14661 C...Massive correction
14662 IF (MQMASS.NE.0) THEN
14663 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
14664 C...Extra safety margin for light sea quark creation
14665 ELSEIF (KSVCB.LT.0) THEN
14670 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14672 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
14673 & (ZMAX*(1D0-ZMIN)))**PYR(0))
14674 WTZ=(1D0-Z*(1D0-Z))**2
14677 C...Derive Q2 from pT2.
14679 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
14681 C...Loopback if outside allowed z range for given pT2.
14682 RM2C=PYMASS(KFLC)**2
14683 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
14684 IF (PT2ADJ.LT.1D-6) GOTO 230
14686 C...Loopback if nonordered in angle/rapidity.
14687 IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
14688 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
14692 C...Select phi angle of branching at random.
14695 C...Matrix-element corrections for some processes.
14696 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14697 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
14698 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14700 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
14701 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14703 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14704 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14706 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14707 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14712 C...Parton distributions at new pT2 but old x.
14714 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
14715 C...Treat val and cmp separately
14716 IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
14718 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14720 IF(XFBN.LT.1D-20) THEN
14721 IF(KFLA.EQ.KFLB) THEN
14734 C...Parton distributions at new pT2 and new x.
14737 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
14738 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
14739 C...q -> q + g: only consider respective sea, val, or cmp content.
14740 IF (KSVCB.LE.0) THEN
14741 XFA(KFLA)=XPSVC(KFLA,KSVCB)
14744 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
14748 IF(XFAN.LT.1D-20) THEN
14752 C...If weighting fails continue evolution.
14754 IF (MCRQQ.EQ.0) THEN
14755 WTPDFA=1D0/WTPDF(KFLA)
14756 WTTOT=WTZ*XFAN/XFBN*WTPDFA
14757 ELSEIF(MCRQQ.EQ.1) THEN
14759 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
14761 ELSEIF(MCRQQ.EQ.2) THEN
14762 C...Force massive quark creation.
14766 C...Loop back if trial emission fails.
14767 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
14768 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
14769 IF(WTTOT.LT.0D0) THEN
14770 WRITE(CHWT,'(1P,E12.4)') WTTOT
14771 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
14772 ELSEIF(WTTOT.GT.WTACC) THEN
14773 WRITE(CHWT,'(1P,E12.4)') WTTOT
14774 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
14775 C...Too high weight: write out as error, but do not update error counter.
14776 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
14778 & '(PYPTIS:) Weight '//CHWT//' above unity')
14779 IF (PT2.GT.PTEMAX) PTEMAX=PT2
14780 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
14783 & '(PYPTIS:) Weight '//CHWT//' above unity')
14785 C...Useful for debugging but commented out for distribution:
14786 C print*, 'JS, MI',JS, MI
14787 C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
14788 C print*, 'A -> B C',KFLA, KFLB, KFLC
14790 C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
14793 C...Save acceptable branching.
14794 IF(PT2.GT.PT2MX) THEN
14807 C----------------------------------------------------------------------
14808 C...MODE= 1: Accept stored shower branching. Update event record etc.
14809 ELSEIF (MODE.EQ.1) THEN
14814 C...Shift down rest of event record to make room for insertion.
14819 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
14820 KT1=K(I,4)/MSTU(5)**2
14821 KT2=K(I,5)/MSTU(5)**2
14822 ID1=MOD(K(I,4),MSTU(5))
14823 ID2=MOD(K(I,5),MSTU(5))
14824 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
14825 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
14826 IF (ID1.GE.IT) ID1=ID1+2
14827 IF (ID2.GE.IT) ID2=ID2+2
14828 IF (IM1.GE.IT) IM1=IM1+2
14829 IF (IM2.GE.IT) IM2=IM2+2
14830 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
14831 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
14837 MCT(I+2,1)=MCT(I,1)
14838 MCT(I+2,2)=MCT(I,2)
14841 C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
14842 DO 290 JI=1,MINT(31)
14843 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
14844 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
14845 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
14846 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
14847 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
14848 C...Also update companion pointers to the present mother.
14849 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
14852 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
14854 C...Zero entries dedicated for new timelike and mother partons.
14865 C...Define timelike and new mother partons. History.
14872 C...Set mother origin = side.
14873 K(IM,3)=MINT(83)+JS+2
14874 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
14876 C...Define colour flow of branching.
14879 C...q -> q + gamma.
14880 IF(K(IT,2).EQ.22) THEN
14885 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
14889 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
14892 C...qbar -> qbar + g.
14893 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
14896 C...qbar -> g + qbar.
14897 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
14900 C...g -> g + g; g -> q + qbar..
14901 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14908 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
14909 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
14910 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14911 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14912 IF(ID1.NE.ID2) THEN
14913 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14914 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14916 IF(K(IT,1).EQ.1) THEN
14920 C...Update IMI and colour tag arrays.
14928 C...If mother flag not yet set for spacelike parton, trace it.
14929 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
14930 IF(MINT(51).NE.0) RETURN
14934 C...If mother flag not yet set for timelike parton, trace it.
14935 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
14936 IF(MINT(51).NE.0) RETURN
14939 C...Boost recoiling parton to compensate for Q2 scale.
14940 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
14941 & (1D0+(1D0+Q2BMX/SHAT)**2)
14943 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
14945 C...Define system to be rotated and boosted
14946 C...(not including the 2 just added partons)
14947 C...(but including the docu lines for first interaction)
14948 IMIN=IMISEP(MI-1)+1
14949 IF (MI.EQ.1) IMIN=MINT(83)+5
14952 C...Rotate back system in phi to compensate for subsequent rotation.
14953 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
14955 C...Define kinematics of new partons in old frame.
14957 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
14958 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
14959 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
14960 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
14962 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
14963 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
14964 P(IT,5)=SQRT(RM2CMX)
14966 C...Update internal line, now spacelike
14967 P(IS,1)=P(IM,1)-P(IT,1)
14968 P(IS,2)=P(IM,2)-P(IT,2)
14969 P(IS,3)=P(IM,3)-P(IT,3)
14970 P(IS,4)=P(IM,4)-P(IT,4)
14971 P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
14972 C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
14973 IF (P(IS,5).LT.0D0) THEN
14974 P(IS,5)=-SQRT(ABS(P(IS,5)))
14976 P(IS,5)=SQRT(P(IS,5))
14979 C...Boost entire system and rotate to new frame.
14980 C...(including docu lines)
14981 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
14982 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
14983 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
14984 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
14989 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
14991 THETA=PYANGL(P(I1,3),P(I1,1))
14992 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
14994 C...Global statistics.
14995 MINT(352)=MINT(352)+1
14996 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14997 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14999 C...Add parton with relevant pT scale for timelike shower.
15000 IF (K(IT,2).NE.22) THEN
15003 PTPART(NPART)=SQRT(PT2AMX)
15006 C...Update saved variables.
15007 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15008 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15009 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15010 PT2SAV(JSMX,MIMX)=PT2MX
15015 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15016 C...Gluon reconstructs to quark.
15017 C...Decide whether newly created quark is valence or sea:
15019 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15020 IF(MINT(51).NE.0) RETURN
15022 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15023 C...Quark reconstructs to gluon.
15024 C...Now some guy may have lost his companion. Check.
15026 IF (ICMP.GT.0) THEN
15027 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15028 & //' away. Cannot handle that yet. Giving up.')
15031 ELSEIF(ICMP.LT.0) THEN
15032 C...A sea quark with companion still in BR was reconstructed to a gluon.
15033 C...Companion should now be removed from the beam remnant.
15034 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15037 DO 370 JCMP=ICMP,NVC(JS,IFL)-1
15038 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15039 DO 360 JI=1,MINT(31)
15041 JFL=-K(IMI(JS,JI,1),2)
15042 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15046 NVC(JS,IFL)=NVC(JS,IFL)-1
15048 C...Set gluon IMI(JS,MI,2) = 0.
15050 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15051 C...Quark reconstructing to quark. If sea with companion still in BR
15052 C...then update associated x value.
15053 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15054 IF (IMI(JS,MI,2).LT.0) THEN
15057 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15063 C...If reached this point, normal exit.
15069 C*********************************************************************
15072 C...Generates maximum ME weight in some initial-state showers.
15073 C...Inparameter MECOR: kind of hard scattering process
15074 C...Outparameter WTFF: maximum weight for fermion -> fermion
15075 C... WTGF: maximum weight for gluon/photon -> fermion
15076 C... WTFG: maximum weight for fermion -> gluon/photon
15077 C... WTGG: maximum weight for gluon -> gluon
15079 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15081 C...Double precision and integer declarations.
15082 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15083 IMPLICIT INTEGER(I-N)
15084 INTEGER PYK,PYCHGE,PYCOMP
15086 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15087 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15088 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15089 COMMON/PYINT1/MINT(400),VINT(400)
15090 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15091 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15093 C...Default maximum weight.
15099 C...Select maximum weight by process.
15100 IF(MECOR.EQ.1) THEN
15103 ELSEIF(MECOR.EQ.2) THEN
15111 C*********************************************************************
15114 C...Calculates actual ME weight in some initial-state showers.
15115 C...Inparameter MECOR: kind of hard scattering process
15116 C... IFLCB: flavour combination of branching,
15117 C... 1 for fermion -> fermion,
15118 C... 2 for gluon/photon -> fermion
15119 C... 3 for fermion -> gluon/photon,
15120 C... 4 for gluon -> gluon
15121 C... Q2: Q2 value of shower branching
15122 C... Z: Z value of branching
15123 C...In+outparameter PHIBR: azimuthal angle of branching
15124 C...Outparameter WTME: actual ME weight
15126 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
15128 C...Double precision and integer declarations.
15129 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15130 IMPLICIT INTEGER(I-N)
15131 INTEGER PYK,PYCHGE,PYCOMP
15133 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15134 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15135 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15136 COMMON/PYINT1/MINT(400),VINT(400)
15137 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15138 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15140 C...Default output.
15143 C...Define kinematics of shower branching in Mandelstam variables.
15147 UH=Q2-SQM*(1D0-Z)/Z
15149 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
15150 IF(MECOR.EQ.1) THEN
15151 IF(IFLCB.EQ.1) THEN
15152 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
15153 ELSEIF(IFLCB.EQ.2) THEN
15154 WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
15157 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
15158 ELSEIF(MECOR.EQ.2) THEN
15159 IF(IFLCB.EQ.3) THEN
15160 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
15161 ELSEIF(IFLCB.EQ.4) THEN
15162 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
15165 C...Matrix-element corrections for q + qbar -> Higgs (h0)
15166 ELSEIF(MECOR.EQ.3) THEN
15167 IF(IFLCB.EQ.2) THEN
15168 WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
15169 1 (SH**2+2D0*SQM*(SQM-SH))
15176 C*********************************************************************
15179 C...Handles the generation of additional interactions in the new
15180 C...multiple interactions framework.
15181 C...MODE=-1 : Initalize MI from scratch.
15182 C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
15183 C... Sudakov for PT2, abort if below PT2CUT.
15184 C...MODE= 1 : Accept interaction at PT2NOW and store variables.
15185 C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
15186 C...PT2NOW : Starting (max) PT2 scale for evolution.
15187 C...PT2CUT : Lower limit for evolution.
15188 C...PT2 : Result of evolution. Generated PT2 for trial interaction.
15189 C...IFAIL : Status return code.
15190 C... = 0: All is well.
15191 C... < 0: Phase space exhausted, generation to be terminated.
15192 C... > 0: Additional interaction vetoed, but continue evolution.
15194 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
15195 C...Double precision and integer declarations.
15196 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15197 IMPLICIT INTEGER(I-N)
15198 INTEGER PYK,PYCHGE,PYCOMP
15199 C...Parameter statement for maximum size of showers.
15200 PARAMETER (MAXNUR=1000)
15202 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15203 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15204 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15205 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15206 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15207 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15208 COMMON/PYINT1/MINT(400),VINT(400)
15209 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15210 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15211 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15212 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15213 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
15214 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
15215 & XMI(2,240),PT2MI(240),IMISEP(0:240)
15216 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
15217 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
15218 COMMON/PYCTAG/NCT,MCT(4000,2)
15219 C...Local arrays and saved variables.
15220 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
15222 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
15223 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
15224 & /PYISMX/,/PYCTAG/
15228 C...Set MI subprocess = QCD 2 -> 2.
15231 C----------------------------------------------------------------------
15232 C...MODE=-1: Initialize from scratch
15233 IF (MODE.EQ.-1) THEN
15234 C...Initialize PT2 array.
15236 C...Initialize list of incoming beams and partons from two sides.
15243 IMI(JS,1,1)=MINT(84)+JS
15245 XMI(JS,1)=VINT(40+JS)
15246 C...Rescale x values to fractions of photon energy.
15247 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
15248 C...Hard reset: hard interaction initiators motherless by definition.
15249 K(MINT(84)+JS,3)=2+JS
15250 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
15251 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
15255 IF (MOD(MSTP(81),10).GE.1) THEN
15256 IF(MSTP(82).LE.1) THEN
15257 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
15259 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
15260 & VINT(317)/(VINT(318)*VINT(320))
15261 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
15263 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
15264 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
15267 C...Zero entries relating to scatterings beyond the first.
15273 IMISEP(MI)=IMISEP(1)
15278 C...Initialize factors for PDF reshaping.
15280 KFBEAM(JS)=MINT(10+JS)
15281 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
15282 KFABM=IABS(KFBEAM(JS))
15283 KFSBM=ISIGN(1,KFBEAM(JS))
15285 C...Zero flavour content of incoming beam particle.
15289 C... Flavour content of baryon.
15290 IF(KFABM.GT.1000) THEN
15291 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
15292 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
15293 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
15294 C... Flavour content of pi+-, K+-.
15295 ELSEIF(KFABM.EQ.211) THEN
15296 KFIVAL(JS,1)=KFSBM*2
15297 KFIVAL(JS,2)=-KFSBM
15298 ELSEIF(KFABM.EQ.321) THEN
15299 KFIVAL(JS,1)=-KFSBM*3
15300 KFIVAL(JS,2)=KFSBM*2
15301 C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
15304 C...Zero initial valence and companion content.
15309 C...Set up colour line tags starting from hard interaction initiators.
15311 C...Reset colour tag array and colour processing flags.
15312 DO 150 I=IMISEP(0)+1,N
15315 K(I,4)=MOD(K(I,4),MSTU(5)**2)
15316 K(I,5)=MOD(K(I,5),MSTU(5)**2)
15318 C... Consider each side in turn.
15323 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15325 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
15327 CALL PYCTTR(I1,KCS,I2)
15328 IF(MINT(51).NE.0) RETURN
15332 C...Range checking for companion quark pdf large-x param.
15333 IF (MSTP(87).LT.0) THEN
15334 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15337 ELSEIF (MSTP(87).GT.4) THEN
15338 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15343 C----------------------------------------------------------------------
15344 C...MODE=0: Generate trial interaction. Return codes:
15345 C...IFAIL < 0: Phase space exhausted, generation to be terminated.
15346 C...IFAIL = 0: Additional interaction generated at PT2.
15347 C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
15348 ELSEIF (MODE.EQ.0) THEN
15349 C...Abolute MI max scale = VINT(62)
15350 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
15351 180 IF(MSTP(82).LE.1) THEN
15352 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
15353 IF(XT2.LT.VINT(149)) IFAIL=-2
15355 IF(XT2.LE.0.01001D0*VINT(149)) THEN
15358 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
15359 & LOG(PYR(0)))-VINT(149)
15362 C...Also exit if below lower limit or if higher trial branching
15364 PT2=0.25D0*VINT(2)*XT2
15365 IF (PT2.LE.PT2CUT) IFAIL=-4
15366 IF (PT2.LE.PT2MX) IFAIL=-5
15367 IF (IFAIL.NE.0) THEN
15371 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
15372 VINT(25)=4D0*PT2/VINT(2)
15375 C...Choose tau and y*. Calculate cos(theta-hat).
15376 IF(PYR(0).LE.COEF(ISUB,1)) THEN
15377 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
15378 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
15380 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
15383 C...New: require shat > 1.
15384 IF(TAU*VINT(2).LT.1D0) GOTO 180
15388 IF(RYST.GT.COEF(ISUB,8)) MYST=2
15389 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
15390 CALL PYKMAP(2,MYST,PYR(0))
15391 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
15393 C...Check that x not used up. Accept or reject kinematical variables.
15394 X1M=SQRT(TAU)*EXP(VINT(22))
15395 X2M=SQRT(TAU)*EXP(-VINT(22))
15396 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
15397 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
15398 CALL PYSIGH(NCHN,SIGS)
15399 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
15400 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
15401 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
15403 C...Save if highest PT so far.
15404 IF (PT2.GT.PT2MX) THEN
15410 C----------------------------------------------------------------------
15411 C...MODE=1: Generate and save accepted scattering.
15412 ELSEIF (MODE.EQ.1) THEN
15414 C...Reset K, P, V, and MCT vectors.
15426 C...Choose flavour of reacting partons (and subprocess).
15428 IF (NTRY.GT.50) THEN
15429 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
15430 & //'interaction. Giving up!')
15438 ICONMI=ISIG(ICHN,3)
15439 RSIGS=RSIGS-SIGH(ICHN)
15440 IF(RSIGS.LE.0D0) GOTO 230
15443 C...Reassign to appropriate process codes.
15444 230 ISUBMI=ICONMI/10
15445 ICONMI=MOD(ICONMI,10)
15447 C...Choose new quark flavour for annihilation graphs
15448 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
15449 SH=VINT(21)*VINT(2)
15450 CALL PYWIDT(21,SH,WDTP,WDTE)
15451 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
15452 DO 250 I=1,MDCY(21,3)
15453 KFLF=KFDP(I+MDCY(21,2)-1,1)
15454 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
15455 IF(RKFL.LE.0D0) GOTO 260
15457 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
15458 IF(KFLF.GE.4) GOTO 240
15459 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
15462 ELSEIF(ISUBMI.EQ.53) THEN
15468 C...Final state flavours and colour flow: default values
15475 IF(ISUBMI.EQ.11) THEN
15476 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
15478 IF(KFL1*KFL2.LT.0) KCC=KCC+2
15480 ELSEIF(ISUBMI.EQ.12) THEN
15481 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
15482 KFL3=ISIGN(KFLF,KFL1)
15486 ELSEIF(ISUBMI.EQ.13) THEN
15487 C...f + fbar -> g + g; th arbitrary
15492 ELSEIF(ISUBMI.EQ.28) THEN
15493 C...f + g -> f + g; th = (p(f)-p(f))**2
15494 IF(KFL1.EQ.21) JS=2
15496 IF(KFL1.EQ.21) KCC=KCC+2
15497 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
15498 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
15500 ELSEIF(ISUBMI.EQ.53) THEN
15501 C...g + g -> f + fbar; th arbitrary
15502 KCS=(-1)**INT(1.5D0+PYR(0))
15503 KFL3=ISIGN(KFLF,KCS)
15507 ELSEIF(ISUBMI.EQ.68) THEN
15508 C...g + g -> g + g; th arbitrary
15510 KCS=(-1)**INT(1.5D0+PYR(0))
15513 C...Check that massive sea quarks have non-zero phase space for g -> Q Q
15514 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
15515 & .OR.IABS(KFL4).EQ.5) THEN
15516 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
15517 IF (PT2.LE.1.05*RMMAX2) THEN
15518 IF (NTRY.EQ.1) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
15519 & //' created below threshold. Rejected.')
15524 C...Store flavours of scattering.
15532 C...Set flavours and mothers of scattering partons.
15541 K(N+1,3)=MINT(83)+1
15542 K(N+2,3)=MINT(83)+2
15546 C...Store colour connection indices.
15549 IF(KCS.EQ.-1) JC=3-J
15550 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
15551 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
15552 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
15553 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
15556 C...Store incoming and outgoing partons in their CM-frame.
15557 SHR=SQRT(VINT(21))*VINT(1)
15560 P(N+2,3)=-0.5D0*SHR
15562 P(N+3,5)=PYMASS(K(N+3,2))
15563 P(N+4,5)=PYMASS(K(N+4,2))
15564 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
15568 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
15569 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
15570 P(N+4,4)=SHR-P(N+3,4)
15573 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
15575 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
15577 C...Global statistics.
15578 MINT(351)=MINT(351)+1
15579 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
15580 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
15582 C...Keep track of loose colour ends and information on scattering.
15583 MINT(31)=MINT(31)+1
15585 PT2MI(MINT(36))=PT2
15586 IMISEP(MINT(31))=N+4
15588 IMI(JS,MINT(31),1)=N+JS
15589 IMI(JS,MINT(31),2)=0
15590 XMI(JS,MINT(31))=VINT(40+JS)
15592 C...Update cumulative counters
15593 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
15594 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
15597 C...Add to list of final state partons
15600 PTPART(NPART+1)=SQRT(PT2)
15601 PTPART(NPART+2)=SQRT(PT2)
15605 NISGEN(1,MINT(31))=0
15606 NISGEN(2,MINT(31))=0
15610 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
15611 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
15616 C...Finally, assign colour tags to new partons
15618 I1=IMI(JS,MINT(31),1)
15619 I2=IMI(3-JS,MINT(31),1)
15621 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15623 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
15625 CALL PYCTTR(I1,KCS,I2)
15626 IF(MINT(51).NE.0) RETURN
15630 C----------------------------------------------------------------------
15631 C...MODE=2: Decide whether quarks in last scattering were valence,
15632 C...companion, or sea.
15633 ELSEIF (MODE.EQ.2) THEN
15637 KFSBM=ISIGN(1,MINT(10+JS))
15638 IFL=K(IMI(JS,MI,1),2)
15640 IF (IABS(IFL).GE.6) THEN
15641 IF (IABS(IFL).EQ.6) THEN
15642 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
15646 C...Get PDFs at X(rescaled) and PT2 of the current initiator.
15647 C...(Do not include the parton itself in the X rescaling.)
15649 XRSC=X/(VINT(142+JS)+X)
15650 C...Note: XPSVC = x*pdf.
15652 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
15656 DO 310 IVC=1,NVC(JS,IFL)
15657 CMP=CMP+XPSVC(IFL,IVC)
15660 C...Decide (Extra factor x cancels in the dvision).
15661 320 RVCS=PYR(0)*(SEA+VAL+CMP)
15663 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
15664 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
15666 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
15667 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
15668 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
15669 IF(KFIVAL(JS,1).EQ.0) THEN
15670 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
15671 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
15672 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
15673 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
15675 C...Count down valence remaining. Do not count current scattering.
15676 DO 340 I1=1,NMI(JS)
15677 IF (I1.EQ.MINT(36)) GOTO 340
15678 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
15682 IF(IVNOW.EQ.0) GOTO 330
15685 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
15686 IF(KFIVAL(JS,1).EQ.0) THEN
15687 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
15690 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
15692 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
15693 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
15697 ELSEIF (RVCS.LE.VAL+SEA) THEN
15698 C...If sea, add opposite sign companion parton. Store X and I.
15699 NVC(JS,-IFL)=NVC(JS,-IFL)+1
15700 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
15701 C...Set pointer to companion
15702 IMI(JS,MI,2)=-NVC(JS,-IFL)
15705 C...If companion, decide which one.
15706 IF (NVC(JS,IFL).EQ.0) THEN
15708 CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
15714 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
15715 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
15716 C...Find original sea (anti-)quark. Do not consider current scattering.
15718 DO 360 I1=1,NMI(JS)
15719 IF (I1.EQ.MINT(36)) GOTO 360
15720 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
15721 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
15722 IMI(JS,MI,2)=IMI(JS,I1,1)
15723 IMI(JS,I1,2)=IMI(JS,MI,1)
15726 C...Mark companion "out-kicked".
15727 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
15734 C*********************************************************************
15736 C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
15737 C...Giving the x*f pdf of a companion quark, with its partner at XS,
15738 C...using an approximate gluon density like (1-X)^NPOW/X. The value
15739 C...corresponds to an unrescaled range between 0 and 1-X.
15741 FUNCTION PYFCMP(XC,XS,NPOW)
15743 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
15747 C...Parent gluon momentum fraction
15749 IF (Y.GE.1D0) RETURN
15750 C...Common factor (includes factor XC, since PYFCMP=x*f)
15751 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
15752 C...Store normalized companion x*f distribution.
15753 IF (NPOW.LE.0) THEN
15754 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
15755 ELSEIF (NPOW.EQ.1) THEN
15756 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
15757 ELSEIF (NPOW.EQ.2) THEN
15758 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
15759 & +3D0*XS*(1D0+XS)*LOG(XS)))
15760 ELSEIF (NPOW.EQ.3) THEN
15761 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
15762 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
15763 ELSEIF (NPOW.GE.4) THEN
15764 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
15765 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
15770 C*********************************************************************
15772 C...PYPCMP: Auxiliary to PYPDFU.
15773 C...Giving the momentum integral of a companion quark, with its
15774 C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
15775 C...The value corresponds to an unrescaled range between 0 and 1-XS.
15777 FUNCTION PYPCMP(XS,NPOW)
15779 DOUBLE PRECISION XS, PYPCMP
15781 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
15783 ELSEIF (NPOW.LE.0) THEN
15784 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
15785 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
15786 ELSEIF (NPOW.EQ.1) THEN
15787 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
15788 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
15789 ELSEIF (NPOW.EQ.2) THEN
15790 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
15791 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
15792 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
15793 & -3D0*XS*LOG(XS)*(1+XS)))
15794 ELSEIF (NPOW.EQ.3) THEN
15795 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
15796 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
15797 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
15798 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
15800 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
15801 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
15802 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
15803 & -6D0*XS*LOG(XS)*(1D0+XS)))
15808 C*********************************************************************
15811 C...Rearranges contents of the HEPEUP commonblock so that
15812 C...mothers precede daughters and daughters of a decay are
15813 C...listed consecutively.
15817 C...Double precision and integer declarations.
15818 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15819 IMPLICIT INTEGER(I-N)
15821 C...User process event common block.
15823 PARAMETER (MAXNUP=500)
15824 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
15825 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
15826 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
15827 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
15828 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
15832 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
15833 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
15834 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
15836 C...Check whether a rearrangement is required.
15839 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
15842 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
15846 C...Find the new order that particles should have.
15852 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
15857 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
15858 IF(NNEW.NE.NUP) THEN
15860 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
15864 C...Copy old info into temporary storage.
15868 MOTUPT(1,I)=MOTHUP(1,I)
15869 MOTUPT(2,I)=MOTHUP(2,I)
15870 ICOUPT(1,I)=ICOLUP(1,I)
15871 ICOUPT(2,I)=ICOLUP(2,I)
15875 VTIUPT(I)=VTIMUP(I)
15876 SPIUPT(I)=SPINUP(I)
15879 C...Copy info back into HEPEUP in right order.
15882 IDUP(I)=IDUPT(IOLD)
15883 ISTUP(I)=ISTUPT(IOLD)
15887 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
15888 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
15890 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
15892 MOTHUP(1,I)=MOTHUP(2,I)
15895 ICOLUP(1,I)=ICOUPT(1,IOLD)
15896 ICOLUP(2,I)=ICOUPT(2,IOLD)
15898 PUP(J,I)=PUPT(J,IOLD)
15900 VTIMUP(I)=VTIUPT(IOLD)
15901 SPINUP(I)=SPIUPT(IOLD)
15905 c...If incoming particles are massive recalculate to put them massless.
15906 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
15907 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
15908 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
15909 PUP(4,1)=0.5D0*PPLUS
15912 PUP(4,2)=0.5D0*PMINUS
15920 C*********************************************************************
15923 C...Administers the generation of successive final-state showers
15924 C...in external processes.
15926 SUBROUTINE PYADSH(NFIN)
15928 C...Double precision and integer declarations.
15929 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15930 IMPLICIT INTEGER(I-N)
15931 INTEGER PYK,PYCHGE,PYCOMP
15932 C...Parameter statement for maximum size of showers.
15933 PARAMETER (MAXNUR=1000)
15935 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15936 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15937 COMMON/PYCTAG/NCT,MCT(4000,2)
15938 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15939 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15940 COMMON/PYINT1/MINT(400),VINT(400)
15941 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
15943 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
15945 C...Set primary vertex.
15947 V(MINT(83)+5,J)=0D0
15948 V(MINT(83)+6,J)=0D0
15949 V(MINT(84)+1,J)=0D0
15950 V(MINT(84)+2,J)=0D0
15953 C...Isolate systems of particles with the same mother.
15956 DO 140 I=MINT(84)+3,NFIN
15958 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
15965 C...Set production vertices.
15966 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
15973 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
15976 IF(MSTP(125).GE.1) THEN
15984 C...End loop over systems. Return if no showers to be performed.
15985 IBEG(NSYS+1)=NFIN+1
15986 IF(MSTP(71).LE.0) RETURN
15988 C...Loop through systems of particles; check that sensible size.
15990 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
15991 IF(MINT(35).LE.1) THEN
15992 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
15994 ELSEIF(NSIZ.LE.1) THEN
15995 CALL PYERRM(2,'(PYADSH:) only one particle in system')
15997 ELSEIF(NSIZ.GT.80) THEN
15998 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
16003 C...Save status codes and daughters of showering particles; reset them.
16010 IF(K(I,1).GT.10) THEN
16012 IF(KSAV(II,1).EQ.14) K(I,1)=3
16014 IF(KSAV(II,1).LE.10) THEN
16015 ELSEIF(K(I,1).EQ.1) THEN
16021 KSAV(II,4)=MOD(K(I,4),MSTU(5))
16022 KSAV(II,5)=MOD(K(I,5),MSTU(5))
16023 K(I,4)=K(I,4)-KSAV(II,4)
16024 K(I,5)=K(I,5)-KSAV(II,5)
16027 PSUM(J)=PSUM(J)+P(I,J)
16031 C...Perform shower.
16032 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16034 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16036 IF(MINT(35).LE.1) THEN
16038 if(parj(200).eq.1.) CALL PYSHOWQ(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16039 if(parj(200).ne.1.) CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16041 if(parj(200).ne.1.) CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16042 if(parj(200).eq.1.) CALL PYSHOWQ(IBEG(ISYS),-NSIZ,QMAX)
16045 C...For external processes, first call, also ISR partons radiate.
16046 C...Can use existing PYPART list, removing partons that radiate later.
16047 ELSEIF(ISYS.EQ.1) THEN
16050 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16052 IPART(NPARTN)=IPART(II)
16053 PTPART(NPARTN)=PTPART(II)
16057 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16059 C...For subsequent calls use the systems excluded above.
16065 PTPART(II)=0.5D0*QMAX
16067 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16070 C...Look up showered copies of original showering particles.
16074 C...Particles without daughters need not be studied.
16075 IF(KSAV(II,1).LE.10) GOTO 260
16076 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16077 ELSEIF(K(I,1).EQ.11) THEN
16078 190 IMV=MOD(K(IMV,4),MSTU(5))
16079 IF(K(IMV,1).EQ.11) GOTO 190
16081 KDA1=MOD(K(I,4),MSTU(5))
16083 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16085 KDA2=MOD(K(I,5),MSTU(5))
16087 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16090 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
16093 KDA1=MOD(K(I3,4),MSTU(5))
16095 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16097 KDA2=MOD(K(I3,5),MSTU(5))
16099 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16105 C...Restore daughter info of original partons to showered copies.
16106 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
16107 IF(KSAV(II,1).LE.10) THEN
16108 ELSEIF(K(I,1).EQ.1) THEN
16109 K(IMV,4)=KSAV(II,4)
16110 K(IMV,5)=KSAV(II,5)
16112 K(IMV,4)=K(IMV,4)+KSAV(II,4)
16113 K(IMV,5)=K(IMV,5)+KSAV(II,5)
16116 C...Reset mother info of existing daughters to showered copies.
16117 DO 210 I3=IBEG(ISYS+1),NFIN
16118 IF(K(I3,3).EQ.I) K(I3,3)=IMV
16119 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
16120 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
16121 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
16125 C...Boost all original daughters to new frame of showered copy.
16126 C...Also update their colour tags.
16129 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
16131 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
16133 BETA(J)=FAC*BETA(J)
16135 DO 250 I3=IBEG(ISYS+1),NFIN
16138 IF(MSTP(128).LE.0) THEN
16139 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
16140 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
16142 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16143 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16144 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16147 IF(IMO.EQ.IMV) THEN
16148 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16149 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16150 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16151 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
16159 C...End of loop over showering systems
16165 C*********************************************************************
16168 C...Interface to UPVETO, which allows user to veto event generation
16169 C...on the parton level, after parton showers but before multiple
16170 C...interactions, beam remnants and hadronization is added.
16172 SUBROUTINE PYVETO(IVETO)
16174 C...All real arithmetic in double precision.
16175 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16176 C...Three Pythia functions return integers, so need declaring.
16177 INTEGER PYK,PYCHGE,PYCOMP
16179 C...PYTHIA commonblocks.
16180 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16181 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16182 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16183 COMMON/PYINT1/MINT(400),VINT(400)
16184 SAVE /PYJETS/,/PYPARS/,/PYINT1/
16185 C...HEPEVT commonblock.
16186 PARAMETER (NMXHEP=4000)
16187 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16188 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
16189 DOUBLE PRECISION PHEP,VHEP
16192 DIMENSION IRESO(100)
16194 C...Define longitudinal boost from initiator rest frame to cm frame.
16195 IF(MINT(35).EQ.3) THEN
16196 C...The last frame is different depending upon old and new shower
16200 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
16201 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
16204 C... Reset counters.
16209 C...Oth pass: identify beam and incoming partons
16210 DO 140 I=MINT(83)+1,MINT(83)+6
16212 C IF(K(I,2).EQ.94.OR.K(I,2).EQ.0) THEN
16213 IF(K(I,2).EQ.94) THEN
16223 IF(ISTORE.EQ.1) THEN
16224 C...Copy parton info, boosting momenta along z axis to cm frame.
16230 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16231 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16237 C...Store one mother. Rest of history and vertex info zeroed.
16249 C...First pass: identify final locations of resonances
16250 C...and of their daughters before showering.
16251 DO 150 I=MINT(84)+3,N
16255 C...Skip shower CM frame documentation lines.
16256 IF(K(I,2).EQ.94) THEN
16258 C... Store a new intermediate product, when mother in documentation.
16259 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
16260 & K(I,3).LE.MINT(84)) THEN
16268 C... Store a new intermediate product, when mother in main section.
16269 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
16270 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
16276 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3))
16279 IF(ISTORE.EQ.1) THEN
16280 C...Copy parton info, boosting momenta along z axis to cm frame.
16285 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16286 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16288 C...Store one mother. Rest of history and vertex info zeroed.
16300 C...Second pass: identify current set of "final" partons.
16301 DO 200 I=MINT(84)+3,N
16305 C...Store a final parton.
16306 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
16310 C..Trace it back through shower, to check if from documented particle.
16314 IF(IHIST.GT.MINT(84)) THEN
16315 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
16317 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
16321 IF(IMOTH.EQ.0) GOTO 160
16322 ELSEIF(IHIST.LE.4) THEN
16323 IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
16332 IF(ISTORE.EQ.1) THEN
16333 C...Copy parton info, boosting momenta along z axis to cm frame.
16338 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16339 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16341 C...Store one mother. Rest of history and vertex info zeroed.
16353 C...Call user-written routine to decide whether to keep events.
16358 C*********************************************************************
16361 C...Allows resonances to decay (including parton showers for hadronic
16364 SUBROUTINE PYRESD(IRES)
16366 C...Double precision and integer declarations.
16367 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16368 IMPLICIT INTEGER(I-N)
16369 INTEGER PYK,PYCHGE,PYCOMP
16370 C...Parameter statement to help give large particle numbers.
16371 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16372 &KEXCIT=4000000,KDIMEN=5000000)
16373 C...Parameter statement for maximum size of showers.
16374 PARAMETER (MAXNUR=1000)
16376 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16377 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16378 COMMON/PYCTAG/NCT,MCT(4000,2)
16379 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16380 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16381 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16382 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16383 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16384 COMMON/PYINT1/MINT(400),VINT(400)
16385 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16386 COMMON/PYINT4/MWID(500),WIDS(500,5)
16387 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
16388 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/
16389 C...Local arrays and complex and character variables.
16390 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
16391 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
16392 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
16393 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
16394 &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(3),ITRI(3),IOCT(3)
16395 COMPLEX FGK,HA(6,6),HC(6,6)
16397 CHARACTER CODE*9,MASS*9
16399 C...The F, Xi and Xj functions of Gunion and Kunszt
16400 C...(Phys. Rev. D33, 665, plus errata from the authors).
16401 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
16402 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
16403 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
16404 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
16405 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
16406 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
16407 &2D0*(D34/D56+D56/D34))
16409 C...Some general constants.
16412 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
16416 GMMZ=PMAS(23,1)*PMAS(23,2)
16418 GMMW=PMAS(24,1)*PMAS(24,2)
16421 C...Boost and rotate to rest frame of incoming partons,
16422 C...to get proper amount of smearing of decay angles.
16426 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
16427 BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
16428 BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
16429 BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
16430 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
16431 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
16432 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
16433 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
16434 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
16437 C...Reset original resonance configuration.
16442 C...Define initial one, two or three objects for subprocess.
16446 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
16447 IREF(1,1)=MINT(84)+2+ISET(ISUB)
16448 IREF(1,4)=MINT(83)+6+ISET(ISUB)
16450 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
16451 IREF(1,1)=MINT(84)+1+ISET(ISUB)
16452 IREF(1,2)=MINT(84)+2+ISET(ISUB)
16453 IREF(1,4)=MINT(83)+5+ISET(ISUB)
16454 IREF(1,5)=MINT(83)+6+ISET(ISUB)
16456 ELSEIF(ISET(ISUB).EQ.5) THEN
16457 IREF(1,1)=MINT(84)+3
16458 IREF(1,2)=MINT(84)+4
16459 IREF(1,3)=MINT(84)+5
16460 IREF(1,4)=MINT(83)+7
16461 IREF(1,5)=MINT(83)+8
16462 IREF(1,6)=MINT(83)+9
16466 C...Define original resonance for odd cases.
16469 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
16471 IF(IHDEC.EQ.1) ISUB=3
16473 IREF(1,4)=K(IRES,3)
16475 IF(IREF(1,4).GT.MINT(84)) THEN
16476 110 ITMPMO=IREF(1,4)
16477 IF(K(ITMPMO,2).EQ.94) THEN
16478 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
16479 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
16480 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
16482 C...Explicitly check that reference particle exists, otherwise stop recursion
16483 IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
16484 IREF(1,4)=K(ITMPMO,3)
16489 IF(IREF(1,4).GT.MINT(84)) THEN
16492 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
16493 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
16496 EMATCH=ABS(P(II,4)-P(IREF14,4))
16503 C...Check if initial resonance has been moved (in resonance + jet).
16505 IF(IREF(1,JT).GT.0) THEN
16506 IF(K(IREF(1,JT),1).GT.10) THEN
16507 KFA=IABS(K(IREF(1,JT),2))
16508 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
16509 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
16510 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
16511 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
16512 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16514 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
16515 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16517 DO 130 I=IREF(1,JT)+1,N
16518 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
16521 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
16522 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
16523 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
16524 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16526 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
16527 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16532 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
16533 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
16539 C...Set decay vertex for initial resonances
16542 V(IREF(1,JT),I)=0D0
16546 C...Loop over decay history.
16552 IF(IREF(IP,2).EQ.0) JTMAX=1
16553 IF(IREF(IP,3).NE.0) JTMAX=3
16557 C...Check for Higgs which appears as decay product of user-process.
16560 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
16562 IF(IHDEC.EQ.1) ISUB=3
16565 C...Start treatment of one, two or three resonances in parallel.
16577 C...Check whether particle can/is allowed to decay.
16578 IF(ID.EQ.0) GOTO 330
16581 IF(MWID(KCA).EQ.0) GOTO 330
16582 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
16583 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
16584 & KFA.EQ.18) IT4=IT4+1
16585 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
16586 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
16588 C...Choose lifetime and determine decay vertex.
16589 IF(K(ID,1).EQ.5) THEN
16591 ELSEIF(K(ID,1).NE.4) THEN
16592 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
16595 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
16598 C...Determine whether decay allowed or not.
16600 IF(MSTJ(22).EQ.2) THEN
16601 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
16602 ELSEIF(MSTJ(22).EQ.3) THEN
16603 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
16604 ELSEIF(MSTJ(22).EQ.4) THEN
16605 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
16606 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
16608 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
16613 C...Info for selection of decay channel: sign, pairings.
16614 IF(KCHG(KCA,3).EQ.0) THEN
16617 IPM=(5-ISIGN(1,K(ID,2)))/2
16620 IF(JTMAX.EQ.2) THEN
16621 KFB=IABS(K(IREF(IP,3-JT),2))
16622 ELSEIF(JTMAX.EQ.3) THEN
16624 KFB=IABS(K(IREF(IP,JT2),2))
16625 IF(KFB.NE.KFA) THEN
16626 JT2=JT+2-3*((JT+1)/3)
16627 KFB=IABS(K(IREF(IP,JT2),2))
16631 C...Select decay channel.
16632 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
16633 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
16634 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
16635 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
16636 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
16637 IF(WDTE0S.LE.0D0) GOTO 330
16641 IDC=IDL+MDCY(KCA,2)-1
16642 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
16643 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
16644 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
16646 C...Read out flavours and colour charges of decay channel chosen.
16647 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
16648 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
16649 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
16650 KFC1A=PYCOMP(IABS(KFL1(JT)))
16651 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
16652 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
16653 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
16654 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
16655 KFC2A=PYCOMP(IABS(KFL2(JT)))
16656 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
16657 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
16658 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
16659 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
16661 IF(KFL3(JT).NE.0) THEN
16662 KFC3A=PYCOMP(IABS(KFL3(JT)))
16663 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
16664 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
16665 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
16668 C...Set/save further info on channel.
16670 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
16672 HGZ(JT,1)=VINT(111)
16673 HGZ(JT,2)=VINT(112)
16674 HGZ(JT,3)=VINT(114)
16677 C...Select masses; to begin with assume resonances narrow.
16682 KFLW=IABS(KFL1(JT))
16684 ELSEIF(I.EQ.2) THEN
16685 KFLW=IABS(KFL2(JT))
16687 ELSEIF(I.EQ.3) THEN
16688 IF(KFL3(JT).EQ.0) GOTO 220
16689 KFLW=IABS(KFL3(JT))
16692 P(N+I,5)=PMAS(KCW,1)
16694 C...This prevents SUSY/t particles from becoming too light.
16695 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
16696 PMMN(I)=PMAS(KCW,1)
16697 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
16698 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
16699 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
16700 & PMAS(PYCOMP(KFDP(IDC,2)),1)
16701 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
16702 & PMAS(PYCOMP(KFDP(IDC,3)),1)
16703 PMMN(I)=MIN(PMMN(I),PMSUM)
16707 ELSEIF(KFLW.EQ.6) THEN
16708 PMMN(I)=PMAS(24,1)+PMAS(5,1)
16712 C...Check which two out of three are widest.
16715 PWID1=PMAS(KFC1A,2)
16716 PWID2=PMAS(KFC2A,2)
16717 KFLW1=IABS(KFL1(JT))
16718 KFLW2=IABS(KFL2(JT))
16719 IF(KFL3(JT).NE.0) THEN
16720 PWID3=PMAS(KFC3A,2)
16721 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
16724 KFLW1=IABS(KFL3(JT))
16725 ELSEIF(PWID3.GT.PWID2) THEN
16728 KFLW2=IABS(KFL3(JT))
16732 C...If all narrow then only check that masses consistent.
16733 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
16734 & PWID2.LT.PARP(41))) THEN
16736 C....Handle near degeneracy cases.
16737 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
16738 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
16739 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
16740 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
16744 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
16745 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
16748 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
16749 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
16754 C...For three wide resonances select narrower of three
16755 C...according to BW decoupled from rest.
16758 IF(KFL3(JT).NE.0) THEN
16759 IWID3=6-IWID1-IWID2
16760 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
16764 P(N+IWID3,5)=PYMASS(KFLW3)
16765 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
16766 PMTOT=PMTOT-P(N+IWID3,5)
16768 C...Select other two correlated within remaining phase space.
16772 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
16773 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
16774 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
16779 CKIN(49)=PMMN(IWID1)
16780 CKIN(50)=PMMN(IWID2)
16781 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
16786 IF(MINT(51).EQ.1) GOTO 720
16789 C...Begin fill decay products, with colour flow for coloured objects.
16794 C...Three-body decays
16795 IF(KFL3(JT).NE.0) THEN
16812 C...Generate kinematics (default is flat)
16815 C...Set generic colour flows whenever unambiguous,
16816 C...(independently of the order of the decay products)
16817 C...Sum up total colour content
16826 IF (KCQ(J).EQ.-1) THEN
16829 ELSEIF (KCQ(J).EQ.1) THEN
16832 ELSEIF (KCQ(J).EQ.2) THEN
16838 C...Set color flow for generic 1 -> N processes (N arbitrary)
16839 IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
16840 C...All singlets: do nothing
16842 ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
16843 C...Two octets, zero triplets, n singlets:
16844 IF (KCQ(0).EQ.2) THEN
16846 K(ID,4)=K(ID,4)+IOCT(2)
16847 K(ID,5)=K(ID,5)+IOCT(2)
16849 K(IOCT(2),4)=MSTU(5)*ID
16850 K(IOCT(2),5)=MSTU(5)*ID
16851 MCT(IOCT(2),1)=MCT(ID,1)
16852 MCT(IOCT(2),2)=MCT(ID,2)
16854 C...1 -> 8 + 8 + n(1)
16856 K(IOCT(1),4)=MSTU(5)*IOCT(2)
16857 K(IOCT(1),5)=MSTU(5)*IOCT(2)
16859 K(IOCT(2),4)=MSTU(5)*IOCT(1)
16860 K(IOCT(2),5)=MSTU(5)*IOCT(1)
16869 ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
16870 C...Two triplets, zero octets, n singlets.
16871 IF (KCQ(0).EQ.1) THEN
16873 K(ID,4)=K(ID,4)+ITRI(2)
16875 K(ITRI(2),4)=MSTU(5)*ID
16876 MCT(ITRI(2),1)=MCT(ID,1)
16877 ELSEIF (KCQ(0).EQ.-1) THEN
16878 C...3bar -> 3bar + n(1)
16879 K(ID,5)=K(ID,5)+IANT(2)
16881 K(IANT(2),5)=MSTU(5)*ID
16882 MCT(IANT(2),2)=MCT(ID,2)
16884 C...1 -> 3 + 3bar + n(1)
16886 K(ITRI(1),4)=MSTU(5)*IANT(1)
16888 K(IANT(1),5)=MSTU(5)*ITRI(1)
16894 ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
16895 C...Two triplets, one octet, n singlets.
16896 IF (KCQ(0).EQ.2) THEN
16897 C...8 -> 3 + 3bar + n(1)
16898 K(ID,4)=K(ID,4)+ITRI(1)
16899 K(ID,5)=K(ID,5)+IANT(1)
16901 K(ITRI(1),4)=MSTU(5)*ID
16903 K(IANT(1),5)=MSTU(5)*ID
16904 MCT(ITRI(1),1)=MCT(ID,1)
16905 MCT(IANT(1),2)=MCT(ID,2)
16906 ELSEIF (KCQ(0).EQ.1) THEN
16907 C...3 -> 8 + 3 + n(1)
16908 K(ID,4)=K(ID,4)+IOCT(1)
16910 K(IOCT(1),4)=MSTU(5)*ID
16911 K(IOCT(1),5)=MSTU(5)*ITRI(2)
16913 K(ITRI(2),4)=MSTU(5)*IOCT(1)
16914 MCT(IOCT(1),1)=MCT(ID,1)
16918 ELSEIF (KCQ(0).EQ.-1) THEN
16919 C...3bar -> 8 + 3bar + n(1)
16920 K(ID,5)=K(ID,5)+IOCT(1)
16922 K(IOCT(1),5)=MSTU(5)*ID
16923 K(IOCT(1),4)=MSTU(5)*IANT(2)
16925 K(IANT(2),5)=MSTU(5)*IOCT(1)
16926 MCT(IOCT(1),2)=MCT(ID,2)
16931 C...1 -> 3 + 3bar + 8 + n(1)
16933 K(ITRI(1),4)=MSTU(5)*IOCT(1)
16935 K(IOCT(1),5)=MSTU(5)*ITRI(1)
16936 K(IOCT(1),4)=MSTU(5)*IANT(1)
16938 K(IANT(1),5)=MSTU(5)*IOCT(1)
16946 CPS-- End of generic cases
16947 C...(could three octets also be handled?)
16948 C...(could (some of) the RPV cases be made generic as well?)
16950 C...Special cases (= old treatment)
16951 C...Set colour flow for t -> W + b + Z.
16952 ELSEIF(KFA.EQ.6) THEN
16955 IF(KCQM(JT).EQ.-1) ISID=5
16957 K(ID,ISID)=K(ID,ISID)+IDAU
16958 K(IDAU,ISID)=MSTU(5)*ID
16960 C...Set colour flow in three-body decays - programmed as special cases.
16962 ELSEIF(KFC2A.LE.6) THEN
16966 IF(KFL2(JT).LT.0) ISID=5
16967 K(N+2,ISID)=MSTU(5)*(N+3)
16968 K(N+3,9-ISID)=MSTU(5)*(N+2)
16969 C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
16970 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
16971 & .AND.KFL3(JT).NE.0) THEN
16972 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
16973 C...3-body decays of squarks to colour singlets plus one quark
16974 IF (KQSUMA.EQ.1) THEN
16977 IF (KCQ1(JT).NE.0) IQ=1
16978 IF (KCQ2(JT).NE.0) IQ=2
16979 IF (KCQ3(JT).NE.0) IQ=3
16981 IF (K(N+IQ,2).LT.0) ISID=5
16983 K(ID,ISID)=K(ID,ISID)+(N+IQ)
16984 K(N+IQ,ISID)=MSTU(5)*ID
16987 ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
16992 IF(KFL2(JT).LT.0) ISID=5
16993 K(N+1,ISID)=MSTU(5)*(N+2)
16994 K(N+1,9-ISID)=MSTU(5)*(N+3)
16995 K(N+2,ISID)=MSTU(5)*(N+1)
16996 K(N+3,9-ISID)=MSTU(5)*(N+1)
16997 ELSEIF(KFA.EQ.KSUSY1+21) THEN
17001 IF(KFL2(JT).LT.0) ISID=5
17002 K(ID,ISID)=K(ID,ISID)+(N+2)
17003 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
17004 K(N+2,ISID)=MSTU(5)*ID
17005 K(N+3,9-ISID)=MSTU(5)*ID
17008 ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
17009 & IABS(KCQ2(JT)).EQ.1) THEN
17013 IF(KFL2(JT).LT.0) ISID=5
17014 K(N+2,ISID)=MSTU(5)*(N+3)
17015 K(N+3,9-ISID)=MSTU(5)*(N+2)
17020 C...Set colour flow in three-body decays with baryon number violation.
17021 C...Neutralino and chargino decays first.
17022 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
17023 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
17024 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
17025 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17026 C...Insert junction to keep track of colours.
17027 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17028 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17029 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17030 C...Set special junction codes:
17034 C...Order decay products by invariant mass. (will be used in PYSTRF).
17035 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)-
17036 & P(N+1,3)*P(N+2,3)
17037 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)-
17038 & P(N+1,3)*P(N+3,3)
17039 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)-
17040 & P(N+2,3)*P(N+3,3)
17041 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
17042 K(N+4,4)=N+3+K(N+4,4)
17043 K(N+4,5)=N+1+MSTU(5)*(N+2)
17044 ELSEIF(PM13.LT.PM23) THEN
17045 K(N+4,4)=N+2+K(N+4,4)
17046 K(N+4,5)=N+1+MSTU(5)*(N+3)
17048 K(N+4,4)=N+1+K(N+4,4)
17049 K(N+4,5)=N+2+MSTU(5)*(N+3)
17055 C...Connect daughters to junction.
17059 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
17061 C...Particle counter should be stepped up one extra for junction.
17065 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
17066 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
17067 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17068 C...Insert junction to keep track of colours.
17069 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17070 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17071 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17082 C...Start by connecting all daughters to junction.
17083 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
17084 C...Only consider colour topologies with off shell resonances.
17085 RMQ1=PMAS(PYCOMP(K(II,2)),1)
17086 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
17087 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
17088 IF (RMGLU-RMQ1.LT.RMRES) THEN
17089 C...Calculate propagators for each colour topology.
17090 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
17091 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
17092 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
17096 CTMSUM=CTMSUM+CTM2(II-N)
17098 CTMSUM=PYR(0)*CTMSUM
17099 C...Select colour topology J, with most off shell least likely.
17102 CTMSUM=CTMSUM-CTM2(J)
17103 IF (CTMSUM.GT.0D0) GOTO 300
17104 C...The lucky winner gets its colour (anti-colour) directly from gluino.
17105 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
17106 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
17107 C...The other gluino colour is connected to junction
17108 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
17110 K(N+4,4)=K(N+4,4)+ID
17111 C...Lastly, connect junction to remaining daughters.
17112 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
17113 C...Particle counter should be stepped up one extra for junction.
17117 C...Update particle counter.
17120 C...2) Everything else two-body decay.
17122 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
17127 C...First set colour flow as if mother colour singlet.
17128 IF(KCQ1(JT).NE.0) THEN
17130 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
17131 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
17133 IF(KCQ2(JT).NE.0) THEN
17135 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
17136 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
17138 C...Then redirect colour flow if mother (anti)triplet.
17139 IF(KCQM(JT).EQ.0) THEN
17140 ELSEIF(KCQM(JT).NE.2) THEN
17142 IF(KCQM(JT).EQ.-1) ISID=5
17144 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
17145 K(ID,ISID)=K(ID,ISID)+IDAU
17146 K(IDAU,ISID)=MSTU(5)*ID
17147 C...Then redirect colour flow if mother octet.
17148 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
17150 IF(KCQ1(JT).EQ.0) IDAU=N
17151 K(ID,4)=K(ID,4)+IDAU
17152 K(ID,5)=K(ID,5)+IDAU
17153 K(IDAU,4)=MSTU(5)*ID
17154 K(IDAU,5)=MSTU(5)*ID
17157 IF(KCQ1(JT).EQ.-1) ISID=5
17158 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
17159 K(ID,ISID)=K(ID,ISID)+(N-1)
17160 K(ID,9-ISID)=K(ID,9-ISID)+N
17161 K(N-1,ISID)=MSTU(5)*ID
17162 K(N,9-ISID)=MSTU(5)*ID
17165 C...Insert junction
17166 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
17168 C...~q* mother: type 3 junction. ~q mother: type 4.
17169 ITJUNC(JT)=(7+KCQM(JT))/2
17170 C...Specify junction KF and set colour flow from junction
17174 C...Junction type encoded together with mother:
17175 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
17176 K(N,5)=N-1+MSTU(5)*(N-2)
17177 C...Zero P and V for junction (V filled later)
17182 C...Set colour flow from mother to junction
17183 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
17184 C...Set colour flow from daughters to junction
17188 C...(Anti-)colour mother is junction.
17189 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
17194 C...End loop over resonances for daughter flavour and mass selection.
17196 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
17198 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
17199 & KFL1(JT).EQ.0) THEN
17200 WRITE(CODE,'(I9)') K(ID,2)
17201 WRITE(MASS,'(F9.3)') P(ID,5)
17202 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
17203 & CODE//' with mass'//MASS)
17209 C...Check for allowed combinations. Skip if no decays.
17210 IF(JTMAX.EQ.1) THEN
17211 IF(KDCY(1).EQ.0) GOTO 710
17212 ELSEIF(JTMAX.EQ.2) THEN
17213 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
17214 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17215 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17216 ELSEIF(JTMAX.EQ.3) THEN
17217 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
17218 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17219 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17220 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17221 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17222 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17223 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17226 C...Special case: matrix element option for Z0 decay to quarks.
17227 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
17228 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
17230 C...Check consistency of MSTJ options set.
17231 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
17233 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
17236 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
17238 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
17243 C...Select alpha_strong behaviour.
17246 MSTU(111)=MSTJ(108)
17247 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
17249 PARU(112)=PARJ(121)
17250 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
17252 C...Find axial fraction in total cross section for scalar gluon model.
17254 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
17255 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
17256 POLL=1D0-PARJ(131)*PARJ(132)
17257 SFF=1D0/(16D0*XW*XW1)
17258 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
17259 & (PARJ(123)*PARJ(124))**2)
17260 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
17262 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
17263 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
17264 & (PARJ(132)-PARJ(131)))
17267 QF=KCHG(KFLC,1)/3D0
17269 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
17270 & 1D0-(2D0*PMQ/P(ID,5))**2))
17271 VF=SIGN(1D0,QF)-4D0*QF*XW
17272 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
17273 & VF**2*HF1W)+VQ**3*HF1W
17274 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
17277 C...Choice of jet configuration.
17278 CALL PYXJET(P(ID,5),NJET,CUT)
17282 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
17283 ELSEIF(NJET.EQ.3) THEN
17284 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
17289 C...Fill jet configuration; return if incorrect kinematics.
17291 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
17292 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
17293 ELSEIF(NJET.EQ.2) THEN
17294 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
17295 ELSEIF(NJET.EQ.3) THEN
17296 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
17297 ELSEIF(KFLN.EQ.21) THEN
17298 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17301 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17304 IF(MSTU(24).NE.0) THEN
17311 C...Angular orientation according to matrix element.
17312 IF(MSTJ(106).EQ.1) THEN
17313 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
17314 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
17316 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
17317 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
17320 C...Boost partons to Z0 rest frame.
17321 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
17322 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17324 C...Mark decayed resonance and add documentation lines,
17326 IDOC=MINT(83)+MINT(4)
17328 I1=MINT(83)+MINT(4)+1
17330 IF(MSTP(128).GE.1) K(I,3)=ID
17331 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
17342 C...Generate parton shower.
17343 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
17344 if(parj(200).ne.1.) CALL PYSHOW(N-1,N,P(ID,5))
17345 if(parj(200).eq.1.) CALL PYSHOWQ(N-1,N,P(ID,5))
17346 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
17350 PTPART(1)=0.5D0*P(ID,5)
17351 PTPART(2)=PTPART(1)
17353 IF(K(N-1,2).GT.0) THEN
17360 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
17363 C... End special case for Z0: skip ahead.
17369 C...Order incoming partons and outgoing resonances.
17370 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
17373 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
17374 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
17375 & ILIN(1)=2*MINT(84)+3-ILIN(1)
17376 ILIN(2)=2*MINT(84)+3-ILIN(1)
17378 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17382 IF(K(IREF(IP,1),2).EQ.23) IORD=2
17383 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
17384 IAKIPD=IABS(K(IREF(IP,IORD),2))
17385 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
17386 IF(KDCY(IORD).EQ.0) IORD=3-IORD
17388 C...Order decay products of resonances.
17389 DO 370 JT=IORD,3-IORD,3-2*IORD
17390 IF(KDCY(JT).EQ.0) THEN
17391 ILIN(IMAX+1)=NSD(JT)
17393 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
17394 ILIN(IMAX+1)=N+2*JT-1
17395 ILIN(IMAX+2)=N+2*JT
17397 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
17398 K(N+2*JT,2)=K(NSD(JT)+2,2)
17400 ILIN(IMAX+1)=N+2*JT
17402 ILIN(IMAX+2)=N+2*JT-1
17404 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
17405 K(N+2*JT,2)=K(NSD(JT)+2,2)
17409 C...Find charge, isospin, left- and righthanded couplings.
17414 KFA=IABS(K(ILIN(I),2))
17415 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
17416 COUP(I,1)=KCHG(KFA,1)/3D0
17417 COUP(I,2)=(-1)**MOD(KFA,2)
17418 COUP(I,4)=-2D0*COUP(I,1)*XWV
17419 COUP(I,3)=COUP(I,2)+COUP(I,4)
17422 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
17423 IF(ISUB.EQ.22) THEN
17426 IF(I.EQ.5) I1=3-IORD
17429 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
17430 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
17431 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
17436 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
17437 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
17438 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
17439 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
17441 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
17445 C...Select angular orientation type - Z'/W' only.
17447 IF(ISUB.EQ.141) THEN
17448 IF(PYR(0).LT.PARU(130)) MZPWP=1
17450 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
17451 IAKIR=IABS(K(IREF(2,2),2))
17452 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
17453 IF(IAKIR.LE.20) MZPWP=2
17455 IF(IP.GE.3) MZPWP=2
17456 ELSEIF(ISUB.EQ.142) THEN
17457 IF(PYR(0).LT.PARU(136)) MZPWP=1
17459 IAKIR=IABS(K(IREF(2,2),2))
17460 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
17461 IF(IAKIR.LE.20) MZPWP=2
17463 IF(IP.GE.3) MZPWP=2
17466 C...Select random angles (begin of weighting procedure).
17467 430 DO 440 JT=1,JTMAX
17468 IF(KDCY(JT).EQ.0) GOTO 440
17469 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
17470 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
17471 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
17474 CTHE(JT)=2D0*PYR(0)-1D0
17475 PHI(JT)=PARU(2)*PYR(0)
17479 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
17480 C...Construct massless four-vectors.
17489 IF(KDCY(JT).EQ.0) GOTO 470
17491 P(N+2*JT-1,3)=0.5D0*P(ID,5)
17492 P(N+2*JT-1,4)=0.5D0*P(ID,5)
17493 P(N+2*JT,3)=-0.5D0*P(ID,5)
17494 P(N+2*JT,4)=0.5D0*P(ID,5)
17495 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
17496 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17499 C...Store incoming and outgoing momenta, with random rotation to
17500 C...avoid accidental zeroes in HA expressions.
17504 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
17505 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
17506 P(N+4+I,5)=P(ILIN(I),5)
17508 P(N+4+I,J)=P(ILIN(I),J)
17511 500 THERR=ACOS(2D0*PYR(0)-1D0)
17512 PHIRR=PARU(2)*PYR(0)
17513 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
17515 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
17516 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
17523 C...Calculate internal products.
17524 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
17525 & ISUB.EQ.142) THEN
17526 DO 540 I1=IMIN,IMAX-1
17527 DO 530 I2=I1+1,IMAX
17528 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
17529 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
17530 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
17531 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
17532 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
17533 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
17534 HC(I1,I2)=CONJG(HA(I1,I2))
17535 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
17536 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
17537 HA(I2,I1)=-HA(I1,I2)
17538 HC(I2,I1)=-HC(I1,I2)
17543 C...Calculate four-products.
17550 DO 580 I1=IMIN,IMAX-1
17551 DO 570 I2=I1+1,IMAX
17552 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
17553 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
17554 PKK(I2,I1)=PKK(I1,I2)
17560 KFAGM=IABS(IREF(IP,7))
17561 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
17562 C...Isotropic decay selected by user.
17566 ELSEIF(JTMAX.EQ.3) THEN
17567 C...Isotropic decay when three mother particles.
17571 ELSEIF(IT4.GE.1) THEN
17572 C... Isotropic decay t -> b + W etc for 4th generation q and l.
17576 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
17577 & IREF(IP,7).EQ.36) THEN
17578 C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
17579 C...CP-odd case added by Kari Ertresvag Myklevoll.
17580 C...Now also with mixed Higgs CP-states
17582 IF(IP.EQ.1) WTMAX=SH**2
17583 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
17584 KFA=IABS(K(IREF(IP,1),2))
17585 KFT=IABS(K(IREF(IP,2),2))
17587 IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
17588 & MSTP(25).GE.3) THEN
17589 C...For mixed CP states need epsilon product.
17606 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
17607 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
17608 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
17609 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
17610 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
17611 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
17612 & P22*P30*P41+P13*P22*P31*P40
17613 C...For mixed CP states need gauge boson masses.
17614 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
17615 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
17616 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
17617 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
17622 IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
17623 KFLF1A=IABS(KFL1(1))
17624 EF1=KCHG(KFLF1A,1)/3D0
17625 AF1=SIGN(1D0,EF1+0.1D0)
17626 VF1=AF1-4D0*EF1*XWV
17627 KFLF2A=IABS(KFL1(2))
17628 EF2=KCHG(KFLF2A,1)/3D0
17629 AF2=SIGN(1D0,EF2+0.1D0)
17630 VF2=AF2-4D0*EF2*XWV
17631 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
17632 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
17635 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
17636 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
17637 ELSEIF(MSTP(25).LE.2) THEN
17639 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
17640 & -2*PKK(3,4)*PKK(5,6)
17641 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
17642 & (PKK(3,4)*PKK(5,6))
17643 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
17644 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
17646 C...Mixed CP states.
17647 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
17648 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
17649 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
17650 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
17651 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
17652 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
17653 & +PKK(3,4)*PKK(5,6)
17654 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
17655 & +VA12AS*PKK(3,4)*PKK(5,6)
17656 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
17657 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
17658 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
17659 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
17663 ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
17664 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
17667 WT=16D0*PKK(3,5)*PKK(4,6)
17668 ELSEIF(MSTP(25).LE.2) THEN
17670 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
17671 & -2*PKK(3,4)*PKK(5,6)
17672 & -2*(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(3,6)-PKK(4,5)-PKK(4,6))*
17675 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
17677 C...Mixed CP states.
17678 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
17679 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
17680 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
17681 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
17682 & +PKK(3,4)*PKK(5,6)
17683 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
17684 & +PKK(3,4)*PKK(5,6)
17685 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
17686 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
17687 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
17688 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
17691 C...No angular correlations in other Higgs decays.
17696 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
17697 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
17699 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
17701 IF(MOD(KFAGM,2).EQ.0) THEN
17709 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
17710 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
17711 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
17712 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
17714 ELSEIF(ISUB.EQ.1) THEN
17715 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
17716 EI=KCHG(IABS(MINT(15)),1)/3D0
17717 AI=SIGN(1D0,EI+0.1D0)
17719 EF=KCHG(IABS(KFL1(1)),1)/3D0
17720 AF=SIGN(1D0,EF+0.1D0)
17723 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
17724 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17725 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
17726 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17727 & (VI**2+AI**2)*VINT(114)*VF**2)
17728 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
17729 & 4D0*VI*AI*VINT(114)*VF*AF)
17730 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
17731 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
17732 WTMAX=2D0*(WT1+ABS(WT3))
17734 ELSEIF(ISUB.EQ.2) THEN
17735 C...Angular weight for W+/- -> 2 quarks/leptons.
17736 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
17737 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
17738 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
17739 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
17742 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
17743 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
17744 C...-> gluon/gamma + 2 quarks/leptons.
17745 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17746 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17747 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
17748 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17749 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17750 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
17751 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17752 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17753 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
17754 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17755 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17756 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
17757 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
17758 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
17759 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
17760 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
17762 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
17763 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
17764 C...-> gluon/gamma + 2 quarks/leptons.
17765 WT=PKK(1,3)**2+PKK(2,4)**2
17766 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
17768 ELSEIF(ISUB.EQ.22) THEN
17769 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
17770 S34=P(IREF(IP,IORD),5)**2
17771 S56=P(IREF(IP,3-IORD),5)**2
17772 TI=PKK(1,3)+PKK(1,4)+S34
17773 UI=PKK(1,5)+PKK(1,6)+S56
17776 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
17777 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
17778 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
17779 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
17780 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
17781 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
17782 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
17783 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
17786 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
17787 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
17788 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
17789 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
17790 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
17791 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
17792 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
17795 ELSEIF(ISUB.EQ.23) THEN
17796 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
17797 D34=P(IREF(IP,IORD),5)**2
17798 D56=P(IREF(IP,3-IORD),5)**2
17799 DT=PKK(1,3)+PKK(1,4)+D34
17800 DU=PKK(1,5)+PKK(1,6)+D56
17801 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
17802 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
17803 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
17804 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
17806 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
17807 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
17808 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
17809 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
17810 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
17811 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
17813 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
17814 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
17815 C...(or H0, or A0).
17816 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
17817 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
17818 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
17819 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
17820 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
17822 ELSEIF(ISUB.EQ.25) THEN
17823 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
17824 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
17825 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
17826 D34=P(IREF(IP,IORD),5)**2
17827 D56=P(IREF(IP,3-IORD),5)**2
17828 DT=PKK(1,3)+PKK(1,4)+D34
17829 DU=PKK(1,5)+PKK(1,6)+D56
17830 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
17831 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
17832 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
17833 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
17834 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
17835 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
17836 & REAL(CBWW)*FGK(1,2,5,6,3,4))
17837 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
17838 IF(MSTP(50).LE.0) THEN
17839 WT=FGK135**2+(CCWW*FGK253)**2
17840 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
17841 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
17844 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
17845 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
17846 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
17847 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
17850 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
17851 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
17852 C...(or H0, or A0).
17853 WT=PKK(1,3)*PKK(2,4)
17854 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
17856 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
17857 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
17858 C...-> f + 2 quarks/leptons.
17859 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17860 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17861 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
17862 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17863 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17864 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
17865 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17866 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17867 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
17868 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17869 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17870 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
17871 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
17872 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
17873 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
17874 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
17875 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
17876 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
17878 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
17879 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
17880 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
17881 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
17882 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
17884 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
17886 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
17887 WT=16D0*PKK(3,5)*PKK(4,6)
17890 ELSEIF(ISUB.EQ.110) THEN
17891 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
17895 ELSEIF(ISUB.EQ.141) THEN
17896 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
17897 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
17898 C...Couplings of incoming flavour.
17899 KFAI=IABS(MINT(15))
17900 EI=KCHG(KFAI,1)/3D0
17901 AI=SIGN(1D0,EI+0.1D0)
17904 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
17905 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
17906 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
17907 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
17908 VPI=PARU(119+2*KFAIC)
17909 API=PARU(120+2*KFAIC)
17910 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
17911 VPI=PARJ(178+2*KFAIC)
17912 API=PARJ(179+2*KFAIC)
17914 VPI=PARJ(186+2*KFAIC)
17915 API=PARJ(187+2*KFAIC)
17917 C...Couplings of final flavour.
17919 EF=KCHG(KFAF,1)/3D0
17920 AF=SIGN(1D0,EF+0.1D0)
17923 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
17924 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
17925 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
17926 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
17927 VPF=PARU(119+2*KFAFC)
17928 APF=PARU(120+2*KFAFC)
17929 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
17930 VPF=PARJ(178+2*KFAFC)
17931 APF=PARJ(179+2*KFAFC)
17933 VPF=PARJ(186+2*KFAFC)
17934 APF=PARJ(187+2*KFAFC)
17936 C...Asymmetry and weight.
17937 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
17938 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
17939 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
17940 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17941 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
17942 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
17943 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
17944 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
17945 WTMAX=2D0+ABS(ASYM)
17946 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
17947 C...Angular weight for f + fbar -> Z' -> W+ + W-.
17948 RM1=P(NSD(1)+1,5)**2/SH
17949 RM2=P(NSD(1)+2,5)**2/SH
17950 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
17951 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17952 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
17954 WT=CFLAT+CCOS2*CTHE(1)**2
17955 WTMAX=CFLAT+MAX(0D0,CCOS2)
17956 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
17957 & IABS(KFL1(1)).EQ.37)) THEN
17958 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
17961 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
17962 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
17963 RM1=P(NSD(1)+1,5)**2/SH
17964 RM2=P(NSD(1)+2,5)**2/SH
17965 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
17966 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
17967 WTMAX=1D0+FLAM2/(8D0*RM1)
17968 ELSEIF(MZPWP.EQ.0) THEN
17969 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
17970 C...(W:s like if intermediate Z).
17971 D34=P(IREF(IP,IORD),5)**2
17972 D56=P(IREF(IP,3-IORD),5)**2
17973 DT=PKK(1,3)+PKK(1,4)+D34
17974 DU=PKK(1,5)+PKK(1,6)+D56
17975 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
17976 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
17977 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
17978 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
17979 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
17980 ELSEIF(MZPWP.EQ.1) THEN
17981 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
17982 C...(W:s approximately longitudinal, like if intermediate H).
17983 WT=16D0*PKK(3,5)*PKK(4,6)
17986 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
17987 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
17992 ELSEIF(ISUB.EQ.142) THEN
17993 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
17994 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
17995 KFAI=IABS(MINT(15))
17997 IF(KFAI.GT.10) KFAIC=2
17998 VI=PARU(129+2*KFAIC)
17999 AI=PARU(130+2*KFAIC)
18002 IF(KFAF.GT.10) KFAFC=2
18003 VF=PARU(129+2*KFAFC)
18004 AF=PARU(130+2*KFAFC)
18005 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
18006 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18007 WTMAX=2D0+ABS(ASYM)
18008 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
18009 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
18010 RM1=P(NSD(1)+1,5)**2/SH
18011 RM2=P(NSD(1)+2,5)**2/SH
18012 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18013 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18014 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18016 WT=CFLAT+CCOS2*CTHE(1)**2
18017 WTMAX=CFLAT+MAX(0D0,CCOS2)
18018 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18019 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
18020 RM1=P(NSD(1)+1,5)**2/SH
18021 RM2=P(NSD(1)+2,5)**2/SH
18022 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18023 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18024 WTMAX=1D0+FLAM2/(8D0*RM1)
18025 ELSEIF(MZPWP.EQ.0) THEN
18026 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18027 C...(W/Z like if intermediate W).
18028 D34=P(IREF(IP,IORD),5)**2
18029 D56=P(IREF(IP,3-IORD),5)**2
18030 DT=PKK(1,3)+PKK(1,4)+D34
18031 DU=PKK(1,5)+PKK(1,6)+D56
18032 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18033 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
18034 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18035 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
18036 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18037 ELSEIF(MZPWP.EQ.1) THEN
18038 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18039 C...(W/Z approximately longitudinal, like if intermediate H).
18040 WT=16D0*PKK(3,5)*PKK(4,6)
18043 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
18044 C...t + bbar -> t + W + bbar.
18049 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
18051 C...Isotropic decay of leptoquarks (assumed spin 0).
18055 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
18056 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
18058 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
18059 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
18060 WT=1D0+SIDE*CTHE(1)
18062 ELSEIF(IP.EQ.1) THEN
18064 RM1=P(NSD(1)+1,5)**2/SH
18065 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18066 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18068 C...W/Z decay assumed isotropic, since not known.
18073 ELSEIF(ISUB.EQ.149) THEN
18074 C...Isotropic decay of techni-eta.
18078 ELSEIF(ISUB.EQ.191) THEN
18079 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18080 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
18081 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
18084 ELSEIF(IP.EQ.1) THEN
18085 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
18086 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18087 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
18088 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18089 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18090 KFAI=IABS(MINT(15))
18091 EI=KCHG(KFAI,1)/3D0
18092 AI=SIGN(1D0,EI+0.1D0)
18096 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
18097 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
18099 EF=KCHG(KFAF,1)/3D0
18100 AF=SIGN(1D0,EF+0.1D0)
18104 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
18105 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
18106 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
18107 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
18108 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
18109 WTMAX=4D0*MAX(ASAME,AFLIP)
18111 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
18116 ELSEIF(ISUB.EQ.192) THEN
18117 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18118 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
18119 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
18122 ELSEIF(IP.EQ.1) THEN
18123 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
18124 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18128 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
18133 ELSEIF(ISUB.EQ.193) THEN
18134 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18135 C...Angular weight for f + fbar -> omega_tc0 ->
18136 C...gamma pi_tc0 or Z0 pi_tc0.
18139 ELSEIF(IP.EQ.1) THEN
18140 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
18141 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18142 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18143 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18144 KFAI=IABS(MINT(15))
18145 EI=KCHG(KFAI,1)/3D0
18146 AI=SIGN(1D0,EI+0.1D0)
18150 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
18151 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
18153 EF=KCHG(KFAF,1)/3D0
18154 AF=SIGN(1D0,EF+0.1D0)
18158 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
18159 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
18160 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
18161 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
18162 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
18163 WTMAX=4D0*MAX(BSAME,BFLIP)
18165 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
18170 ELSEIF(ISUB.EQ.353) THEN
18171 C...Angular weight for Z_R0 -> 2 quarks/leptons.
18172 EI=KCHG(IABS(MINT(15)),1)/3D0
18173 AI=SIGN(1D0,EI+0.1D0)
18175 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
18176 AF=SIGN(1D0,EF+0.1D0)
18178 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
18179 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
18180 WT2=RMF*(VI**2+AI**2)*VF**2
18181 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
18182 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18183 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18184 WTMAX=2D0*(WT1+ABS(WT3))
18186 ELSEIF(ISUB.EQ.354) THEN
18187 C...Angular weight for W_R+/- -> 2 quarks/leptons.
18188 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
18189 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
18190 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18191 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18194 ELSEIF(ISUB.EQ.391) THEN
18195 C...Angular weight for f + fbar -> G* -> f + fbar
18196 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18197 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
18199 C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
18200 C...implemented by M.-C. Lemaire
18201 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18202 & IABS(KFL1(1)).EQ.22)) THEN
18205 C...Other G* decays not yet implemented angular distributions.
18211 ELSEIF(ISUB.EQ.392) THEN
18212 C...Angular weight for g + g -> G* -> f + fbar
18213 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18216 C...Angular weight for g + g -> G* -> gamma +gamma or g + g
18217 C...implemented by M.-C. Lemaire
18218 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18219 & IABS(KFL1(1)).EQ.22)) THEN
18220 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
18222 C...Other G* decays not yet implemented angular distributions.
18228 C...Obtain correct angular distribution by rejection techniques.
18233 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
18235 C...Construct massive four-vectors using angles chosen.
18236 590 DO 690 JT=1,JTMAX
18237 IF(KDCY(JT).EQ.0) GOTO 690
18242 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
18244 IF(KFL3(JT).EQ.0) THEN
18245 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
18246 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18249 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
18250 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18255 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
18257 C...Fill in position of decay vertex.
18258 DO 630 I=NSD(JT)+1,N0
18267 C...Mark decayed resonances; trace history.
18271 IF(KCQM(JT).NE.0) THEN
18272 C...Do not kill colour flow through coloured resonance!
18276 C...If 3-body or 2-body with junction:
18277 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
18278 C...If 3-body with junction:
18279 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
18282 C...Add documentation lines.
18283 ISUBRG=MAX(1,MIN(500,MINT(1)))
18284 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
18285 IDOC=MINT(83)+MINT(4)
18288 IF(KFL3(JT).NE.0) IHI=IHI+1
18289 DO 650 I=NSD(JT)+1,IHI
18291 I1=MINT(83)+MINT(4)+1
18293 IF(MSTP(128).GE.1) K(I,3)=ID
18294 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18298 K(I1,3)=IREF(IP,JT+3)
18307 C...If 3-body or 2-body with junction:
18308 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
18309 C...If 3-body with junction:
18310 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
18313 C...Do showering of two or three objects.
18315 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
18316 IF(KFL3(JT).EQ.0) THEN
18317 if(parj(200).ne.1.) CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
18318 if(parj(200).eq.1.) CALL PYSHOWQ(NSD(JT)+1,NSD(JT)+2,P(ID,5))
18320 if(parj(200).ne.1.) CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
18321 if(parj(200).eq.1.) CALL PYSHOWQ(NSD(JT)+1,-3,P(ID,5))
18324 c...For pT-ordered shower need set up first, especially colour tags.
18325 C...(Need to set up colour tags even if MSTP(71) = 0)
18326 ELSEIF(MINT(35).GE.2) THEN
18328 IF(KFL3(JT).NE.0) NPART=3
18332 PTPART(1)=0.5D0*P(ID,5)
18333 PTPART(2)=PTPART(1)
18334 PTPART(3)=PTPART(1)
18335 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
18336 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
18337 IF(MOTHER.LE.NSD(JT)) THEN
18338 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
18341 MCT(NSD(JT)+1,1)=NCT
18345 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
18346 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
18347 IF(MOTHER.LE.NSD(JT)) THEN
18348 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
18351 MCT(NSD(JT)+1,2)=NCT
18355 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
18356 & KCQ2(JT).EQ.2)) THEN
18357 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
18358 IF(MOTHER.LE.NSD(JT)) THEN
18359 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
18362 MCT(NSD(JT)+2,1)=NCT
18366 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
18367 & KCQ2(JT).EQ.2)) THEN
18368 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
18369 IF(MOTHER.LE.NSD(JT)) THEN
18370 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18373 MCT(NSD(JT)+2,2)=NCT
18377 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
18378 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
18379 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
18380 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
18382 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
18383 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
18384 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
18385 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18387 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
18390 IF(JT.EQ.1) NAFT1=N
18392 C...Check if decay products moved by shower.
18396 IF(NSHAFT.GT.NSHBEF) THEN
18397 IF(K(NSD1,1).GT.10) THEN
18398 DO 660 I=NSHBEF+1,NSHAFT
18399 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
18402 IF(K(NSD2,1).GT.10) THEN
18403 DO 670 I=NSHBEF+1,NSHAFT
18404 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
18405 & I.NE.NSD1) NSD2=I
18408 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
18409 DO 680 I=NSHBEF+1,NSHAFT
18410 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
18411 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
18416 C...Store decay products for further treatment.
18421 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
18425 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
18426 IREF(NP,7)=K(IREF(IP,JT),2)
18427 IREF(NP,8)=IREF(IP,JT)
18431 C...Fill information for 2 -> 1 -> 2.
18432 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
18433 MINT(7)=MINT(83)+6+2*ISET(ISUB)
18434 MINT(8)=MINT(83)+7+2*ISET(ISUB)
18440 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18441 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
18442 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
18443 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
18444 VINT(47)=SQRT(VINT(48))
18447 C...Possibility of colour rearrangement in W+W- events.
18448 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
18449 IAKF1=IABS(KFL1(1))
18450 IAKF2=IABS(KFL1(2))
18451 IAKF3=IABS(KFL2(1))
18452 IAKF4=IABS(KFL2(2))
18453 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
18454 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
18455 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
18456 IF(MINT(51).NE.0) RETURN
18459 C...Loop back if needed.
18460 710 IF(IP.LT.NP) GOTO 170
18462 C...Boost back to standard frame.
18463 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
18469 C*********************************************************************
18472 C...Initializes treatment of multiple interactions, selects kinematics
18473 C...of hardest interaction if low-pT physics included in run, and
18474 C...generates all non-hardest interactions.
18476 SUBROUTINE PYMULT(MMUL)
18478 C...Double precision and integer declarations.
18479 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18480 IMPLICIT INTEGER(I-N)
18481 INTEGER PYK,PYCHGE,PYCOMP
18483 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
18484 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18485 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18486 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
18487 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18488 COMMON/PYINT1/MINT(400),VINT(400)
18489 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
18490 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
18491 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
18492 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
18493 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
18494 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
18495 C...Local arrays and saved variables.
18496 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
18497 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
18498 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
18499 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
18501 C...Initialization of multiple interaction treatment.
18503 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
18511 C...Loop over phase space points: xT2 choice in 20 bins.
18514 NMUL(IXT2)=MSTP(83)
18516 DO 110 ITRY=1,MSTP(83)
18517 RSCA=0.05D0*((21-IXT2)-PYR(0))
18518 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
18519 XT2=MAX(0.01D0*VINT(149),XT2)
18522 C...Choose tau and y*. Calculate cos(theta-hat).
18523 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18524 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18525 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18527 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18533 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18534 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18535 CALL PYKMAP(2,MYST,PYR(0))
18536 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18538 C...Calculate differential cross-section.
18539 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
18540 CALL PYSIGH(NCHN,SIGS)
18541 SIGM(IXT2)=SIGM(IXT2)+SIGS
18543 SIGSUM=SIGSUM+SIGM(IXT2)
18545 SIGSUM=SIGSUM/(20D0*MSTP(83))
18547 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
18548 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
18549 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
18550 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
18551 PARP(82)=0.9D0*PARP(82)
18552 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
18556 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
18557 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
18559 C...Start iteration to find k factor.
18560 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
18561 P83A=(1D0-PARP(83))**2
18562 P83B=2D0*PARP(83)*(1D0-PARP(83))
18564 CQ2I=1D0/PARP(84)**2
18565 CQ2R=2D0/(1D0+PARP(84)**2)
18573 130 IF(IIT.EQ.0) THEN
18575 ELSEIF(IIT.EQ.1) THEN
18578 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
18581 C...Evaluate overlap integrals. Find where to divide the b range.
18582 IF(MSTP(82).EQ.2) THEN
18583 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
18586 IF(MSTP(82).EQ.3) THEN
18588 ELSEIF(MSTP(82).EQ.4) THEN
18589 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
18591 POWIP=MAX(0.4D0,PARP(83))
18592 RPWIP=2D0/POWIP-1D0
18593 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
18603 IF(MSTP(82).EQ.3) THEN
18604 OV=EXP(-B**2)/PARU(2)
18605 ELSEIF(MSTP(82).EQ.4) THEN
18606 OV=(P83A*EXP(-MIN(50D0,B**2))+
18607 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18608 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18610 OV=EXP(-B**POWIP)/PARU(2)
18611 SO=SO+PARU(2)*B*DELTAB*OV
18613 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
18614 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
18615 SP=SP+PARU(2)*B*DELTAB*PACC
18616 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
18617 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
18618 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
18620 BDIV=B+0.5D0*DELTAB
18622 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
18624 YK=PARU(1)*XK*SO/SP
18626 C...Continue iteration until convergence.
18636 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
18638 C...Store some results for subsequent use.
18646 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
18647 PIK=(VNT146/VNT147)*YKE
18649 C...Find relative weight for low and high impact parameter.
18650 PLOWB=PARU(1)*BDIV**2
18651 IF(MSTP(82).EQ.3) THEN
18652 PHIGHB=PIK*0.5*EXP(-BDIV**2)
18653 ELSEIF(MSTP(82).EQ.4) THEN
18654 S4A=P83A*EXP(-BDIV**2)
18655 S4B=P83B*EXP(-BDIV**2*CQ2R)
18656 S4C=P83C*EXP(-BDIV**2*CQ2I)
18657 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
18658 ELSEIF(PARP(83).GE.1.999D0) THEN
18664 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
18668 C...Initialize iteration in xT2 for hardest interaction.
18669 ELSEIF(MMUL.EQ.2) THEN
18673 IF(MSTP(82).LE.0) THEN
18674 ELSEIF(MSTP(82).EQ.1) THEN
18676 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
18677 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
18678 & VINT(317)/(VINT(318)*VINT(320))
18679 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
18680 ELSEIF(MSTP(82).EQ.2) THEN
18682 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
18683 & VINT(149)*(1D0+VINT(149))
18685 XC2=4D0*CKIN(3)**2/VINT(2)
18686 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
18689 C...Select impact parameter for hardest interaction.
18690 IF(MSTP(82).LE.2) RETURN
18691 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
18692 C...Treatment in low b region.
18694 B=BDIV*SQRT(PYR(0))
18695 IF(MSTP(82).EQ.3) THEN
18696 OV=EXP(-B**2)/PARU(2)
18697 ELSEIF(MSTP(82).EQ.4) THEN
18698 OV=(P83A*EXP(-MIN(50D0,B**2))+
18699 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18700 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18702 OV=EXP(-B**POWIP)/PARU(2)
18704 VINT(148)=OV/VNT147
18705 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
18707 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
18708 & VINT(149)*(1D0+VINT(149))
18710 C...Treatment in high b region.
18712 IF(MSTP(82).EQ.3) THEN
18713 B=SQRT(BDIV**2-LOG(PYR(0)))
18714 OV=EXP(-B**2)/PARU(2)
18715 ELSEIF(MSTP(82).EQ.4) THEN
18716 S4RNDM=PYR(0)*(S4A+S4B+S4C)
18717 IF(S4RNDM.LT.S4A) THEN
18718 B=SQRT(BDIV**2-LOG(PYR(0)))
18719 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
18720 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
18722 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
18724 OV=(P83A*EXP(-MIN(50D0,B**2))+
18725 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18726 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18727 ELSEIF(PARP(83).GE.1.999D0) THEN
18728 144 B2RPW=B2RPDV-LOG(PYR(0))
18729 ACCIP=(B2RPW/B2RPDV)**RPWIP
18730 IF(ACCIP.LT.PYR(0)) GOTO 144
18731 OV=EXP(-B2RPW)/PARU(2)
18732 B=B2RPW**(1D0/POWIP)
18734 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
18735 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
18736 IF(ACCIP.LT.PYR(0)) GOTO 146
18737 OV=EXP(-B2RPW)/PARU(2)
18738 B=B2RPW**(1D0/POWIP)
18740 VINT(148)=OV/VNT147
18741 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
18743 IF(PACC.LT.PYR(0)) GOTO 142
18746 ELSEIF(MMUL.EQ.3) THEN
18747 C...Low-pT or multiple interactions (first semihard interaction):
18748 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
18749 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
18754 IF(MSTP(82).LE.0) THEN
18756 ELSEIF(MSTP(82).EQ.1) THEN
18757 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
18758 C...Use with "Sudakov" for low b values when impact parameter dependence.
18759 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
18760 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
18761 & VINT(149)))).GT.PYR(0)) XT2=1D0
18762 IF(XT2.GE.1D0) THEN
18763 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
18764 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
18767 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
18768 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
18771 XT2=MAX(0.01D0*VINT(149),XT2)
18772 C...Use without "Sudakov" for high b values when impact parameter dep.
18774 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
18775 & PYR(0)*(1D0-XC2))-VINT(149)
18776 XT2=MAX(0.01D0*VINT(149),XT2)
18780 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
18781 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
18782 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
18783 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
18786 VINT(21)=0.01D0*VINT(149)
18789 VINT(25)=0.01D0*VINT(149)
18792 C...Multiple interactions (first semihard interaction).
18793 C...Choose tau and y*. Calculate cos(theta-hat).
18794 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18795 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18796 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18798 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18804 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18805 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18806 CALL PYKMAP(2,MYST,PYR(0))
18807 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18809 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
18811 C...Store results of cross-section calculation.
18812 ELSEIF(MMUL.EQ.4) THEN
18818 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
18819 IF(ISET(ISUB).EQ.2)
18820 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
18821 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
18822 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
18823 & (XTS+VINT(149))))
18824 IRBIN=INT(1D0+20D0*RBIN)
18825 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
18826 NMUL(IRBIN)=NMUL(IRBIN)+1
18827 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
18830 C...Choose impact parameter if not already done.
18831 ELSEIF(MMUL.EQ.5) THEN
18836 150 IF(MINT(39).GT.0) THEN
18837 ELSEIF(MSTP(82).EQ.3) THEN
18840 VINT(148)=EXPB2/(PARU(2)*VNT147)
18841 VINT(139)=SQRT(B2)/BAVG
18842 ELSEIF(MSTP(82).EQ.4) THEN
18844 IF(RTYPE.LT.P83A) THEN
18846 ELSEIF(RTYPE.LT.P83A+P83B) THEN
18847 B2=-LOG(PYR(0))/CQ2R
18849 B2=-LOG(PYR(0))/CQ2I
18851 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
18852 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
18853 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
18854 VINT(139)=SQRT(B2)/BAVG
18855 ELSEIF(PARP(83).GE.1.999D0) THEN
18856 POWIP=MAX(2D0,PARP(83))
18857 RPWIP=2D0/POWIP-1D0
18858 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
18859 160 IF(PYR(0).LT.PROB1) THEN
18860 B2RPW=PYR(0)**(0.5D0*POWIP)
18863 B2RPW=1D0-LOG(PYR(0))
18866 IF(ACCIP.LT.PYR(0)) GOTO 160
18867 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
18868 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
18870 POWIP=MAX(0.4D0,PARP(83))
18871 RPWIP=2D0/POWIP-1D0
18872 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
18873 170 IF(PYR(0).LT.PROB1) THEN
18874 B2RPW=2D0*RPWIP*PYR(0)
18875 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
18877 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
18878 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
18880 IF(ACCIP.LT .PYR(0)) GOTO 170
18881 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
18882 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
18885 C...Multiple interactions (variable impact parameter) : reject with
18886 C...probability exp(-overlap*cross-section above pT/normalization).
18887 C...Does not apply to low-b region, where "Sudakov" already included.
18889 IF(MINT(39).NE.1) THEN
18890 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
18891 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
18892 DO 180 IBIN=IRBIN+1,20
18893 RNCOR=RNCOR+NMUL(IBIN)
18894 SIGCOR=SIGCOR+SIGM(IBIN)
18896 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
18897 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
18898 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
18899 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
18901 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
18902 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
18903 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
18904 IF(VINT(150).LT.PYR(0)) GOTO 150
18908 C...Generate additional multiple semihard interactions.
18909 ELSEIF(MMUL.EQ.6) THEN
18922 C...Reconstruct strings in hard scattering.
18924 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
18925 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
18927 DO 210 I=MINT(84)+1,NMAX
18928 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
18929 IF(KCS.EQ.0) GOTO 210
18931 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
18932 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
18934 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
18936 IST=MOD(K(I,J+1),MSTU(5))
18938 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
18939 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
18941 IF(J.EQ.1.OR.J.EQ.4) THEN
18951 C...Set up starting values for iteration in xT2.
18952 XT2=4D0*VINT(62)/VINT(2)
18953 IF(MSTP(82).LE.1) THEN
18954 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
18955 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
18956 & VINT(317)/(VINT(318)*VINT(320))
18957 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
18959 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
18960 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
18964 VINT(143)=1D0-VINT(141)
18965 VINT(144)=1D0-VINT(142)
18967 C...Iterate downwards in xT2.
18968 220 IF(MSTP(82).LE.1) THEN
18969 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
18970 IF(XT2.LT.VINT(149)) GOTO 270
18972 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
18973 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
18974 & LOG(PYR(0)))-VINT(149)
18975 IF(XT2.LE.0D0) GOTO 270
18976 XT2=MAX(0.01D0*VINT(149),XT2)
18980 C...Choose tau and y*. Calculate cos(theta-hat).
18981 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18982 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18983 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18985 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18991 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18992 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18993 CALL PYKMAP(2,MYST,PYR(0))
18994 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18996 C...Check that x not used up. Accept or reject kinematical variables.
18997 X1M=SQRT(TAU)*EXP(VINT(22))
18998 X2M=SQRT(TAU)*EXP(-VINT(22))
18999 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
19000 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19001 CALL PYSIGH(NCHN,SIGS)
19002 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
19003 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
19005 C...Reset K, P and V vectors. Select some variables.
19014 PT=0.5D0*VINT(1)*SQRT(XT2)
19018 C...Add first parton to event record.
19021 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
19022 & 1+INT((2D0+PARJ(2))*PYR(0))
19023 P(N+1,1)=PT*COS(PHI)
19024 P(N+1,2)=PT*SIN(PHI)
19025 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
19026 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
19029 C...Add second parton to event record.
19032 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
19035 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
19036 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
19039 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
19040 C....Choose relevant string pieces to place gluons on.
19046 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
19047 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
19048 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
19049 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
19050 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
19058 C....Colour flow adjustments, new string pieces.
19059 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
19060 & MOD(K(IST1,4),MSTU(5))
19061 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
19062 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
19063 K(I,5)=MSTU(5)*IST1
19064 K(I,4)=MSTU(5)*IST2
19065 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
19066 & MOD(K(IST2,5),MSTU(5))
19067 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
19068 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
19071 KSTR(NSTR+1,2)=IST2
19075 C...String drawing and colour flow for gluon loop.
19076 ELSEIF(K(N+1,2).EQ.21) THEN
19077 K(N+1,4)=MSTU(5)*(N+2)
19078 K(N+1,5)=MSTU(5)*(N+2)
19079 K(N+2,4)=MSTU(5)*(N+1)
19080 K(N+2,5)=MSTU(5)*(N+1)
19087 C...String drawing and colour flow for qqbar pair.
19089 K(N+1,4)=MSTU(5)*(N+2)
19090 K(N+2,5)=MSTU(5)*(N+1)
19096 C...Global statistics.
19097 MINT(351)=MINT(351)+1
19098 VINT(351)=VINT(351)+PT
19099 IF (MINT(351).EQ.1) VINT(356)=PT
19101 C...Update remaining energy; iterate.
19103 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
19104 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
19108 MINT(31)=MINT(31)+1
19109 VINT(151)=VINT(151)+VINT(41)
19110 VINT(152)=VINT(152)+VINT(42)
19111 VINT(143)=VINT(143)-VINT(41)
19112 VINT(144)=VINT(144)-VINT(42)
19113 C...Allow FSR for UE
19114 IF(MSTP(152).EQ.1) then
19115 if(parj(200).ne.1.) CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
19116 if(parj(200).eq.1.) CALL PYSHOWQ(N-1,N,SQRT(PARP(71))*PT)
19118 IF(MINT(31).LT.240) GOTO 220
19126 C...Format statements for printout.
19127 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
19128 &'actions for MSTP(82) =',I2,' ******')
19129 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19130 &D9.2,' mb: rejected')
19131 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19132 &D9.2,' mb: accepted')
19137 C*********************************************************************
19140 C...Adds on target remnants (one or two from each side) and
19141 C...includes primordial kT for hadron beams.
19143 SUBROUTINE PYREMN(IPU1,IPU2)
19145 C...Double precision and integer declarations.
19146 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19147 IMPLICIT INTEGER(I-N)
19148 INTEGER PYK,PYCHGE,PYCOMP
19150 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19151 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19152 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19153 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19154 COMMON/PYINT1/MINT(400),VINT(400)
19155 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19157 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
19158 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
19160 C...Find event type and remaining energy.
19163 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
19164 VINT(143)=1D0-VINT(141)
19165 VINT(144)=1D0-VINT(142)
19168 C...Define initial partons.
19173 IF(JT.EQ.1) IPU=IPU1
19174 IF(JT.EQ.2) IPU=IPU2
19181 IF(MINT(47).EQ.1) THEN
19185 ELSEIF(ISUB.EQ.95) THEN
19190 C...No primordial kT, or chosen according to truncated Gaussian or
19191 C...exponential, or (for photon) predetermined or power law.
19192 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
19193 IF(MSTP(91).LE.0) THEN
19195 ELSEIF(MSTP(91).EQ.1) THEN
19196 PT=PARP(91)*SQRT(-LOG(PYR(0)))
19200 PT=-PARP(92)*LOG(RPT1*RPT2)
19202 IF(PT.GT.PARP(93)) GOTO 120
19203 ELSEIF(MINT(106+JT).EQ.3) THEN
19204 PTA=SQRT(VINT(282+JT))
19206 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
19207 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
19208 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
19211 PTB=-PARP(99)*LOG(RPT1*RPT2)
19213 IF(PTB.GT.PARP(100)) GOTO 120
19214 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
19215 PT=PT*0.8D0**MINT(57)
19216 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
19217 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
19218 IF(MSTP(93).LE.0) THEN
19220 ELSEIF(MSTP(93).EQ.1) THEN
19221 PT=PARP(99)*SQRT(-LOG(PYR(0)))
19222 ELSEIF(MSTP(93).EQ.2) THEN
19225 PT=-PARP(99)*LOG(RPT1*RPT2)
19226 ELSEIF(MSTP(93).EQ.3) THEN
19229 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
19233 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
19234 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
19236 IF(PT.GT.PARP(100)) GOTO 120
19244 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19247 IF(MINT(47).EQ.1) RETURN
19249 C...Kinematics construction for initial partons.
19252 IF(ISUB.EQ.95) THEN
19256 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
19257 & (P(I1,2)+P(I2,2))**2
19258 SHR=SQRT(MAX(0D0,SHS))
19259 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
19260 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
19261 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
19262 P(I2,4)=SHR-P(I1,4)
19265 C...Transform partons to overall CM-frame.
19266 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
19267 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
19268 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
19269 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
19270 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
19271 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
19272 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
19273 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
19274 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
19275 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
19276 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
19279 C...Optionally fix up x and Q2 definitions for leptoproduction.
19281 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
19282 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
19283 IF(IDISXQ.EQ.1) THEN
19285 C...Find where incoming and outgoing leptons/partons are sitting.
19287 IF(MINT(42).EQ.1) LESD=2
19288 LPIN=MINT(83)+3-LESD
19290 LQIN=MINT(84)+3-LESD
19291 LEOUT=MINT(84)+2+LESD
19292 LQOUT=MINT(84)+5-LESD
19293 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
19294 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
19296 DO 140 I=MINT(84)+5,N
19297 IF(K(I,2).EQ.94) THEN
19304 IF(LESD.EQ.1) LQBG=IPU2
19306 C...Calculate actual and wanted momentum transfer.
19309 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
19310 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
19311 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
19312 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
19313 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
19314 P(N+1,1)=FAC*P(LEOUT,1)
19315 P(N+1,2)=FAC*P(LEOUT,2)
19316 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
19317 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
19318 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
19321 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
19322 QNEW(J)=P(LEIN,J)-P(N+1,J)
19325 C...Boost outgoing electron and daughters.
19326 IF(LSCMS.EQ.0) THEN
19328 P(LEOUT,J)=P(N+1,J)
19332 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
19334 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
19336 DBE(J)=PINV*P(N+2,J)
19340 190 IORIG=K(IORIG,3)
19341 IF(IORIG.GT.LEOUT) GOTO 190
19342 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
19343 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
19347 C...Copy shower initiator and all outgoing partons.
19351 P(NCOP,J)=P(LQBG,J)
19353 DO 240 I=MINT(84)+1,N
19355 IF(K(I,1).GT.10) GOTO 240
19356 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
19360 220 IORIG=K(IORIG,3)
19361 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
19363 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
19376 C...Calculate relative rescaling factors.
19380 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
19383 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
19386 C...Transfer extra three-momentum of current.
19389 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
19391 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
19394 C...Iterate change of initiator momentum to get energy right.
19397 PEEX=-P(N+1,4)-QNEW(4)
19398 PEMV=-P(N+1,3)/P(N+1,4)
19401 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
19403 IF(ABS(PEMV).LT.1D-10) THEN
19405 MINT(57)=MINT(57)+1
19409 P(N+1,3)=P(N+1,3)+PZCH
19410 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)
19412 P(I,3)=P(I,3)+V(I,1)*PZCH
19413 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
19415 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
19417 C...Modify momenta in event record.
19418 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
19419 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
19420 IF(ABS(HBE).GE.1D0) THEN
19422 MINT(57)=MINT(57)+1
19426 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
19435 C...Check minimum invariant mass of remnant system(s).
19436 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
19437 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
19438 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
19439 PMIN(0)=SQRT(PMS(0))
19441 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
19442 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
19444 IF(MINT(44+JT).EQ.1) GOTO 340
19445 MINT(105)=MINT(102+JT)
19446 MINT(109)=MINT(106+JT)
19447 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
19448 IF(MINT(51).NE.0) THEN
19449 MINT(57)=MINT(57)+1
19452 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
19453 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
19454 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
19455 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
19456 & P(MINT(83)+JT+2,2)**2)
19458 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
19459 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
19462 MINT(57)=MINT(57)+1
19466 C...Loop over two remnants; skip if none there.
19470 IF(MINT(44+JT).EQ.1) GOTO 410
19471 IF(JT.EQ.1) IPU=IPU1
19472 IF(JT.EQ.2) IPU=IPU2
19474 C...Store first remnant parton.
19486 P(I,5)=PYMASS(K(I,2))
19488 C...First parton colour connections and kinematics.
19489 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
19492 K(I,4)=MSTU(5)*IPU+IPU
19493 K(I,5)=MSTU(5)*IPU+IPU
19494 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
19495 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
19496 ELSEIF(KCOL.NE.0) THEN
19498 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
19500 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
19502 IF(KFLCH(JT).EQ.0) THEN
19503 P(I,1)=-P(MINT(83)+JT+2,1)
19504 P(I,2)=-P(MINT(83)+JT+2,2)
19505 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19506 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
19510 C...When extra remnant parton or hadron: store extra remnant.
19522 P(I,5)=PYMASS(K(I,2))
19524 C...Find parton colour connections of extra remnant.
19525 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
19528 K(I,4)=MSTU(5)*IPU+IPU
19529 K(I,5)=MSTU(5)*IPU+IPU
19530 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
19531 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
19532 ELSEIF(KCOL.NE.0) THEN
19534 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
19536 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
19539 C...Relative transverse momentum when two remnants.
19542 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
19543 IF(IABS(MINT(10+JT)).LT.20) THEN
19547 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
19548 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
19550 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
19551 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
19552 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
19553 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19555 C...Meson or baryon; photon as meson. For splitup below.
19557 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
19559 C***Relative distribution for electron into two electrons. Temporary!
19560 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
19564 C...Relative distribution of electron energy into electron plus parton.
19565 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
19568 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
19570 C...Relative distribution of energy for particle into two jets.
19571 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
19572 CHIK=PARP(92+2*IMB)
19573 IF(MSTP(92).LE.1) THEN
19574 IF(IMB.EQ.1) CHI(JT)=PYR(0)
19575 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
19576 ELSEIF(MSTP(92).EQ.2) THEN
19577 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
19578 ELSEIF(MSTP(92).EQ.3) THEN
19579 CUT=2D0*0.3D0/VINT(1)
19580 380 CHI(JT)=PYR(0)**2
19581 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
19582 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
19583 ELSEIF(MSTP(92).EQ.4) THEN
19584 CUT=2D0*0.3D0/VINT(1)
19585 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
19586 390 CHIR=CUT*CUTR**PYR(0)
19587 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
19588 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
19590 CUT=2D0*0.3D0/VINT(1)
19591 CUTA=CUT**(1D0-PARP(98))
19592 CUTB=(1D0+CUT)**(1D0-PARP(98))
19593 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
19594 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
19595 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
19598 C...Relative distribution of energy for particle into jet plus particle.
19600 IF(MSTP(94).LE.1) THEN
19601 IF(IMB.EQ.1) CHI(JT)=PYR(0)
19602 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
19603 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
19604 ELSEIF(MSTP(94).EQ.2) THEN
19605 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
19606 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
19607 ELSEIF(MSTP(94).EQ.3) THEN
19608 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
19611 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
19616 C...Construct total transverse mass; reject if too large.
19617 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
19618 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
19619 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
19620 IF(LOOP.LT.100) THEN
19624 MINT(57)=MINT(57)+1
19628 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
19629 VINT(158+JT)=CHI(JT)
19631 C...Subdivide longitudinal momentum according to value selected above.
19632 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
19633 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
19634 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
19635 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
19636 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
19641 C...Check if longitudinal boosts needed - if so pick two systems.
19642 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
19643 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
19644 IF(PDEV.LE.1D-6*VINT(1)) RETURN
19645 IF(ISN(1).EQ.0) THEN
19648 ELSEIF(ISN(2).EQ.0) THEN
19651 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
19654 ELSEIF(VINT(143).GT.0.2D0) THEN
19657 ELSEIF(VINT(144).GT.0.2D0) THEN
19660 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
19669 C...E+-pL wanted for system to be modified.
19670 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
19674 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
19675 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
19678 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
19679 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
19680 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
19681 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
19685 DO 450 I=MINT(84)+1,NS
19686 IF(K(I,1).GT.10) GOTO 450
19689 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19691 IF(IORIG.GT.LPIN) GOTO 430
19692 IF(INCL.EQ.0) GOTO 450
19694 PSYS(0,J)=PSYS(0,J)+P(I,J)
19697 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
19698 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
19699 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
19702 C...Construct longitudinal boosts.
19706 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
19707 IF(DSQLAM.LE.1D-6*DPMTB) THEN
19709 MINT(57)=MINT(57)+1
19712 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
19713 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
19714 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
19715 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
19716 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
19717 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
19718 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
19720 C...Perform longitudinal boosts.
19721 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
19723 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
19724 ELSEIF(IR.EQ.1) THEN
19725 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
19726 ELSEIF(IDISXQ.EQ.1) THEN
19730 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19732 IF(IORIG.GT.LPIN) GOTO 460
19733 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
19736 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
19738 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
19740 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
19741 ELSEIF(IL.EQ.2) THEN
19742 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
19743 ELSEIF(IDISXQ.EQ.1) THEN
19747 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19749 IF(IORIG.GT.LPIN) GOTO 480
19750 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
19753 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
19756 C...Final check that energy-momentum conservation worked.
19759 DO 500 I=MINT(84)+1,N
19760 IF(K(I,1).GT.10) GOTO 500
19764 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
19765 IF(PDEV.GT.1D-4*VINT(1)) THEN
19767 MINT(57)=MINT(57)+1
19771 C...Calculate rotation and boost from overall CM frame to
19772 C...hadronic CM frame in leptoproduction.
19774 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
19777 IF(MINT(42).EQ.1) LESD=2
19778 LPIN=MINT(83)+3-LESD
19780 C...Sum upp momenta of everything not lepton or photon to define boost.
19785 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
19786 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
19787 IF(K(I,2).EQ.22) GOTO 530
19789 PSUM(J)=PSUM(J)+P(I,J)
19792 VINT(223)=-PSUM(1)/PSUM(4)
19793 VINT(224)=-PSUM(2)/PSUM(4)
19794 VINT(225)=-PSUM(3)/PSUM(4)
19796 C...Boost incoming hadron to hadronic CM frame to determine rotations.
19802 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
19803 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
19804 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
19806 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
19808 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
19815 C*********************************************************************
19818 C...Initializes treatment of new multiple interactions scenario,
19819 C...selects kinematics of hardest interaction if low-pT physics
19820 C...included in run, and generates all non-hardest interactions.
19822 SUBROUTINE PYMIGN(MMUL)
19824 C...Double precision and integer declarations.
19825 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19826 IMPLICIT INTEGER(I-N)
19827 INTEGER PYK,PYCHGE,PYCOMP
19829 DOUBLE PRECISION PYALPS
19831 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19832 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19833 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19834 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19835 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19836 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19837 COMMON/PYINT1/MINT(400),VINT(400)
19838 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19839 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19840 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19841 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19842 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
19843 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
19844 & XMI(2,240),PT2MI(240),IMISEP(0:240)
19845 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19846 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
19847 C...Local arrays and saved variables.
19848 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
19849 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
19850 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19851 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19852 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19854 C...Initialization of multiple interaction treatment.
19856 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19864 C...Loop over phase space points: xT2 choice in 20 bins.
19867 NMUL(IXT2)=MSTP(83)
19869 DO 110 ITRY=1,MSTP(83)
19870 RSCA=0.05D0*((21-IXT2)-PYR(0))
19871 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19872 XT2=MAX(0.01D0*VINT(149),XT2)
19875 C...Choose tau and y*. Calculate cos(theta-hat).
19876 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19877 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19878 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19880 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19886 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19887 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19888 CALL PYKMAP(2,MYST,PYR(0))
19889 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19891 C...Calculate differential cross-section.
19892 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19893 CALL PYSIGH(NCHN,SIGS)
19894 SIGM(IXT2)=SIGM(IXT2)+SIGS
19896 SIGSUM=SIGSUM+SIGM(IXT2)
19898 SIGSUM=SIGSUM/(20D0*MSTP(83))
19900 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19901 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19902 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19903 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19904 PARP(82)=0.9D0*PARP(82)
19905 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19909 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19910 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19912 C...Start iteration to find k factor.
19913 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19914 P83A=(1D0-PARP(83))**2
19915 P83B=2D0*PARP(83)*(1D0-PARP(83))
19917 CQ2I=1D0/PARP(84)**2
19918 CQ2R=2D0/(1D0+PARP(84)**2)
19926 130 IF(IIT.EQ.0) THEN
19928 ELSEIF(IIT.EQ.1) THEN
19931 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19934 C...Evaluate overlap integrals. Find where to divide the b range.
19935 IF(MSTP(82).EQ.2) THEN
19936 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19939 IF(MSTP(82).EQ.3) THEN
19941 ELSEIF(MSTP(82).EQ.4) THEN
19942 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19944 POWIP=MAX(0.4D0,PARP(83))
19945 RPWIP=2D0/POWIP-1D0
19946 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19956 IF(MSTP(82).EQ.3) THEN
19957 OV=EXP(-B**2)/PARU(2)
19958 ELSEIF(MSTP(82).EQ.4) THEN
19959 OV=(P83A*EXP(-MIN(50D0,B**2))+
19960 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19961 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19963 OV=EXP(-B**POWIP)/PARU(2)
19964 SO=SO+PARU(2)*B*DELTAB*OV
19966 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19967 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19968 SP=SP+PARU(2)*B*DELTAB*PACC
19969 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19970 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19971 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19973 BDIV=B+0.5D0*DELTAB
19975 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19977 YK=PARU(1)*XK*SO/SP
19979 C...Continue iteration until convergence.
19989 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19991 C...Store some results for subsequent use.
19999 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
20000 PIK=(VNT146/VNT147)*YKE
20002 C...Find relative weight for low and high impact parameter..
20003 PLOWB=PARU(1)*BDIV**2
20004 IF(MSTP(82).EQ.3) THEN
20005 PHIGHB=PIK*0.5*EXP(-BDIV**2)
20006 ELSEIF(MSTP(82).EQ.4) THEN
20007 S4A=P83A*EXP(-BDIV**2)
20008 S4B=P83B*EXP(-BDIV**2*CQ2R)
20009 S4C=P83C*EXP(-BDIV**2*CQ2I)
20010 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
20011 ELSEIF(PARP(83).GE.1.999D0) THEN
20017 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
20021 C...Initialize iteration in xT2 for hardest interaction.
20022 ELSEIF(MMUL.EQ.2) THEN
20026 IF(MSTP(82).LE.0) THEN
20027 ELSEIF(MSTP(82).EQ.1) THEN
20029 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20030 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20031 & VINT(317)/(VINT(318)*VINT(320))
20032 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20033 ELSEIF(MSTP(82).EQ.2) THEN
20035 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20036 & VINT(149)*(1D0+VINT(149))
20038 XC2=4D0*CKIN(3)**2/VINT(2)
20039 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
20042 C...Select impact parameter for hardest interaction.
20043 IF(MSTP(82).LE.2) RETURN
20044 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
20045 C...Treatment in low b region.
20047 B=BDIV*SQRT(PYR(0))
20048 IF(MSTP(82).EQ.3) THEN
20049 OV=EXP(-B**2)/PARU(2)
20050 ELSEIF(MSTP(82).EQ.4) THEN
20051 OV=(P83A*EXP(-MIN(50D0,B**2))+
20052 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20053 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20055 OV=EXP(-B**POWIP)/PARU(2)
20057 VINT(148)=OV/VNT147
20058 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
20060 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20061 & VINT(149)*(1D0+VINT(149))
20063 C...Treatment in high b region.
20065 IF(MSTP(82).EQ.3) THEN
20066 B=SQRT(BDIV**2-LOG(PYR(0)))
20067 OV=EXP(-B**2)/PARU(2)
20068 ELSEIF(MSTP(82).EQ.4) THEN
20069 S4RNDM=PYR(0)*(S4A+S4B+S4C)
20070 IF(S4RNDM.LT.S4A) THEN
20071 B=SQRT(BDIV**2-LOG(PYR(0)))
20072 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
20073 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
20075 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
20077 OV=(P83A*EXP(-MIN(50D0,B**2))+
20078 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20079 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20080 ELSEIF(PARP(83).GE.1.999D0) THEN
20081 144 B2RPW=B2RPDV-LOG(PYR(0))
20082 ACCIP=(B2RPW/B2RPDV)**RPWIP
20083 IF(ACCIP.LT.PYR(0)) GOTO 144
20084 OV=EXP(-B2RPW)/PARU(2)
20085 B=B2RPW**(1D0/POWIP)
20087 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
20088 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
20089 IF(ACCIP.LT.PYR(0)) GOTO 146
20090 OV=EXP(-B2RPW)/PARU(2)
20091 B=B2RPW**(1D0/POWIP)
20093 VINT(148)=OV/VNT147
20094 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
20096 IF(PACC.LT.PYR(0)) GOTO 142
20099 ELSEIF(MMUL.EQ.3) THEN
20100 C...Low-pT or multiple interactions (first semihard interaction):
20101 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
20102 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
20107 IF(MSTP(82).LE.0) THEN
20109 ELSEIF(MSTP(82).EQ.1) THEN
20110 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20111 C...Use with "Sudakov" for low b values when impact parameter dependence.
20112 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
20113 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
20114 & VINT(149)))).GT.PYR(0)) XT2=1D0
20115 IF(XT2.GE.1D0) THEN
20116 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
20117 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
20120 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
20121 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
20124 XT2=MAX(0.01D0*VINT(149),XT2)
20125 C...Use without "Sudakov" for high b values when impact parameter dep.
20127 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
20128 & PYR(0)*(1D0-XC2))-VINT(149)
20129 XT2=MAX(0.01D0*VINT(149),XT2)
20133 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
20134 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
20135 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
20136 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
20139 VINT(21)=1D-12*VINT(149)
20142 VINT(25)=1D-12*VINT(149)
20145 C...Multiple interactions (first semihard interaction).
20146 C...Choose tau and y*. Calculate cos(theta-hat).
20147 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20148 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20149 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20151 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20157 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20158 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20159 CALL PYKMAP(2,MYST,PYR(0))
20160 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20162 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
20164 C...Store results of cross-section calculation.
20165 ELSEIF(MMUL.EQ.4) THEN
20171 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
20172 IF(ISET(ISUB).EQ.2)
20173 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20174 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
20175 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
20176 & (XTS+VINT(149))))
20177 IRBIN=INT(1D0+20D0*RBIN)
20178 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
20179 NMUL(IRBIN)=NMUL(IRBIN)+1
20180 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
20183 C...Choose impact parameter if not already done.
20184 ELSEIF(MMUL.EQ.5) THEN
20189 150 IF(MINT(39).GT.0) THEN
20190 ELSEIF(MSTP(82).EQ.3) THEN
20193 VINT(148)=EXPB2/(PARU(2)*VNT147)
20194 VINT(139)=SQRT(B2)/BAVG
20195 ELSEIF(MSTP(82).EQ.4) THEN
20197 IF(RTYPE.LT.P83A) THEN
20199 ELSEIF(RTYPE.LT.P83A+P83B) THEN
20200 B2=-LOG(PYR(0))/CQ2R
20202 B2=-LOG(PYR(0))/CQ2I
20204 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
20205 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
20206 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
20207 VINT(139)=SQRT(B2)/BAVG
20208 ELSEIF(PARP(83).GE.1.999D0) THEN
20209 POWIP=MAX(2D0,PARP(83))
20210 RPWIP=2D0/POWIP-1D0
20211 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
20212 160 IF(PYR(0).LT.PROB1) THEN
20213 B2RPW=PYR(0)**(0.5D0*POWIP)
20216 B2RPW=1D0-LOG(PYR(0))
20219 IF(ACCIP.LT.PYR(0)) GOTO 160
20220 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20221 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20223 POWIP=MAX(0.4D0,PARP(83))
20224 RPWIP=2D0/POWIP-1D0
20225 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
20226 170 IF(PYR(0).LT.PROB1) THEN
20227 B2RPW=2D0*RPWIP*PYR(0)
20228 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
20230 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
20231 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
20233 IF(ACCIP.LT .PYR(0)) GOTO 170
20234 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20235 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20238 C...Multiple interactions (variable impact parameter) : reject with
20239 C...probability exp(-overlap*cross-section above pT/normalization).
20240 C...Does not apply to low-b region, where "Sudakov" already included.
20242 IF(MINT(39).NE.1) THEN
20243 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
20244 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
20245 DO 180 IBIN=IRBIN+1,20
20246 RNCOR=RNCOR+NMUL(IBIN)
20247 SIGCOR=SIGCOR+SIGM(IBIN)
20249 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
20250 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
20251 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
20252 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
20254 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
20255 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
20256 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20257 IF(VINT(150).LT.PYR(0)) GOTO 150
20261 C...Generate additional multiple semihard interactions.
20262 ELSEIF(MMUL.EQ.6) THEN
20264 C...Save data for hardest initeraction, to be restored.
20281 C...Store data on hardest interaction.
20288 C...Change process to generate; sum of x values so far.
20291 VINT(143)=1D0-VINT(141)
20292 VINT(144)=1D0-VINT(142)
20296 C...Initialize factors for PDF reshaping.
20300 KFSBM=ISIGN(1,KFBEAM)
20302 C...Zero flavour content of incoming beam particle.
20306 C...Flavour content of baryon.
20307 IF(KFABM.GT.1000) THEN
20308 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
20309 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
20310 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
20311 C...Flavour content of pi+-, K+-.
20312 ELSEIF(KFABM.EQ.211) THEN
20313 KFIVAL(JS,1)=KFSBM*2
20314 KFIVAL(JS,2)=-KFSBM
20315 ELSEIF(KFABM.EQ.321) THEN
20316 KFIVAL(JS,1)=-KFSBM*3
20317 KFIVAL(JS,2)=KFSBM*2
20318 C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
20321 C...Zero initial valence and companion content.
20326 C...Initiate listing of all incoming partons from two sides.
20328 DO 210 I=MINT(84)+1,N
20329 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
20335 C...Decide whether quarks in hard scattering were valence or sea.
20336 IFL=K(IMI(JS,1,1),2)
20337 IF (IABS(IFL).GT.6) GOTO 230
20339 C...Get PDFs at X and Q2 of the parton shower initiator for the
20340 C...hard scattering.
20342 IF(MSTP(61).GE.1) THEN
20347 C...Note: XPSVC = x*pdf.
20349 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20353 C...Decide (Extra factor x cancels in the division).
20354 RVCS=PYR(0)*(SEA+VAL)
20356 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20357 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20359 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20360 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20361 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20362 IF(KFIVAL(JS,1).EQ.0) THEN
20363 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20364 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20365 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20366 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20368 IF(IVNOW.EQ.0) GOTO 220
20371 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20372 IF(KFIVAL(JS,1).EQ.0) THEN
20373 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20376 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
20378 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
20379 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
20383 C...If sea, add opposite sign companion parton. Store X and I.
20385 NVC(JS,-IFL)=NVC(JS,-IFL)+1
20386 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
20387 C...Set pointer to companion
20388 IMI(JS,1,2)=-NVC(JS,-IFL)
20392 C...Update counter number of multiple interactions.
20396 C...Set up starting values for iteration in xT2.
20397 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
20398 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
20399 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
20400 & ISUBSV.NE.96)) THEN
20401 XT2=(1D0-VINT(141))*(1D0-VINT(142))
20404 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
20405 IF(ISET(ISUBSV).EQ.2)
20406 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20407 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
20409 IF(MSTP(82).LE.1) THEN
20410 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20411 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20412 & VINT(317)/(VINT(318)*VINT(320))
20413 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20415 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
20416 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
20421 C...Iterate downwards in xT2.
20422 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
20425 ELSEIF(MSTP(82).LE.1) THEN
20426 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20427 IF(XT2.LT.VINT(149)) GOTO 440
20429 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
20430 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
20431 & LOG(PYR(0)))-VINT(149)
20432 IF(XT2.LE.0D0) GOTO 440
20433 XT2=MAX(0.01D0*VINT(149),XT2)
20437 C...Choose tau and y*. Calculate cos(theta-hat).
20438 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20439 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20440 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20442 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20445 C...New: require shat > 1.
20446 IF(TAU*VINT(2).LT.1D0) GOTO 240
20450 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20451 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20452 CALL PYKMAP(2,MYST,PYR(0))
20453 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20455 C...Check that x not used up. Accept or reject kinematical variables.
20456 X1M=SQRT(TAU)*EXP(VINT(22))
20457 X2M=SQRT(TAU)*EXP(-VINT(22))
20458 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
20459 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20460 CALL PYSIGH(NCHN,SIGS)
20461 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
20462 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
20463 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
20465 C...Reset K, P and V vectors.
20473 PT=0.5D0*VINT(1)*SQRT(XT2)
20475 C...Choose flavour of reacting partons (and subprocess).
20480 ICONMI=ISIG(ICHN,3)
20481 RSIGS=RSIGS-SIGH(ICHN)
20482 IF(RSIGS.LE.0D0) GOTO 280
20485 C...Reassign to appropriate process codes.
20486 280 ISUBMI=ICONMI/10
20487 ICONMI=MOD(ICONMI,10)
20489 C...Choose new quark flavour for annihilation graphs
20490 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
20492 CALL PYWIDT(21,SH,WDTP,WDTE)
20493 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
20494 DO 300 I=1,MDCY(21,3)
20495 KFLF=KFDP(I+MDCY(21,2)-1,1)
20496 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
20497 IF(RKFL.LE.0D0) GOTO 310
20499 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
20500 IF(KFLF.GE.4) GOTO 290
20501 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
20504 ELSEIF(ISUBMI.EQ.53) THEN
20510 C...Final state flavours and colour flow: default values
20517 IF(ISUBMI.EQ.11) THEN
20518 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
20520 IF(KFL1*KFL2.LT.0) KCC=KCC+2
20522 ELSEIF(ISUBMI.EQ.12) THEN
20523 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
20524 KFL3=ISIGN(KFLF,KFL1)
20528 ELSEIF(ISUBMI.EQ.13) THEN
20529 C...f + fbar -> g + g; th arbitrary
20534 ELSEIF(ISUBMI.EQ.28) THEN
20535 C...f + g -> f + g; th = (p(f)-p(f))**2
20536 IF(KFL1.EQ.21) JS=2
20538 IF(KFL1.EQ.21) KCC=KCC+2
20539 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
20540 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
20542 ELSEIF(ISUBMI.EQ.53) THEN
20543 C...g + g -> f + fbar; th arbitrary
20544 KCS=(-1)**INT(1.5D0+PYR(0))
20545 KFL3=ISIGN(KFLF,KCS)
20549 ELSEIF(ISUBMI.EQ.68) THEN
20550 C...g + g -> g + g; th arbitrary
20552 KCS=(-1)**INT(1.5D0+PYR(0))
20555 C...Store flavours of scattering.
20563 C...Set flavours and mothers of scattering partons.
20572 K(N+1,3)=MINT(83)+1
20573 K(N+2,3)=MINT(83)+2
20577 C...Store colour connection indices.
20580 IF(KCS.EQ.-1) JC=3-J
20581 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
20582 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
20583 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
20584 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
20587 C...Store incoming and outgoing partons in their CM-frame.
20588 SHR=SQRT(TAU)*VINT(1)
20591 P(N+2,3)=-0.5D0*SHR
20593 P(N+3,5)=PYMASS(K(N+3,2))
20594 P(N+4,5)=PYMASS(K(N+4,2))
20595 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
20596 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
20597 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
20598 P(N+4,4)=SHR-P(N+3,4)
20601 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
20603 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
20605 C...Set up default values before showers.
20606 MINT(31)=MINT(31)+1
20615 C...Showering of initial state partons (optional).
20616 C...Note: no showering of final state partons here; it comes later.
20617 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
20624 KSAV(I,J)=K(N-4+I,J)
20625 PSAV(I,J)=P(N-4+I,J)
20628 CALL PYSSPA(IPU1,IPU2)
20630 C...If shower failed then restore to situation before shower.
20631 IF(MINT(51).GE.1) THEN
20635 K(N-4+I,J)=KSAV(I,J)
20636 P(N-4+I,J)=PSAV(I,J)
20646 C...Keep track of loose colour ends and information on scattering.
20647 370 IMI(1,MINT(31),1)=IPU1
20648 IMI(2,MINT(31),1)=IPU2
20649 IMI(1,MINT(31),2)=0
20650 IMI(2,MINT(31),2)=0
20651 XMI(1,MINT(31))=VINT(141)
20652 XMI(2,MINT(31))=VINT(142)
20653 PT2MI(MINT(31))=VINT(54)
20656 C...Decide whether quarks in last scattering were valence, companion or
20660 KFSBM=ISIGN(1,MINT(10+JS))
20661 IFL=K(IMI(JS,MINT(31),1),2)
20662 IMI(JS,MINT(31),2)=0
20663 IF (IABS(IFL).GT.6) GOTO 430
20665 C...Get PDFs at X and Q2 of the parton shower initiator for the
20666 C...last scattering. At this point VINT(143:144) do not yet
20667 C...include the scattered x values VINT(141:142).
20668 X=VINT(140+JS)/VINT(142+JS)
20669 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
20674 C...Note: XPSVC = x*pdf.
20676 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20680 DO 380 IVC=1,NVC(JS,IFL)
20681 CMP=CMP+XPSVC(IFL,IVC)
20684 C...Decide (Extra factor x cancels in the dvision).
20685 RVCS=PYR(0)*(SEA+VAL+CMP)
20687 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20688 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20690 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20691 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20692 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20693 IF(KFIVAL(JS,1).EQ.0) THEN
20694 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20695 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20696 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20697 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20699 DO 400 I1=1,NMI(JS)
20700 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
20704 IF(IVNOW.EQ.0) GOTO 390
20706 IMI(JS,MINT(31),2)=0
20707 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20708 IF(KFIVAL(JS,1).EQ.0) THEN
20709 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20712 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
20714 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
20715 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
20719 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
20720 C...If sea, add opposite sign companion parton. Store X and I.
20721 NVC(JS,-IFL)=NVC(JS,-IFL)+1
20722 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
20723 C...Set pointer to companion
20724 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
20726 C...If companion, decide which one.
20730 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
20731 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
20732 C...Find original sea (anti-)quark:
20734 DO 420 I1=1,NMI(JS)
20735 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
20736 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
20737 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
20738 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
20741 C...Change X to what associated companion had, so that the correct
20742 C...amount of momentum can be subtracted from the companion sum below.
20743 X=XASSOC(JS,IFL,ISEL)
20744 C...Mark companion read.
20745 XASSOC(JS,IFL,ISEL)=0D0
20749 C...Global statistics.
20750 MINT(351)=MINT(351)+1
20751 VINT(351)=VINT(351)+PT
20752 IF (MINT(351).EQ.1) VINT(356)=PT
20754 C...Update remaining energy and other counters.
20755 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
20756 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
20762 VINT(151)=VINT(151)+VINT(41)
20763 VINT(152)=VINT(152)+VINT(42)
20764 VINT(143)=VINT(143)-VINT(141)
20765 VINT(144)=VINT(144)-VINT(142)
20767 C...Iterate, with more interactions allowed.
20768 IF(MINT(31).LT.240) GOTO 240
20771 C...Restore saved quantities for hardest interaction.
20787 C...Format statements for printout.
20788 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
20789 &'actions for MSTP(82) =',I2,' ******')
20790 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20791 &D9.2,' mb: rejected')
20792 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20793 &D9.2,' mb: accepted')
20798 C*********************************************************************
20801 C...Finds left-behind remnant flavour content and hooks up
20802 C...the colour flow between the hard scattering and remnants
20806 C...Double precision and integer declarations.
20807 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20808 IMPLICIT INTEGER(I-N)
20809 INTEGER PYK,PYCHGE,PYCOMP
20810 C...The event record
20811 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20813 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20814 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20815 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20816 COMMON/PYINT1/MINT(400),VINT(400)
20817 C...The common block of dangling ends
20818 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20819 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20820 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20821 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
20822 C...Local variables
20823 PARAMETER (NERSIZ=4000)
20824 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
20826 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
20827 SAVE /PYCBLS/,/PYCTAG/
20828 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
20829 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
20832 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)
20834 C...Set up error checkers
20837 C...Initialize colour arrays: MCO (Original) and MCT (New)
20838 DO 110 I=MINT(84)+1,NERSIZ
20843 C...Also zero colour tracing information, if existed.
20845 K(I,4)=MOD(K(I,4),MSTU(5)**2)
20846 K(I,5)=MOD(K(I,5),MSTU(5)**2)
20850 C...Initialize colour tag collapse arrays:
20851 C...JCCO (Original) and JCCN (New).
20852 DO 130 MG=MINT(84)+1,NERSIZ
20859 C...Zero gluon insertion array
20866 C...Compute hard scattering system rapidities
20867 IF (MSTP(89).EQ.1) THEN
20869 IF (IM.LE.MINT(31)) THEN
20870 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
20872 C...Set (unsigned) rapidity = 100 for beam remnant systems.
20878 C...Treat each side separately
20881 C...Initialize side.
20884 KFS=ISIGN(1,MINT(10+JS))
20886 C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
20887 IF(KFIVAL(JS,1).EQ.0) THEN
20888 IF(MINT(10+JS).EQ.111) THEN
20889 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
20890 KFIVAL(JS,2)=-KFIVAL(JS,1)
20891 ELSEIF(MINT(10+JS).EQ.22) THEN
20894 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
20895 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
20896 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
20897 KFIVAL(JS,2)=-KFIVAL(JS,1)
20898 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
20899 IF(PYR(0).GT.0.5D0) THEN
20909 C...Initialize beam remnant sea and valence content flavour by flavour.
20913 C...Count up original number of JFA valence quarks and antiquarks.
20918 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
20919 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
20921 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
20922 C...Subtract kicked out valence and determine sea from flavour cons.
20923 DO 180 IM=1,NMI(JS)
20924 IFL = K(IMI(JS,IM,1),2)
20927 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
20928 C...Subtract K.O. valence quark from remainder.
20930 JV=NVSUM(JS)-NVALQ-NVALQB
20931 IV(JS,JV)=IMI(JS,IM,1)
20932 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
20933 C...Subtract K.O. valence antiquark from remainder.
20935 JV=NVSUM(JS)-NVALQ-NVALQB
20936 IV(JS,JV)=IMI(JS,IM,1)
20937 ELSEIF (IFA.EQ.JFA) THEN
20938 C...Outside sea without companion: add opposite sea flavour inside.
20939 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
20942 C...Check if space left in PYJETS for additional BR flavours
20943 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
20944 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
20945 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
20946 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
20950 C...Add required val+sea content to beam remnant.
20951 IF (NFLSUM.GT.0) THEN
20953 C...Insert beam remnant quark as p.t. symbolic parton in ER.
20961 K(N,2)=ISIGN(JFA,NSEA)
20962 IF (IA.LE.NVALQ) K(N,2)=JFA
20963 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
20965 C...Also update NMI, IMI, and IV arrays.
20967 IMI(JS,NMI(JS),1)=N
20968 IMI(JS,NMI(JS),2)=-1
20969 IF (IA.LE.NVALQ+NVALQB) THEN
20970 IMI(JS,NMI(JS),2)=0
20972 IV(JS,JV)=IMI(JS,NMI(JS),1)
20980 IF (IM.LE.NMI(JS)) THEN
20981 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
20983 C...Add fictitious parent gluons for companion pairs.
20984 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
20985 C...Randomly assign companions to sea quarks which have none.
20986 IF (IMI(JS,IM,2).LT.0) THEN
20988 230 IMC=MOD(IMC,NMI(JS))+1
20989 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
20990 IF (IMI(JS,IMC,2).GE.0) GOTO 230
20991 IMI(JS, IM,2) = IMI(JS,IMC,1)
20992 IMI(JS,IMC,2) = IMI(JS, IM,1)
20994 C...Add fictitious parent gluon
21004 C...Set gluon (anti-)colour daughter pointers
21005 K(N,4)=IMI(JS, IM,1)
21006 K(N,5)=IMI(JS, IM,2)
21007 C...Set quark (anti-)colour parent pointers
21008 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
21009 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
21010 C...Add gluon to IMI
21012 IMI(JS,NMI(JS),1)=N
21013 IMI(JS,NMI(JS),2)=0
21018 C...If incoming (anti-)baryon, insert inside (anti-)junction.
21019 C...Set up initial v-v-j-v configuration. Otherwise set up
21020 C...mesonic v-vbar configuration
21021 IF (IABS(MINT(10+JS)).GT.1000) THEN
21022 C...Determine junction type (1: B=1 2: B=-1)
21023 ITJUNC(JS) = (3-KFS)/2
21024 C...Insert junction.
21031 C...Set special junction codes:
21034 C...Set parent to side.
21036 K(N,4)=ITJUNC(JS)*MSTU(5)
21038 C...Connect valence quarks to junction.
21041 C...Set (anti)colour mother = junction.
21043 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21045 C...Keep track of partons adjacent to junction:
21046 JST(JS,JV)=IV(JS,JV)
21049 C...Mesons: set up initial q-qbar topology
21051 IF (K(IV(JS,1),2).GT.0) THEN
21062 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21063 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21064 C...Special for mesons. Insert gluon if BR empty.
21065 IF (NBRTOT(JS).EQ.0) THEN
21079 C...Add gluon to IMI
21081 IMI(JS,NMI(JS),1)=N
21082 IMI(JS,NMI(JS),2)=0
21087 C...Count up number of valence quarks outside BR.
21089 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
21090 & MOUT(JS)=MOUT(JS)+1
21095 C...Now both sides have been prepared in an initial vvjv (baryonic) or
21096 C...v(g)vbar (mesonic) configuration.
21098 C...Create colour line tags starting from initiators.
21100 DO 320 IM=1,MINT(31)
21101 C...Consider each side in turn.
21106 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
21108 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
21111 CALL PYCTTR(I1,KCS,I2)
21112 IF(MINT(51).NE.0) RETURN
21119 C...Create colour tags for beam remnant partons.
21120 DO 330 IM=MINT(31)+1,NMI(JS)
21122 IF (K(IP,2).NE.21) THEN
21123 JC=(3-ISIGN(1,K(IP,2)))/2
21124 IF (MCT(IP,JC).EQ.0) THEN
21133 C...Fictituous gluons just inherit from their quark daughters.
21137 C...Real beam remnant gluons get their own colours
21148 C...Create colour tags for colour lines which are detached from the
21152 DO 350 I=MINT(84)+1,N
21154 C...Look for coloured string endpoint, or (later) leftover gluon.
21155 IF (K(I,1).NE.3) GOTO 350
21157 IF(KC.EQ.0) GOTO 350
21159 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
21161 C...Pick up loose string end with no previous tag.
21163 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
21164 IF(MCT(I,KCS-3).NE.0) GOTO 350
21166 CALL PYCTTR(I,KCS,I)
21167 IF(MINT(51).NE.0) RETURN
21172 C...Store original colour tags
21173 DO 370 I=MINT(84)+1,N
21178 C...Iteratively add gluons to already existing string pieces, enforcing
21179 C...various possible orderings, and rejecting insertions that would give
21180 C...rise to singlet gluons.
21181 C...<kappa tau> normalization.
21186 C...Set up simplified kinematics.
21187 C...Boost hard interaction systems.
21189 DO 380 IM=1,MINT(31)
21190 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21191 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21193 C...Assign preliminary beam remnant momenta.
21194 DO 390 I=MINT(53)+1,N
21198 IF (K(I,2).NE.88) THEN
21199 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
21201 IF (JS.EQ.2) P(I,3)=-P(I,3)
21203 C...Junctions are wildcards for the present.
21209 C...Reset colour processing information.
21210 400 DO 410 I=MINT(84)+1,N
21211 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21212 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21217 C...If meson, without gluon in BR, collapse q-qbar colour tags:
21218 IF (ITJUNC(JS).EQ.0) THEN
21219 JC1=MCT(JST(JS,1),1)
21220 JC2=MCT(JST(JS,2),2)
21222 JCCO(NCC,1)=MAX(JC1,JC2)
21223 JCCO(NCC,2)=MIN(JC1,JC2)
21224 C...Collapse colour tags in event record
21225 DO 420 I=MINT(84)+1,N
21226 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
21227 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
21233 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
21234 IF (NG(JS).GT.0) THEN
21237 C...Start at random gluon (optimizes speed for random attachments)
21239 IMGL=PYR(0)*NMI(JS)+1
21240 450 IMGL=MOD(IMGL,NMI(JS))+1
21242 C...Only loop through NMI once (with upper limit to save time)
21243 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
21244 IGL = IMI(JS,IMGL,1)
21245 C...If not gluon or if already connected, try next.
21246 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
21247 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
21248 C...Now loop through all possible insertions of this gluon.
21250 IMP1=PYR(0)*NMI(JS)+1
21251 460 IMP1=MOD(IMP1,NMI(JS))+1
21253 IF (IMP1.EQ.IMGL) GOTO 460
21254 C...Only loop through NMI once (with upper limit to save time).
21255 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
21256 IP1 = IMI(JS,IMP1,1)
21257 C...Try both colour mother and colour anti-mother.
21258 C...Randomly select which one to try first.
21261 470 MANTI=MOD(MANTI+1,2)
21263 IF (NANTI.LE.2) THEN
21264 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
21265 C...Reject if no appropriate mother (or if mother is fictitious
21267 IF (IP2.LE.0) GOTO 470
21268 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
21269 C...Also reject if this link has already been tried.
21270 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21271 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21272 C...Set flag to indicate that this link has now been tried for this
21273 C...gluon. IP2 may be junction, which has several mothers.
21274 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
21275 IF (K(IP2,2).NE.88) THEN
21276 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
21279 C...JCG1: Original colour tag of gluon on IP1 side
21280 C...JCG2: Original colour tag of gluon on IP2 side
21281 C...JCP1: Original colour tag of IP1 on gluon side
21282 C...JCP2: Original colour tag of IP2 on gluon side.
21283 JCG1=MCO(IGL,2-MANTI)
21284 JCG2=MCO(IGL,1+MANTI)
21285 JCP1=MCO(IP1,1+MANTI)
21286 JCP2=MCO(IP2,2-MANTI)
21288 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
21289 C...Reject gluon attachments that give rise to singlet gluons.
21290 IF (MACCPT.EQ.0) GOTO 470
21293 JCG1=MCT(IGL,2-MANTI)
21294 JCG2=MCT(IGL,1+MANTI)
21295 JCP1=MCT(IP1,1+MANTI)
21296 JCP2=MCT(IP2,2-MANTI)
21298 C...Select whether to accept this insertion
21299 IF (MSTP(89).EQ.0) THEN
21300 C...Random insertions: no measure.
21302 C...For random ordering, we want to suppress beam remnant breakups
21303 C...already at this point.
21304 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
21305 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
21310 ELSEIF (MSTP(89).EQ.1) THEN
21311 C...Rapidity ordering:
21312 C...YGL = Rapidity of gluon.
21314 C...If fictitious gluon
21315 IF (YGL.EQ.100D0) THEN
21317 IDA1=MOD(K(IGL,4),MSTU(5))
21318 IDA2=MOD(K(IGL,5),MSTU(5))
21319 DO 480 IMT=1,NMI(JS)
21320 C...Select (arbitrarily) the most central daughter.
21321 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21323 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
21327 C...YP1 = Rapidity IP1
21329 C...If fictitious gluon
21330 IF (YP1.EQ.100D0) THEN
21332 IDA1=MOD(K(IP1,4),MSTU(5))
21333 IDA2=MOD(K(IP1,5),MSTU(5))
21334 DO 490 IMT=1,NMI(JS)
21335 C...Select (arbitrarily) the most central daughter.
21336 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21338 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
21342 C...YP2 = Rapidity of mother system
21343 IF (K(IP2,2).NE.88) THEN
21344 DO 500 IMT=1,NMI(JS)
21345 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
21347 C...If fictitious gluon
21348 IF (YP2.EQ.100D0) THEN
21350 IDA1=MOD(K(IP2,4),MSTU(5))
21351 IDA2=MOD(K(IP2,5),MSTU(5))
21352 DO 510 IMT=1,NMI(JS)
21353 C...Select (arbitrarily) the most central daughter.
21354 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
21356 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
21360 C...Assign (arbitrarily) 100D0 to junction also
21364 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
21365 ELSEIF (MSTP(89).EQ.2) THEN
21366 C...Lambda ordering:
21367 C...Compute lambda measure for this insertion.
21372 C...If IP2 is junction, not caught below.
21373 IF (JCP2.EQ.0) THEN
21374 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
21375 C...Anti-junction is colour endpoint et vv., always on JCG2.
21378 DO 530 I=MINT(84)+1,N
21379 IF (K(I,1).LT.10) THEN
21380 C...The new string pieces
21381 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
21382 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
21383 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
21384 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
21387 C...Also identify junctions as string endpoints.
21388 DO 540 I=MINT(84)+1,N
21389 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
21390 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
21391 C...Find partons adjacent to junctions.
21392 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
21393 & .EQ.0) ISTR(2) = ICMO
21394 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
21395 & .EQ.0) ISTR(1) = IAMO
21396 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
21397 & .EQ.0) ISTR(4) = ICMO
21398 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
21399 & .EQ.0) ISTR(3) = IAMO
21401 C...The old string piece
21402 ISTR(5)=ISTR(1+2*MANTI)
21403 ISTR(6)=ISTR(4-2*MANTI)
21404 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
21405 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
21408 C...Allow some breadth to speed things up.
21409 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
21411 ELSEIF (RL.GT.RLOPT) THEN
21417 C...INSR(NOPT,1)=Gluon colour mother
21418 C...INSR(NOPT,2)=Gluon
21419 C...INSR(NOPT,3)=Gluon anticolour mother
21420 IF (NOPT.GT.1000) GOTO 470
21421 INSR(NOPT,1+2*MANTI)=IP2
21423 INSR(NOPT,3-2*MANTI)=IP1
21424 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
21426 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
21428 C...Reset link test information.
21429 DO 550 I=MINT(84)+1,N
21430 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21431 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21433 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
21435 C...Now we have a list of best gluon insertions, none of which cause
21436 C...singlets to arise. If list is empty, try again a few times. Note:
21437 C...this should never happen if we have a meson with a gluon inserted
21438 C...in the beam remnant, since that breaks up the colour line.
21439 IF (NOPT.EQ.0) THEN
21440 C...Abandon BR-g-BR suppression for retries. This is not serious, it
21441 C...just means we happened to start with trying a bad sequence.
21443 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
21444 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
21447 IF (ITJUNC(JS).NE.0) THEN
21451 C...Reset valence quark parent pointers
21452 DO 560 I=MINT(53)+1,N
21453 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
21456 C...Set (anti)colour mother = junction.
21458 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21462 C...Same for mesons. JST unchanged, so needn't be restored.
21465 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21466 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21468 C...Also reset gluon parent pointers.
21470 DO 580 IM=1,NMI(JS)
21472 IF (K(I,2).EQ.21) THEN
21473 K(I,4)=MOD(K(I,4),MSTU(5))
21474 K(I,5)=MOD(K(I,5),MSTU(5))
21479 C...Reset colour tags
21480 DO 600 I=MINT(84)+1,N
21486 IF(NERRPR.LT.5) THEN
21489 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
21490 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
21492 C...Kill event and start another.
21497 C...Select between insertions, suppressing insertions wholly in the BR.
21499 610 IIN=MOD(IIN,NOPT)+1
21500 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
21501 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
21504 C...Now we know which gluon to insert where. Colour tags in JCCO and
21505 C...colour connection information should be updated, NG(JS) should be
21506 C...counted down, and a new loop performed if there are still gluons
21507 C...left on any side.
21511 C...JCG : Original gluon colour tag
21512 C...JCAG: Original gluon anticolour tag.
21513 C...JCM : Original anticolour tag of gluon colour mother
21514 C...JACM: Original colour tag of gluon anticolour mother
21520 CALL PYMIHG(JACM,JACG,JCM,JCG)
21521 IF (MACCPT.EQ.0) THEN
21522 IF(NERRPR.LT.5) THEN
21525 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
21526 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
21528 C...Kill event and start another.
21532 C...If everything went fine, store new JCCN in JCCO.
21535 JCCO(ICC,1)=JCCN(ICC,1)
21536 JCCO(ICC,2)=JCCN(ICC,2)
21540 C...One gluon attached is counted as equivalent to one end outside.
21542 C...Set IGL colour mother = ICM.
21543 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
21544 C...Set ICM anticolour mother = IGL colour.
21545 IF (K(ICM,2).NE.88) THEN
21546 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
21548 C...If ICM is junction, just update JST array for now.
21550 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
21553 C...Set IGL anticolour mother = IACM.
21554 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
21555 C...Set IACM anticolour mother = IGL anticolour.
21556 IF (K(IACM,2).NE.88) THEN
21557 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
21559 C...If IACM is junction, just update JST array for now.
21561 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
21564 C...Count down # unconnected gluons.
21567 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
21570 C...Collapse fictitious gluons.
21571 DO 670 IGL=MINT(53)+1,N
21572 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
21573 & K(IGL,1).EQ.14) THEN
21574 ICM=K(IGL,4)/MSTU(5)
21575 IAM=K(IGL,5)/MSTU(5)
21576 ICD=MOD(K(IGL,4),MSTU(5))
21577 IAD=MOD(K(IGL,5),MSTU(5))
21578 C...Set gluon daughters pointing to gluon mothers
21579 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
21580 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
21581 C...Set gluon mothers pointing to gluon daughters.
21582 IF (K(ICM,2).NE.88) THEN
21583 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
21585 C...Special case: mother=junction. Just update JST array for now.
21587 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
21590 IF (K(IAM,2).NE.88) THEN
21591 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
21594 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
21600 C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
21603 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
21604 IF (IM.GT.MINT(31)) THEN
21606 DO 690 IMR=IM,NMI(JS)
21607 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
21608 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
21613 C...Finally, connect junction.
21614 IF (ITJUNC(JS).NE.0) THEN
21615 DO 700 I=MINT(53)+1,N
21616 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
21618 C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
21623 C...Find jq with no glue inbetween inside beam remnant.
21624 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
21627 C...Set IDQ = -I if q non-valence and = +I if q valence.
21628 IDQ(NBRJQ)=-JST(JS,MSJ)
21630 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
21631 IDQ(NBRJQ)=JST(JS,MSJ)
21638 IF (MSJ.EQ.3) I45=4
21639 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
21642 C...Check if diquark can be formed.
21643 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
21645 C...If there is less than 2 valence quarks connected to junction
21646 C...and MSTP(88)>1, use random non-valence quarks to fill up.
21647 IF (NBRVQ.LE.1) THEN
21649 730 JFLIP=NBRJQ*PYR(0)+1
21650 IF (IDQ(JFLIP).LT.0) THEN
21651 IDQ(JFLIP)=-IDQ(JFLIP)
21654 IF (NDIQ.LE.1) GOTO 730
21656 C...Place selected quarks first in IDQ, ordered in flavour.
21658 IF (IDQ(JDQ).LE.0) THEN
21662 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
21669 C...Choose diquark spin.
21670 IF (NBRVQ.EQ.2) THEN
21671 C...If the selected quarks are both valence, we may use SU(6) rules
21672 C...to figure out which spin the diquark has, by a subdivision of the
21673 C...original beam hadron into the selected diquark system plus a kicked
21674 C...out quark, IKO.
21678 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
21682 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
21684 C...If one or more of the selected quarks are not valence, we cannot use
21685 C...SU(6) subdivisions of the original beam hadron. Instead, with the
21686 C...flavours of the diquark already selected, we assume for now
21687 C...50:50 spin-1:spin-0 (where spin-0 possible).
21688 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
21690 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
21691 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
21692 KFDQ=KFDQ+ISIGN(IS,KFDQ)
21695 C...Collapse diquark-j-quark system to baryon, if allowed and possible.
21696 C...Note: third quark can per definition not also be valence,
21697 C...therefore we can only do this if we are allowed to use sea quarks.
21698 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
21701 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
21702 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
21704 ELSEIF(NTRY.GT.100) THEN
21705 C...If no baryon can be found, give up and form diquark.
21709 C...Replace junction by baryon.
21712 K(IJU,3)=MINT(83)+JS
21715 P(IJU,5)=PYMASS(KFBAR)
21717 C...Prepare removal of participating quarks from ER.
21718 K(JST(JS,MSJ),1)=-1
21722 C...If collapse to baryon not possible or not allowed, replace junction
21723 C...by diquark. This way, collapsed gluons that were pointing at the
21724 C...junction will now point (correctly) at diquark.
21728 K(IJU,3)=MINT(83)+JS
21733 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
21735 K(IJU,5-MANTI)=IP*MSTU(5)
21736 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
21738 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
21740 C...Prepare removal of participating quarks from ER.
21746 C...Update so ER pointers to collapsed quarks
21747 C...now go to collapsed object.
21748 DO 820 I=MINT(84)+1,N
21749 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
21750 & .K(I,1).GT.0) THEN
21752 IMO=K(I,ISID)/MSTU(5)
21753 IDA=MOD(K(I,ISID),MSTU(5))
21755 IF (K(IMO,1).EQ.-1) IMO=IJU
21758 IF (K(IDA,1).EQ.-1) IDA=IJU
21760 K(I,ISID)=IDA+MSTU(5)*IMO
21767 C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
21768 C...(this only happens for baryons, where we want to force the gluon
21769 C...to sit next to the junction. Mesons handled above.)
21770 IF (NBRTOT(JS).EQ.0) THEN
21780 K(IGL,3)=MINT(83)+JS
21781 IF (ITJUNC(JS).NE.0) THEN
21782 C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
21783 JLEG=PYR(0)*NVSUM(JS)+1
21786 JCT=MCT(I1,ITJUNC(JS))
21787 MCT(IGL,3-ITJUNC(JS))=JCT
21789 MCT(IGL,ITJUNC(JS))=NCT
21792 C...Meson. Should not happen.
21793 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
21794 IF(NERRPR.LT.5) THEN
21795 WRITE(MSTU(11),*) 'This should not have been possible!'
21802 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
21803 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
21804 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
21805 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
21806 IF (K(I2,2).NE.88) THEN
21807 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
21809 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
21810 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
21811 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
21812 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
21814 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
21820 C...Remove collapsed quarks and junctions from ER and update IMI.
21823 C...Also update beam remnant part of IMI.
21826 DO 850 I=MINT(53)+1,N
21827 IF (K(I,1).LE.0) GOTO 850
21828 C...Restore BR quark/diquark/baryon pointers in IMI.
21829 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
21832 IMI(JS,NMI(JS),1)=I
21833 IMI(JS,NMI(JS),2)=0
21837 C...Restore companion information from collapsed gluons.
21838 DO 870 I=MINT(53)+1,N
21839 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
21841 JCD=MOD(K(I,4),MSTU(5))
21842 JAD=MOD(K(I,5),MSTU(5))
21843 DO 860 IM=1,NMI(JS)
21844 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
21845 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
21847 IMI(JS,IMC,2)=IMI(JS,IMA,1)
21848 IMI(JS,IMA,2)=IMI(JS,IMC,1)
21852 C...Renumber colour lines (since some have disappeared)
21860 IF (MFOUND.EQ.0) JCD=JCD+1
21861 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
21864 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
21868 IF (I.LE.N) GOTO 890
21869 IF (JCT.LT.NCT) GOTO 880
21872 C...Reset hard interaction subsystems to their CM frames.
21873 IF (IBOOST.EQ.1) THEN
21874 DO 900 IM=1,MINT(31)
21875 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21876 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21878 C...Zero beam remnant longitudinal momenta and energies
21879 DO 910 I=MINT(53)+1,N
21885 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
21886 C...Kill event and start another.
21893 C*********************************************************************
21896 C...Adapted from PYPREP.
21897 C...Assigns LHA1 colour tags to coloured partons based on
21898 C...K(I,4) and K(I,5) colour connection record.
21899 C...KCS negative signifies that a previous tracing should be continued.
21900 C...(in case the tag to be continued is empty, the routine exits)
21901 C...Starts at I and ends at I or IEND.
21902 C...Special considerations for systems with junctions.
21904 SUBROUTINE PYCTTR(I,KCS,IEND)
21905 C...Double precision and integer declarations.
21906 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21907 INTEGER PYK,PYCHGE,PYCOMP
21909 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21910 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21911 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21912 COMMON/PYINT1/MINT(400),VINT(400)
21913 C...The common block of colour tags.
21914 COMMON/PYCTAG/NCT,MCT(4000,2)
21915 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
21919 C...Skip if parton not existing or does not have KCS
21920 IF (K(I,1).LE.0) GOTO 120
21922 IF (KC.EQ.0) GOTO 120
21924 IF (KQ.EQ.0) GOTO 120
21925 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
21930 C...Set colour tag of first parton.
21936 IF (NCS.EQ.0) GOTO 120
21942 IF(NSTP.GT.4*N) THEN
21943 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
21947 C...Finished if reached final-state triplet.
21948 IF(K(IA,1).EQ.3) THEN
21949 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
21952 C...Also finished if reached junction.
21953 IF(K(IA,1).EQ.42) THEN
21957 C...GOTO next parton in colour space.
21959 C...If IB's KCS daughter not traced and exists, goto KCS daughter.
21960 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
21962 IA=MOD(K(IB,KCS),MSTU(5))
21963 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
21966 C...If KCS mother traced or KCS mother nonexistent, switch colour.
21967 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
21968 & MSTU(5)).EQ.0) THEN
21972 C...Assign new colour tag on other side of old parton.
21975 C...Goto (new) KCS mother, set mother traced tag
21976 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
21977 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
21980 IF(IA.LE.0.OR.IA.GT.N) THEN
21981 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
21982 IF(NERRPR.LT.5) THEN
21983 write(*,*) 'began at ',I
21984 write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
21985 & ' NCS=',NCS,' MREV=',MREV
21992 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
21993 & MSTU(5)).EQ.IB) THEN
21994 IF(MREV.EQ.1) KCS=9-KCS
21995 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
21996 C...Set KSC mother traced tag for IA
21997 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
21999 IF(MREV.EQ.0) KCS=9-KCS
22000 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
22001 C...Set KCS daughter traced tag for IA
22002 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
22004 C...Assign new colour tag
22006 IF(IA.NE.I.AND.IA.NE.IEND) GOTO 100
22011 *********************************************************************
22014 C...Collapse JCP1 and connecting tags to JCG1.
22015 C...Collapse JCP2 and connecting tags to JCG2.
22017 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
22018 C...Double precision and integer declarations.
22019 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22020 IMPLICIT INTEGER(I-N)
22021 INTEGER PYK,PYCHGE,PYCOMP
22022 C...The event record
22023 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22025 COMMON/PYINT1/MINT(400),VINT(400)
22026 SAVE /PYJETS/,/PYINT1/
22027 C...Local variables
22028 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
22029 COMMON /PYCTAG/NCT,MCT(4000,2)
22030 SAVE /PYCBLS/,/PYCTAG/
22032 C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
22033 C...in temporary tag collapse array JCCN. Only break up one connection.
22037 JCCN(ICC,1)=JCCO(ICC,1)
22038 JCCN(ICC,2)=JCCO(ICC,2)
22039 C...If there was a mother, it was previously connected to JCP1.
22040 C...Should be changed to JCP2.
22041 IF (MCLPS.EQ.0) THEN
22042 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
22044 JCCN(ICC,1)=MAX(JCG2,JCP2)
22045 JCCN(ICC,2)=MIN(JCG2,JCP2)
22050 C...Also collapse colours on JCP1 side of JCG1
22051 IF (JCP1.NE.0) THEN
22052 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
22053 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
22055 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
22056 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
22059 C...Initialize event record colour tag array MCT array to MCO.
22060 DO 110 I=MINT(84)+1,N
22066 C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
22067 C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
22068 C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
22069 C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
22071 C...Skip if junction.
22072 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
22073 C...Define starting point in tag space.
22074 C...JCA = previous tag
22075 C...JCO = present tag
22077 IF (MOD(IS,2).EQ.1) THEN
22081 ELSEIF (MOD(IS,2).EQ.0) THEN
22087 120 ITRACE=ITRACE+1
22088 IF (ITRACE.GT.1000) THEN
22089 C...NB: Proper error message should be defined here.
22091 & ,'(PYMIHG:) Inf loop when collapsing colours.')
22092 MINT(57)=MINT(57)+1
22096 C...Collapse all JCN tags to JCALL
22097 DO 130 I=MINT(84)+1,N
22098 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22099 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22101 C...IS = 1,2: first step forward. IS = 3,4: first step backward.
22102 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
22109 C...If possible, step from JCO to new tag JCN not equal to JCA.
22111 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
22113 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
22116 C...Iterate if new colour was arrived at, but don't go in circles.
22117 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
22118 C...Change all JCN tags in MCO to JCALL in MCT.
22119 DO 150 I=MINT(84)+1,N
22120 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22121 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22122 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22123 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22128 DO 200 JCL=NCT,1,-1
22133 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
22135 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
22138 C...Overpaint all JCN with JCL
22139 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
22140 DO 190 I=MINT(84)+1,N
22141 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
22142 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
22143 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22144 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22155 C*********************************************************************
22158 C...Picks primordial kT and shares longitudinal momentum among
22163 C...Double precision and integer declarations.
22164 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22165 IMPLICIT INTEGER(I-N)
22166 INTEGER PYK,PYCHGE,PYCOMP
22167 C...The event record
22168 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22170 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22171 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22172 COMMON/PYINT1/MINT(400),VINT(400)
22173 C...The common block of colour tags.
22174 COMMON/PYCTAG/NCT,MCT(4000,2)
22175 C...The common block of dangling ends
22176 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
22177 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
22178 & XMI(2,240),PT2MI(240),IMISEP(0:240)
22179 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
22180 C...Local variables
22181 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
22182 C...W(I,J)| J=0 | 1 | 2 |
22183 C... I=0 | Wrem**2 | W+ | W- |
22184 C... 1 | W1**2 | W1+ | W1- |
22185 C... 2 | W2**2 | W2+ | W2- |
22187 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)
22188 C...Tentative parametrization of <kT> as a function of Q.
22189 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
22190 C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
22191 C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
22192 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
22193 C...Lambda kinematic function.
22194 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
22196 C...Beginning and end of beam remnant partons
22200 C...Loopback point if kinematic choices gives impossible configuration.
22204 C...Assign kT values on each side separately.
22207 C...First zero all kT on this side. Skip if no kT to generate.
22208 DO 110 IM=1,NMI(JS)
22209 P(IMI(JS,IM,1),1)=0D0
22210 P(IMI(JS,IM,1),2)=0D0
22212 IF(MSTP(91).LE.0) GOTO 180
22214 C...Now assign kT to each (non-collapsed) parton in IMI.
22215 DO 170 IM=1,NMI(JS)
22217 C...Select kT according to truncated gaussian or 1/kt6 tails.
22218 C...For first interaction, either use rms width = PARP(91) or fitted.
22221 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
22226 C...For subsequent interactions and BR partons use fragmentation width.
22231 IF(NTRY.LE.100) THEN
22232 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
22236 ELSEIF (MSTP(91).EQ.2) THEN
22237 CALL PYERRM(11,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
22238 & 'available, using MSTP(91)=1.')
22239 CALL PYGIVE('MSTP(91)=1')
22241 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
22242 C...Use distribution with kt**6 tails, rms width = PARP(91).
22243 EPS=SQRT(3D0/2D0)*SIGMA
22244 C...Generate PTX and PTY separately, each propto 1/KT**6
22246 C...Decide which interval to try
22247 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
22248 IF (PYR(0).LT.P12) THEN
22249 C...Use flat approx with accept/reject up to EPS.
22251 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
22252 IF (PYR(0).GT.WT) GOTO 112
22254 C...Above EPS, use 1/kt**6 approx with accept/reject.
22255 PT=EPS/(PYR(0)**(1D0/5D0))
22256 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
22257 IF (PYR(0).GT.WT) GOTO 112
22260 IF (PYR(0).GT.0.5D0) MSIGN=-1
22261 IF (IXY.EQ.1) PTX=MSIGN*PT
22262 IF (IXY.EQ.2) PTY=MSIGN*PT
22264 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
22265 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22266 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22268 C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
22269 PT=SQRT(PTX**2+PTY**2)
22271 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
22272 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
22275 PT=SQRT(PTX**2+PTY**2)
22281 C...Compensation kicks, with varying degree of local anticorrelations.
22283 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
22284 PTCX=-PTX/(NMI(JS)-1)
22285 PTCY=-PTY/(NMI(JS)-1)
22286 IF(ISUB.EQ.95) THEN
22287 PTCX=-PTX/(NMI(JS)-2)
22288 PTCY=-PTY/(NMI(JS)-2)
22290 DO 120 IMC=1,NMI(JS)
22291 IF (IMC.EQ.IM) GOTO 120
22292 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
22293 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
22294 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
22296 ELSEIF (MCORR.GE.1) THEN
22299 C...Count up # of neighbours on either side
22301 130 IMO=K(IMO,MSID)/MSTU(5)
22302 IF (IMO.EQ.0) GOTO 140
22303 NNXT(MSID-3)=NNXT(MSID-3)+1
22304 C...Stop at quarks and junctions
22305 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
22307 C...How should compensation be shared when unequal numbers on the
22308 C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
22309 NSUM=NNXT(1)+NNXT(2)
22312 C...Total momentum to be compensated on this side
22313 IF (NNXT(MSID-3).EQ.0) GOTO 160
22314 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
22315 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
22316 C...RS: compensation supression factor as we go out from parton I.
22317 C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
22318 C...since (for now) MSTP(90) provides enough variability.
22320 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
22323 IMO=K(IMO,MSID)/MSTU(5)
22324 IF (IMO.EQ.0) GOTO 160
22326 IF (K(IMO,2).NE.88) THEN
22327 P(IMO,1)=P(IMO,1)+FAC*PTCX
22328 P(IMO,2)=P(IMO,2)+FAC*PTCY
22329 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
22330 C...If we reach junction, divide out the kT that would have been
22331 C...assigned to the junction on each of its other legs.
22333 L1=MOD(K(IMO,4),MSTU(5))
22334 L2=K(IMO,5)/MSTU(5)
22335 L3=MOD(K(IMO,5),MSTU(5))
22336 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
22337 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
22338 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
22339 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
22340 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
22341 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
22342 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
22343 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
22349 C...End assignment of kT values to initiators and remnants.
22352 C...Check kinematics constraints for non-BR partons.
22353 DO 190 IM=1,MINT(31)
22354 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
22355 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
22356 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
22357 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
22358 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
22359 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
22360 IF(NTRY.GE.100) THEN
22361 C...Kill this event and start another.
22363 & '(PYMIRM:) No consistent (x,kT) sets found')
22371 C...Calculate W+ and W- available for combined remnant system.
22374 DO 200 IM=1,MINT(31)
22375 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
22376 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
22377 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
22378 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
22379 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
22381 C...Also store Wrem**2 = W+ * W-
22382 W(0,0)=W(0,1)*W(0,2)
22384 IF (W(0,0).LT.0D0.AND.NTRY.LE.100) THEN
22385 IF(NTRY.GE.100) THEN
22386 C...Kill this event and start another.
22388 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
22395 C...Assign unscaled x values to partons/hadrons in each of the
22396 C...beam remnants and calculate unscaled W+ and W- from them.
22402 DO 270 IM=MINT(31)+1,NMI(JS)
22408 C...Skip collapsed gluons and junctions. Reset.
22409 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
22410 IF (KFA.EQ.88) GOTO 270
22417 C...If gluon then only beam remnant, so takes all.
22420 C...If valence quark then use parametrized valence distribution.
22421 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
22423 C...If companion quark then derive from companion x.
22424 ELSEIF(KFA.LE.6) THEN
22426 C...If valence diquark then use two parametrized valence distributions.
22427 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
22429 IVALQ(1)=ISIGN(KFA/1000,KF)
22430 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
22431 C...If valence+sea diquark then combine valence + companion choices.
22432 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
22433 & ICOMP.LT.MSTU(5)) THEN
22434 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
22435 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
22437 IVALQ(1)=ISIGN(KFA/1000,KF)
22440 C...Extra code: workaround for diquark made out of two sea
22441 C...quarks, but where not (yet) ICOMP > MSTU(5).
22442 DO 220 IM1=1,MINT(31)
22443 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
22444 ICOMQ(2)=IMI(JS,IM1,1)
22448 C...If sea diquark then sum of two derived from companion x.
22449 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
22450 ICOMQ(1)=MOD(ICOMP,MSTU(5))
22451 ICOMQ(2)=ICOMP/MSTU(5)
22452 C...If meson or baryon then use fragmentation function.
22453 C...Somewhat arbitrary split into old and new flavour, but OK normally.
22455 KFL3=MOD(KFA/10,10)
22456 IF(MOD(KFA/1000,10).EQ.0) THEN
22457 KFL1=MOD(KFA/100,10)
22459 KFL1=MOD(KFA,10000)-10*KFL3-1
22460 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
22461 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
22463 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
22464 CALL PYZDIS(KFL1,KFL3,PR,X)
22468 C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
22469 C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
22470 C...In other baryons combine u and d from proton appropriately.
22471 IF(IVALQ(IQ).NE.0) THEN
22473 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
22474 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
22475 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
22477 IF(KFIVAL(JS,3).EQ.0) THEN
22479 C...Baryon with three identical quarks: mix u and d forms.
22480 ELSEIF(NVAL.EQ.3) THEN
22481 MDU=INT(PYR(0)+5D0/3D0)
22482 C...Baryon, one of two identical quarks: u form.
22483 ELSEIF(NVAL.EQ.2) THEN
22485 C...Baryon with two identical quarks, but not the one picked: d form.
22486 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
22487 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
22489 C...Baryon with three nonidentical quarks: mix u and d forms.
22491 MDU=INT(PYR(0)+5D0/3D0)
22494 IF(MDU.EQ.1) XPOW=3.5D0
22495 IF(MDU.EQ.2) XPOW=2D0
22497 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
22501 C...Calculation of x of companion quark.
22502 IF(ICOMQ(IQ).NE.0) THEN
22504 DO 240 IM1=1,MINT(31)
22505 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
22507 NPOW=MAX(0,MIN(4,MSTP(87)))
22508 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
22509 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
22510 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
22511 IF(CORR.LT.PYR(0)) GOTO 250
22516 C...Optionally enchance x of composite systems (e.g. diquarks)
22517 IF (KFA.GT.100) X=PARP(79)*X
22519 C...Store x. Also calculate light cone energies of each system.
22521 W(JS,JS)=W(JS,JS)+X
22522 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
22524 W(JS,JS)=W(JS,JS)*W(0,JS)
22525 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
22526 W(JS,0)=W(JS,1)*W(JS,2)
22529 C...Check W1 W2 < Wrem (can be done before rescaling, since W
22530 C...insensitive to global rescalings of the BR x values).
22531 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
22534 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
22536 ELSEIF (NTRYX.GT.100) THEN
22537 CALL PYERRM(11,'(PYMIRM:) No consistent (x,kT) sets found')
22538 MINT(57)=MINT(57)+1
22543 C...Compute x rescaling factors
22544 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
22545 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
22546 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
22548 IF (R1.LT.0.OR.R2.LT.0) THEN
22549 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
22550 MINT(57)=MINT(57)+1
22554 C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
22560 C...Rescale BR x values.
22561 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
22562 XMI(1,IM)=XMI(1,IM)*R1
22563 XMI(2,IM)=XMI(2,IM)*R2
22566 C...Now we have a consistent set of x and kT values.
22567 C...First set up the initiators and their daughters correctly.
22568 DO 300 IM=1,MINT(31)
22571 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
22572 & (P(I1,2)+P(I2,2))**2
22573 PT12=P(I1,1)**2+P(I1,2)**2
22574 PT22=P(I2,1)**2+P(I2,2)**2
22576 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
22578 C...Energies (masses should be zero at this stage)
22579 P(I1,4)=SQRT(PT12+P(I1,3)**2)
22580 P(I2,4)=SQRT(PT22+P(I2,3)**2)
22582 C...Transverse 12 system initiator velocity:
22583 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
22584 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
22585 C...Boost to overall initiator system rest frame
22586 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
22587 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
22589 C...Compute phi,theta coordinates of I1 and rotate z axis.
22590 PHI=PYANGL(P(I1,1),P(I1,2))
22591 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
22592 IMIN=IMISEP(IM-1)+1
22593 C...(include documentation lines if MI = 1)
22594 IF (IM.EQ.1) IMIN=MINT(83)+5
22596 C...Rotate entire system in phi
22597 CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
22598 C...Only rotate 12 system in theta
22599 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
22600 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
22602 C...Now boost entire system back to LAB
22603 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22604 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
22605 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
22610 C...For the beam remnant partons/hadrons, we only need to set pz and E.
22612 DO 310 IM=MINT(31)+1,NMI(JS)
22614 C...Skip collapsed gluons and junctions.
22615 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
22616 IF (KFA.EQ.88) GOTO 310
22617 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
22618 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
22619 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
22620 IF (JS.EQ.2) P(I,3)=-P(I,3)
22625 C...Documentation lines
22631 K(IN,3)=MINT(83)+JS
22638 MCT(IN,1)=MCT(IO,1)
22639 MCT(IN,2)=MCT(IO,2)
22642 C...Final state colour reconnections.
22643 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
22645 C...Number of colour tags for which a recoupling will be tried.
22647 C...Number of recouplings to try
22655 IF (IITER.LE.PARP(78)*NTOT) THEN
22656 C...Select two colour tags at random
22657 C...NB: jj strings do not have colour tags assigned to them,
22658 C...thus they are as yet not affected by anything done here.
22660 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
22665 C...Find final state partons with this (anti)colour
22666 DO 370 I=MINT(84)+1,N
22667 IF (K(I,1).EQ.3) THEN
22668 IF (MCT(I,1).EQ.JCT) IJ1=I
22669 IF (MCT(I,2).EQ.JCT) IJ2=I
22670 IF (MCT(I,1).EQ.KCT) IK1=I
22671 IF (MCT(I,2).EQ.KCT) IK2=I
22674 C...Only consider recouplings not involving junctions for now.
22675 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
22677 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
22678 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
22679 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
22682 C...Count up number of reconnections
22683 MINT(34)=MINT(34)+1
22685 IF (MINT(34).LE.1000) THEN
22688 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
22692 IF (NRECP.LT.MINT(34)) GOTO 350
22694 C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
22700 C*********************************************************************
22703 C...Performs colour annealing.
22704 C...MSTP(95) : CR Type
22705 C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
22706 C... = 2 : Type I(no gg loops); hadron-hadron only
22707 C... = 3 : Type I(no gg loops); all beams
22708 C... = 4 : Type II(gg loops) ; hadron-hadron only
22709 C... = 5 : Type II(gg loops) ; all beams
22710 C... = 6 : Type S ; hadron-hadron only
22711 C... = 7 : Type S ; all beams
22712 C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
22713 C...Type S is driven by starting only from free triplets, not octets.
22714 C...A string piece remains unchanged with probability
22715 C... PKEEP = (1-PARP(78))**N
22716 C...This scaling corresponds to each string piece having to go through
22717 C...N other ones, each with probability PARP(78) for reconnection, where
22718 C...N is here chosen simply as the number of multiple interactions,
22719 C...for a rough scaling with the general level of activity.
22721 SUBROUTINE PYFSCR(IP)
22722 C...Double precision and integer declarations.
22723 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22724 INTEGER PYK,PYCHGE,PYCOMP
22726 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22727 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22728 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22729 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22730 COMMON/PYINT1/MINT(400),VINT(400)
22731 C...The common block of colour tags.
22732 COMMON/PYCTAG/NCT,MCT(4000,2)
22733 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
22735 C...MCN: Temporary storage of new colour tags
22736 DOUBLE PRECISION MCN(4000,2)
22738 C...Function to give four-product.
22739 FOUR(I,J)=P(I,4)*P(J,4)
22740 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
22742 C...Check valid range of MSTP(95), local copy
22743 IF (MSTP(95).LE.1.OR.MSTP(95).GE.8) RETURN
22744 MSTP95=MOD(MSTP(95),10)
22745 C...Set whether CR allowed inside resonance systems or not
22746 C...(not implemented yet)
22748 C IF (MSTP(95).GE.10) MRESCR=0
22750 C...Check whether colour tags already defined
22751 IF (MINT(33).EQ.0) THEN
22752 C...Erase any existing colour tags for this event
22757 C...Create colour tags for this event
22759 IF (K(I,1).EQ.3) THEN
22762 IF (MCT(I,KCSIN-3).EQ.0) THEN
22763 CALL PYCTTR(I,KCSIN,I)
22768 C...Instruct PYPREP to use colour tags
22772 C...For MSTP(95) even, only apply to hadron-hadron
22773 IF (MOD(MSTP(95),2).EQ.0) THEN
22776 IF (KA1.LT.100.OR.KA2.LT.100) GOTO 9999
22779 C...Initialize new tag array (but do not delete old yet)
22781 DO 130 I=MAX(1,IP),N
22786 C...For each final-state dipole, check whether string should be
22791 DO 140 I=MAX(1,IP),N
22792 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
22793 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
22795 IF (IC.NE.0.AND.IA.NE.0) THEN
22796 C...Chiefly consider large strings.
22797 PKEEP=(1D0-PARP(78))**MINT(31)
22798 IF (PYR(0).LE.PKEEP) THEN
22806 C...Loop over event record, starting from IP
22807 C...(Ignore junctions for now.)
22815 DO 230 I=MAX(1,IP),N
22816 IF (K(I,1).NE.3) GOTO 230
22817 C...Check colour charge
22818 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22819 IF (MCI.EQ.0) GOTO 230
22820 C...For Seattle algorithm, only start from partons with one dangling
22822 IF (MSTP(95).EQ.6.OR.MSTP(95).EQ.7) THEN
22823 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
22825 C... Find optimal partner
22831 C...Loop over I colour/anticolour, check whether already connected
22833 IF (MCN(I,ICL).NE.0) GOTO 220
22834 IF (ICL.EQ.1.AND.MCI.EQ.-1) GOTO 220
22835 IF (ICL.EQ.2.AND.MCI.EQ.1) GOTO 220
22836 C...Check whether this is a dangling colour tag (ie to junction!)
22838 DO 180 J=MAX(1,IP),N
22839 IF (K(J,1).EQ.3.AND.MCT(J,3-ICL).EQ.MCT(I,ICL)) IFOUND=1
22841 IF (IFOUND.EQ.0) GOTO 220
22842 DO 210 J=MAX(1,IP),N
22843 IF (K(J,1).NE.3.OR.I.EQ.J) GOTO 210
22844 C...Do not make direct connections between partons in same Beam Remnant
22846 IF (K(I,3).LE.2.AND.K(J,3).LE.2.AND.K(I,3).EQ.K(J,3))
22848 C...Check colour charge
22849 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
22850 IF (MCJ.EQ.0.OR.(MCJ.EQ.MCI.AND.MCI.NE.2)) GOTO 210
22851 C...Check for gluon loops
22853 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
22855 IF (MCN(I,ICLA).EQ.MCN(J,ICL).AND.MSTP(95).LE.3.AND.
22856 & MCN(I,ICLA).NE.0) MGGSTR=1
22858 C...Loop over J colour/anticolour, check whether already connected
22860 IF (MCN(J,JCL).NE.0) GOTO 200
22861 IF (JCL.EQ.ICL) GOTO 200
22862 IF (JCL.EQ.1.AND.MCJ.EQ.-1) GOTO 200
22863 IF (JCL.EQ.2.AND.MCJ.EQ.1) GOTO 200
22864 C...Check whether this is a dangling colour tag (ie to junction!)
22866 DO 190 J2=MAX(1,IP),N
22867 IF (K(J2,1).EQ.3.AND.MCT(J2,3-JCL).EQ.MCT(J,JCL))
22870 IF (IFOUND.EQ.0) GOTO 200
22871 C...Save connection with smallest lambda measure
22872 C...If best so far was a BR string and this is not, also save.
22873 C...If best so far was a gg string and this is not, also save.
22875 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
22876 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
22877 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
22889 IF (JLOPT.NE.0) THEN
22890 C...Save pair with largest RLOPT so far
22891 IF (RLOPT.GE.RLMAX) THEN
22902 C...Save and iterate
22903 IF (ILMAX.GT.0) THEN
22905 MCN(ILMAX,ICMAX)=LCT
22906 MCN(JLMAX,JCMAX)=LCT
22907 IF (NLOOP.LE.2*(N-IP)) THEN
22910 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
22914 C...Save and exit. First check for leftover gluon(s)
22915 DO 260 I=MAX(1,IP),N
22916 C...Check colour charge
22917 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22918 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
22919 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
22920 C...Decide where to put left-over gluon (minimal insertion)
22923 DO 250 KCT=NCT+1,LCT
22924 DO 240 IT=MAX(1,IP),N
22925 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
22926 IF (MCN(IT,1).EQ.KCT) IC=IT
22927 IF (MCN(IT,2).EQ.KCT) IA=IT
22929 RL=FOUR(IC,I)*FOUR(IA,I)
22930 IF (RL.LT.RLMAX) THEN
22937 MCN(I,1)=MCN(ICMAX,1)
22942 DO 270 I=MAX(1,IP),N
22943 C...Do not erase parton shower colour history
22944 IF (K(I,1).NE.3) GOTO 270
22945 C...Check colour charge
22946 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22947 IF (MCI.EQ.0) GOTO 270
22948 IF (MCN(I,1).NE.0) MCT(I,1)=MCN(I,1)
22949 IF (MCN(I,2).NE.0) MCT(I,2)=MCN(I,2)
22956 C*********************************************************************
22959 C...Handles diffractive and elastic scattering.
22963 C...Double precision and integer declarations.
22964 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22965 IMPLICIT INTEGER(I-N)
22966 INTEGER PYK,PYCHGE,PYCOMP
22968 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22969 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22970 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22971 COMMON/PYINT1/MINT(400),VINT(400)
22972 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
22974 C...Reset K, P and V vectors. Store incoming particles.
22975 DO 110 JT=1,MSTP(126)+10
22995 P(I,J)=VINT(285+5*JT+J)
23000 C...Subprocess; kinematics.
23001 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
23002 PZ=SQRT(SQLAM)/(2D0*VINT(1))
23005 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
23008 C...Elastically scattered particle. (Except elastic GVMD states.)
23009 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
23010 & MINT(106+JT).NE.3)) THEN
23015 P(N,3)=PZ*(-1)**(JT+1)
23017 P(N,5)=SQRT(VINT(62+JT))
23019 C...Decay rho from elastic scattering of gamma with sin**2(theta)
23020 C...distribution of decay products (in rho rest frame).
23021 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
23023 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
23027 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
23028 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
23029 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
23030 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
23031 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
23032 140 CTHE=2D0*PYR(0)-1D0
23033 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
23034 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
23036 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
23039 C...Diffracted particle: low-mass system to two particles.
23040 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
23046 PMMAS=SQRT(VINT(62+JT))
23049 IF(NTRY.LT.20) THEN
23050 MINT(105)=MINT(102+JT)
23051 MINT(109)=MINT(106+JT)
23052 CALL PYSPLI(KFH,21,KFL1,KFL2)
23053 CALL PYKFDI(KFL1,0,KFL3,KF1)
23054 IF(KF1.EQ.0) GOTO 150
23055 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
23056 IF(KF2.EQ.0) GOTO 150
23063 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
23068 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
23069 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
23072 P(N-1,4)=SQRT(PM1**2+PZP**2)
23073 P(N,4)=SQRT(PM2**2+PZP**2)
23074 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
23076 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
23077 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
23079 C...Diffracted particle: valence quark kicked out.
23080 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
23087 MINT(105)=MINT(102+JT)
23088 MINT(109)=MINT(106+JT)
23089 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
23090 P(N-1,5)=PYMASS(K(N-1,2))
23091 P(N,5)=PYMASS(K(N,2))
23092 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
23093 & 4D0*P(N-1,5)**2*P(N,5)**2
23094 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
23095 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
23096 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
23097 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
23098 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23100 C...Diffracted particle: gluon kicked out.
23109 MINT(105)=MINT(102+JT)
23110 MINT(109)=MINT(106+JT)
23111 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
23113 P(N-2,5)=PYMASS(K(N-2,2))
23115 P(N,5)=PYMASS(K(N,2))
23116 C...Energy distribution for particle into two jets.
23118 IF(MOD(KFH/1000,10).NE.0) IMB=2
23119 CHIK=PARP(92+2*IMB)
23120 IF(MSTP(92).LE.1) THEN
23121 IF(IMB.EQ.1) CHI=PYR(0)
23122 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23123 ELSEIF(MSTP(92).EQ.2) THEN
23124 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
23125 ELSEIF(MSTP(92).EQ.3) THEN
23126 CUT=2D0*0.3D0/VINT(1)
23128 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
23130 ELSEIF(MSTP(92).EQ.4) THEN
23131 CUT=2D0*0.3D0/VINT(1)
23132 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
23133 180 CHIR=CUT*CUTR**PYR(0)
23134 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
23135 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
23137 CUT=2D0*0.3D0/VINT(1)
23138 CUTA=CUT**(1D0-PARP(98))
23139 CUTB=(1D0+CUT)**(1D0-PARP(98))
23140 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
23141 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
23142 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
23144 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
23145 & VINT(62+JT)) GOTO 160
23146 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
23147 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
23148 & (2D0*VINT(62+JT))
23149 PEI=SQRT(PZI**2+SQM)
23150 PQQP=(1D0-CHI)*(PEI+PZI)
23151 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
23152 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
23153 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
23154 P(N-1,3)=P(N-1,4)*(-1)**JT
23155 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
23156 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23159 C...Documentation lines.
23161 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
23162 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
23163 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
23165 P(I+2,3)=PZ*(-1)**(JT+1)
23167 P(I+2,5)=SQRT(VINT(62+JT))
23170 C...Rotate outgoing partons/particles using cos(theta).
23171 IF(VINT(23).LT.0.9D0) THEN
23172 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
23174 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
23180 C*********************************************************************
23183 C...Set up a DIS process as gamma* + f -> f, with beam remnant
23184 C...and showering added consecutively. Photon flux by the PYGAGA
23185 C...routine (if at all).
23189 C...Double precision and integer declarations.
23190 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23191 IMPLICIT INTEGER(I-N)
23192 INTEGER PYK,PYCHGE,PYCOMP
23193 C...Parameter statement to help give large particle numbers.
23194 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23195 &KEXCIT=4000000,KDIMEN=5000000)
23197 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23198 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23199 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23200 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23201 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23202 COMMON/PYINT1/MINT(400),VINT(400)
23203 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
23207 C...Choice of subprocess, number of documentation lines
23215 IF(MINT(107).EQ.4) ISIDE=2
23217 C...Reset K, P and V vectors. Store incoming particles
23218 DO 110 JT=1,MSTP(126)+20
23231 P(I,J)=VINT(285+5*JT+J)
23236 C...Store incoming partons in hadronic CM-frame
23241 K(I,3)=MINT(83)+2+JT
23243 IF(MINT(15).EQ.22) THEN
23244 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
23245 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
23246 P(MINT(84)+1,5)=-SQRT(VINT(307))
23247 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
23248 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
23252 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
23253 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
23254 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
23255 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
23256 P(MINT(84)+1,5)=-SQRT(VINT(308))
23260 SIDESG=(-1D0)**(ISIDE-1)
23262 C...Copy incoming partons to documentation lines.
23273 C...Second copy for partons before ISR shower, since no such.
23283 C...Define initial partons.
23286 IF(NTRY.GT.100) THEN
23291 C...Scattered quark in hadronic CM frame.
23296 P(IPU3,5)=PYMASS(KFRES)
23297 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
23298 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
23302 K(I,3)=MINT(83)+4+ISIDE
23310 C...No primordial kT, or chosen according to truncated Gaussian or
23311 C...exponential, or (for photon) predetermined or power law.
23312 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
23313 IF(MSTP(91).LE.0) THEN
23315 ELSEIF(MSTP(91).EQ.1) THEN
23316 PT=PARP(91)*SQRT(-LOG(PYR(0)))
23320 PT=-PARP(92)*LOG(RPT1*RPT2)
23322 IF(PT.GT.PARP(93)) GOTO 190
23323 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
23324 PTA=SQRT(VINT(282+ISIDE))
23326 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
23327 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
23328 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
23331 PTB=-PARP(99)*LOG(RPT1*RPT2)
23333 IF(PTB.GT.PARP(100)) GOTO 190
23334 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
23335 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
23336 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
23337 IF(MSTP(93).LE.0) THEN
23339 ELSEIF(MSTP(93).EQ.1) THEN
23340 PT=PARP(99)*SQRT(-LOG(PYR(0)))
23341 ELSEIF(MSTP(93).EQ.2) THEN
23344 PT=-PARP(99)*LOG(RPT1*RPT2)
23345 ELSEIF(MSTP(93).EQ.3) THEN
23348 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
23352 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
23353 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
23355 IF(PT.GT.PARP(100)) GOTO 190
23361 P(IPU3,1)=PT*COS(PHI)
23362 P(IPU3,2)=PT*SIN(PHI)
23363 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
23364 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
23365 PCP=P(IPU3,4)+ABS(P(IPU3,3))
23367 C...Find one or two beam remnants.
23368 MINT(105)=MINT(102+ISIDE)
23369 MINT(109)=MINT(106+ISIDE)
23370 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
23371 IF(MINT(51).NE.0) THEN
23376 C...Store first remnant parton, with colour info and kinematics.
23380 K(I,3)=MINT(83)+ISIDE
23381 P(I,5)=PYMASS(K(I,2))
23382 KCOL=KCHG(PYCOMP(KFLSP),2)
23385 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
23386 K(I,KFLS+3)=MSTU(5)*IPU3
23387 K(IPU3,6-KFLS)=MSTU(5)*I
23390 IF(KFLCH.EQ.0) THEN
23393 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
23395 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
23396 PRP=P(I,4)+ABS(P(I,3))
23398 C...When extra remnant parton or hadron: store extra remnant.
23403 K(I,3)=MINT(83)+ISIDE
23404 P(I,5)=PYMASS(K(I,2))
23405 KCOL=KCHG(PYCOMP(KFLCH),2)
23408 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
23409 K(I,KFLS+3)=MSTU(5)*IPU3
23410 K(IPU3,6-KFLS)=MSTU(5)*I
23414 C...Relative transverse momentum when two remnants.
23417 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
23418 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
23419 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
23420 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
23421 P(I,1)=-P(IPU3,1)-P(I-1,1)
23422 P(I,2)=-P(IPU3,2)-P(I-1,2)
23423 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
23425 C...Relative distribution of energy for particle into jet plus particle.
23427 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
23428 IF(MSTP(94).LE.1) THEN
23429 IF(IMB.EQ.1) CHI=PYR(0)
23430 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23431 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
23432 ELSEIF(MSTP(94).EQ.2) THEN
23433 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
23434 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
23435 ELSEIF(MSTP(94).EQ.3) THEN
23436 CALL PYZDIS(1,0,PMS(4),ZZ)
23439 CALL PYZDIS(1000,0,PMS(4),ZZ)
23443 C...Construct total transverse mass; reject if too large.
23444 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
23445 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
23446 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
23447 IF(LOOP.LT.10) GOTO 200
23450 VINT(158+ISIDE)=CHI
23452 C...Subdivide longitudinal momentum according to value selected above.
23453 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
23455 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
23456 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
23458 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
23459 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
23463 C...Boost current and remnant systems to correct frame.
23464 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
23465 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
23466 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
23468 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
23470 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
23471 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
23472 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
23473 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
23475 C...Let current quark shower; recoil but no showering by colour partner.
23476 QMAX=2D0*SQRT(VINT(309-ISIDE))
23481 IF(MSTP(71).EQ.1) then
23482 if(parj(200).ne.1.) CALL PYSHOW(IPU3,ICOLR,QMAX)
23483 if(parj(200).eq.1.) CALL PYSHOWQ(IPU3,ICOLR,QMAX)
23491 C*********************************************************************
23494 C...Handles the documentation of the process in MSTI and PARI,
23495 C...and also computes cross-sections based on accumulated statistics.
23499 C...Double precision and integer declarations.
23500 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23501 IMPLICIT INTEGER(I-N)
23502 INTEGER PYK,PYCHGE,PYCOMP
23504 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23505 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23506 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23507 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23508 COMMON/PYINT1/MINT(400),VINT(400)
23509 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
23510 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
23511 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
23514 C...Calculate Monte Carlo estimates of cross-sections.
23516 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
23517 NGEN(0,3)=NGEN(0,3)+1
23520 IF(I.EQ.96.OR.I.EQ.97) THEN
23522 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
23523 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
23524 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
23525 & DBLE(NGEN(96,2)))
23526 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
23527 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
23528 & DBLE(NGEN(96,2)))
23529 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
23531 ELSEIF(NGEN(I,2).EQ.0) THEN
23532 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
23535 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
23538 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
23541 C...Rescale to known low-pT cross-section for standard QCD processes.
23542 IF(MSUB(95).EQ.1) THEN
23543 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
23544 & XSEC(68,3)+XSEC(95,3)
23545 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
23546 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
23548 XSEC(11,3)=FAC*XSEC(11,3)
23549 XSEC(12,3)=FAC*XSEC(12,3)
23550 XSEC(13,3)=FAC*XSEC(13,3)
23551 XSEC(28,3)=FAC*XSEC(28,3)
23552 XSEC(53,3)=FAC*XSEC(53,3)
23553 XSEC(68,3)=FAC*XSEC(68,3)
23554 XSEC(95,3)=FAC*XSEC(95,3)
23555 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
23559 C...Save information for gamma-p and gamma-gamma.
23560 IF(MINT(121).GT.1) THEN
23566 C...Reset information on hard interaction.
23572 C...Copy integer valued information from MINT into MSTI.
23576 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
23578 C...Store cross-section variables in PARI.
23580 PARI(2)=XSEC(0,3)/MINT(5)
23584 VINT(98)=VINT(98)+VINT(100)
23585 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
23587 C...Store kinematics variables in PARI.
23590 IF(ISUB.NE.95) THEN
23600 PARI(35)=PARI(33)-PARI(34)
23607 PARI(42)=2D0*VINT(47)/VINT(1)
23610 C...Store information on scattered partons in PARI.
23611 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
23614 PARI(36+IS)=P(I,3)/VINT(1)
23615 PARI(38+IS)=P(I,4)/VINT(1)
23616 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
23617 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
23618 & SQRT(PR),1D20)),P(I,3))
23619 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
23620 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
23621 & SQRT(PR),1D20)),P(I,3))
23622 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
23623 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
23624 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
23628 C...Store sum up transverse and longitudinal momenta.
23629 PARI(65)=2D0*PARI(17)
23630 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
23631 DO 150 I=MSTP(126)+1,N
23632 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
23633 PT=SQRT(P(I,1)**2+P(I,2)**2)
23634 PARI(69)=PARI(69)+PT
23635 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
23636 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
23648 C...Store various other pieces of information into PARI.
23656 C...Store information on lepton -> lepton + gamma in PYGAGA.
23659 PARI(101)=VINT(301)
23660 PARI(102)=VINT(302)
23662 PARI(I)=VINT(I+202)
23665 C...Set information for PYTABU.
23666 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
23669 ELSEIF(ISET(ISUB).EQ.5) THEN
23680 C*********************************************************************
23683 C...Performs transformations between different coordinate frames.
23685 SUBROUTINE PYFRAM(IFRAME)
23687 C...Double precision and integer declarations.
23688 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23689 IMPLICIT INTEGER(I-N)
23690 INTEGER PYK,PYCHGE,PYCOMP
23692 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23693 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23694 COMMON/PYINT1/MINT(400),VINT(400)
23695 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
23697 C...Check that transformation can and should be done.
23698 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
23699 &MINT(91).EQ.1)) THEN
23700 IF(IFRAME.EQ.MINT(6)) RETURN
23702 WRITE(MSTU(11),5000) IFRAME,MINT(6)
23706 IF(MINT(6).EQ.1) THEN
23707 C...Transform from fixed target or user specified frame to
23708 C...overall CM frame.
23709 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
23710 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
23711 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
23712 ELSEIF(MINT(6).EQ.3) THEN
23713 C...Transform from hadronic CM frame in DIS to overall CM frame.
23714 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
23718 IF(IFRAME.EQ.1) THEN
23719 C...Transform from overall CM frame to fixed target or user specified
23721 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
23722 ELSEIF(IFRAME.EQ.3) THEN
23723 C...Transform from overall CM frame to hadronic CM frame in DIS.
23724 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
23725 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
23726 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
23729 C...Set information about new frame.
23733 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
23734 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
23740 C*********************************************************************
23743 C...Calculates full and partial widths of resonances.
23745 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
23747 C...Double precision and integer declarations.
23748 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23749 IMPLICIT INTEGER(I-N)
23750 INTEGER PYK,PYCHGE,PYCOMP
23751 C...Parameter statement to help give large particle numbers.
23752 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23753 &KEXCIT=4000000,KDIMEN=5000000)
23755 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23756 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23757 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
23758 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23759 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23760 COMMON/PYINT1/MINT(400),VINT(400)
23761 COMMON/PYINT4/MWID(500),WIDS(500,5)
23762 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
23763 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
23764 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
23765 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
23766 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
23767 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/
23768 C...Local arrays and saved variables.
23769 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
23770 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
23771 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
23772 SAVE MOFSV,WIDWSV,WID2SV
23773 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
23775 C...Compressed code and sign; mass.
23782 C...Reset width information.
23783 DO 110 I=0,MDCY(KC,3)
23790 C...Allow for fudge factor to rescale resonance width.
23792 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
23793 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
23794 IF(MSTP(110).EQ.KFLA) THEN
23796 ELSEIF(MSTP(110).EQ.-1) THEN
23797 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
23798 ELSEIF(MSTP(110).EQ.-2) THEN
23803 C...Not to be treated as a resonance: return.
23804 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
23813 C...Treatment as a resonance based on tabulated branching ratios.
23814 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
23815 C...Loop over possible decay channels; skip irrelevant ones.
23816 DO 120 I=1,MDCY(KC,3)
23818 IF(MDME(IDC,1).LT.0) GOTO 120
23820 C...Read out decay products and nominal masses.
23823 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
23827 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
23833 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
23837 C...Naive partial width and alternative threshold factors.
23838 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
23839 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
23840 & PM1+PM2+PM3.GE.SHR) THEN
23842 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
23843 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
23844 & 4D0*PM1**2*PM2**2))/SH
23845 ELSEIF(MDME(IDC,2).EQ.52) THEN
23846 PMA=MAX(PM1,PM2,PM3)
23847 PMC=MIN(PM1,PM2,PM3)
23848 PMB=PM1+PM2+PM3-PMA-PMC
23849 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
23854 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
23855 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23856 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23857 & ((SHR-PMA)**2-(PMB+PMC)**2)*
23858 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
23859 & ((1D0-PMBCN)*PMBCN*SH)
23860 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
23861 WDTP(I)=WDTP(I)*SQRT(
23862 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
23863 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
23864 ELSEIF(MDME(IDC,2).EQ.53) THEN
23865 PMA=MAX(PM1,PM2,PM3)
23866 PMC=MIN(PM1,PM2,PM3)
23867 PMB=PM1+PM2+PM3-PMA-PMC
23868 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
23873 FACACT=SQRT(MAX(0D0,
23874 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23875 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23876 & ((SHR-PMA)**2-(PMB+PMC)**2)*
23877 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
23878 & ((1D0-PMBCN)*PMBCN*SH)
23879 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
23883 PMBCN=PMBC**2/PMR**2
23884 FACNOM=SQRT(MAX(0D0,
23885 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23886 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23887 & ((PMR-PMA)**2-(PMB+PMC)**2)*
23888 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
23889 & ((1D0-PMBCN)*PMBCN*PMR**2)
23890 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
23892 WDTP(I)=FUDGE*WDTP(I)
23893 WDTP(0)=WDTP(0)+WDTP(I)
23895 C...Calculate secondary width (at most two identical/opposite).
23897 IF(MDME(IDC,1).GT.0) THEN
23898 IF(KFD2.EQ.KFD1) THEN
23899 IF(KCHG(KFC1,3).EQ.0) THEN
23901 ELSEIF(KFD1.GT.0) THEN
23907 WID2=WID2*WIDS(KFC3,2)
23908 ELSEIF(KFD3.LT.0) THEN
23909 WID2=WID2*WIDS(KFC3,3)
23911 ELSEIF(KFD2.EQ.-KFD1) THEN
23914 WID2=WID2*WIDS(KFC3,2)
23915 ELSEIF(KFD3.LT.0) THEN
23916 WID2=WID2*WIDS(KFC3,3)
23918 ELSEIF(KFD3.EQ.KFD1) THEN
23919 IF(KCHG(KFC1,3).EQ.0) THEN
23921 ELSEIF(KFD1.GT.0) THEN
23927 WID2=WID2*WIDS(KFC2,2)
23928 ELSEIF(KFD2.LT.0) THEN
23929 WID2=WID2*WIDS(KFC2,3)
23931 ELSEIF(KFD3.EQ.-KFD1) THEN
23934 WID2=WID2*WIDS(KFC2,2)
23935 ELSEIF(KFD2.LT.0) THEN
23936 WID2=WID2*WIDS(KFC2,3)
23938 ELSEIF(KFD3.EQ.KFD2) THEN
23939 IF(KCHG(KFC2,3).EQ.0) THEN
23941 ELSEIF(KFD2.GT.0) THEN
23947 WID2=WID2*WIDS(KFC1,2)
23948 ELSEIF(KFD1.LT.0) THEN
23949 WID2=WID2*WIDS(KFC1,3)
23951 ELSEIF(KFD3.EQ.-KFD2) THEN
23954 WID2=WID2*WIDS(KFC1,2)
23955 ELSEIF(KFD1.LT.0) THEN
23956 WID2=WID2*WIDS(KFC1,3)
23965 WID2=WID2*WIDS(KFC2,2)
23967 WID2=WID2*WIDS(KFC2,3)
23970 WID2=WID2*WIDS(KFC3,2)
23971 ELSEIF(KFD3.LT.0) THEN
23972 WID2=WID2*WIDS(KFC3,3)
23976 C...Store effective widths according to case.
23977 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23978 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23979 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23980 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23990 C...Here begins detailed dynamical calculation of resonance widths.
23991 C...Shared treatment of Higgs states.
23994 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
23999 C...Common electroweak and strong constants.
24002 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
24005 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
24007 RADC=1D0+AS/PARU(1)
24011 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24012 RADCT=1D0-2.5D0*AS/PARU(1)
24013 DO 140 I=1,MDCY(KC,3)
24015 IF(MDME(IDC,1).LT.0) GOTO 140
24016 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24017 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24018 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
24020 IF(I.GE.4.AND.I.LE.7) THEN
24021 C...t -> W + q; including approximate QCD correction factor.
24022 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
24023 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24024 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24027 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24030 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24032 ELSEIF(I.EQ.9) THEN
24034 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
24035 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24036 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
24037 & 4D0*SQRT(RM2R*RM2))
24039 IF(KFLR.LT.0) WID2=WIDS(37,3)
24041 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
24042 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
24045 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
24048 KFC1=PYCOMP(KFDP(IDC,1))
24049 KFC2=PYCOMP(KFDP(IDC,2))
24050 PMNCHI=PMAS(KFC1,1)
24051 PMSTOP=PMAS(KFC2,1)
24052 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24055 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
24057 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
24058 AR=-ET*ZMIXC(IZ,1)*TANW
24059 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
24061 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
24062 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
24063 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24064 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24065 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
24066 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
24067 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
24069 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24071 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24074 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
24076 KFC1=PYCOMP(KFDP(IDC,1))
24077 KFC2=PYCOMP(KFDP(IDC,2))
24078 PMNCHI=PMAS(KFC1,1)
24079 PMSTOP=PMAS(KFC2,1)
24080 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24083 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24084 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24085 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
24086 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
24088 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24090 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24093 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
24094 C...t -> ~gravitino + ~t
24096 KFC1=PYCOMP(KFDP(IDC,1))
24097 XMGR2=PMAS(KFC1,1)**2
24098 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
24099 KFC2=PYCOMP(KFDP(IDC,2))
24101 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
24104 WDTP(I)=FUDGE*WDTP(I)
24105 WDTP(0)=WDTP(0)+WDTP(I)
24106 IF(MDME(IDC,1).GT.0) THEN
24107 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24108 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24109 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24110 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24114 ELSEIF(KFLA.EQ.7) THEN
24116 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24117 DO 150 I=1,MDCY(KC,3)
24119 IF(MDME(IDC,1).LT.0) GOTO 150
24120 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24121 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24122 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
24124 IF(I.GE.4.AND.I.LE.7) THEN
24126 WDTP(I)=FAC*VCKM(I-3,4)*
24127 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24128 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24131 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
24132 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
24135 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
24136 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
24139 IF(KFLR.LT.0) WID2=WIDS(24,2)
24140 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24142 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24143 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24146 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
24149 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
24152 WDTP(I)=FUDGE*WDTP(I)
24153 WDTP(0)=WDTP(0)+WDTP(I)
24154 IF(MDME(IDC,1).GT.0) THEN
24155 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24156 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24157 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24158 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24162 ELSEIF(KFLA.EQ.8) THEN
24164 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24165 DO 160 I=1,MDCY(KC,3)
24167 IF(MDME(IDC,1).LT.0) GOTO 160
24168 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24169 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24170 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
24172 IF(I.GE.4.AND.I.LE.7) THEN
24174 WDTP(I)=FAC*VCKM(4,I-3)*
24175 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24176 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24179 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24182 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24184 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24186 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24187 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24190 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
24193 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
24196 WDTP(I)=FUDGE*WDTP(I)
24197 WDTP(0)=WDTP(0)+WDTP(I)
24198 IF(MDME(IDC,1).GT.0) THEN
24199 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24200 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24201 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24202 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24206 ELSEIF(KFLA.EQ.17) THEN
24208 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24209 DO 170 I=1,MDCY(KC,3)
24211 IF(MDME(IDC,1).LT.0) GOTO 170
24212 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24213 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24214 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
24217 C...tau' -> W + nu'_tau.
24218 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24219 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24222 WID2=WID2*WIDS(18,2)
24225 WID2=WID2*WIDS(18,3)
24227 ELSEIF(I.EQ.5) THEN
24228 C...tau' -> H + nu'_tau.
24229 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24230 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24233 WID2=WID2*WIDS(18,2)
24236 WID2=WID2*WIDS(18,3)
24239 WDTP(I)=FUDGE*WDTP(I)
24240 WDTP(0)=WDTP(0)+WDTP(I)
24241 IF(MDME(IDC,1).GT.0) THEN
24242 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24243 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24244 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24245 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24249 ELSEIF(KFLA.EQ.18) THEN
24250 C...nu'_tau neutrino.
24251 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24252 DO 180 I=1,MDCY(KC,3)
24254 IF(MDME(IDC,1).LT.0) GOTO 180
24255 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24256 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24257 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
24260 C...nu'_tau -> W + tau'.
24261 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24262 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24265 WID2=WID2*WIDS(17,2)
24268 WID2=WID2*WIDS(17,3)
24270 ELSEIF(I.EQ.3) THEN
24271 C...nu'_tau -> H + tau'.
24272 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24273 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24276 WID2=WID2*WIDS(17,2)
24279 WID2=WID2*WIDS(17,3)
24282 WDTP(I)=FUDGE*WDTP(I)
24283 WDTP(0)=WDTP(0)+WDTP(I)
24284 IF(MDME(IDC,1).GT.0) THEN
24285 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24286 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24287 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24288 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24292 ELSEIF(KFLA.EQ.21) THEN
24294 C***Note that widths are not given in dimensional quantities here.
24295 DO 190 I=1,MDCY(KC,3)
24297 IF(MDME(IDC,1).LT.0) GOTO 190
24298 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24299 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24300 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
24303 C...QCD -> q + qbar
24304 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24305 IF(I.EQ.6) WID2=WIDS(6,1)
24306 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24308 WDTP(I)=FUDGE*WDTP(I)
24309 WDTP(0)=WDTP(0)+WDTP(I)
24310 IF(MDME(IDC,1).GT.0) THEN
24311 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24312 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24313 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24314 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24318 ELSEIF(KFLA.EQ.22) THEN
24320 C***Note that widths are not given in dimensional quantities here.
24321 DO 200 I=1,MDCY(KC,3)
24323 IF(MDME(IDC,1).LT.0) GOTO 200
24324 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24325 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24326 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
24329 C...QED -> q + qbar.
24332 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
24333 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24334 IF(I.EQ.6) WID2=WIDS(6,1)
24335 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24336 ELSEIF(I.LE.12) THEN
24337 C...QED -> l+ + l-.
24338 EF=KCHG(9+2*(I-8),1)/3D0
24339 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24340 IF(I.EQ.12) WID2=WIDS(17,1)
24342 WDTP(I)=FUDGE*WDTP(I)
24343 WDTP(0)=WDTP(0)+WDTP(I)
24344 IF(MDME(IDC,1).GT.0) THEN
24345 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24346 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24347 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24348 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24352 ELSEIF(KFLA.EQ.23) THEN
24355 XWC=1D0/(16D0*XW*XW1)
24356 FAC=(AEM*XWC/3D0)*SHR
24358 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
24363 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24365 IF(KFI.GT.20) KFI=IABS(MINT(16))
24371 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
24372 IF(MSTP(43).EQ.3) VINT(112)=
24373 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
24374 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
24375 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
24377 DO 220 I=1,MDCY(KC,3)
24379 IF(MDME(IDC,1).LT.0) GOTO 220
24380 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24381 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24382 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
24387 AF=SIGN(1D0,EF+0.1D0)
24390 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
24391 IF(I.EQ.6) WID2=WIDS(6,1)
24392 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24393 ELSEIF(I.LE.16) THEN
24394 C...Z0 -> l+ + l-, nu + nubar
24396 AF=SIGN(1D0,EF+0.1D0)
24399 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
24401 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
24402 IF(ICASE.EQ.1) THEN
24403 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
24405 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24406 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
24407 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
24408 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
24409 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
24410 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
24411 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
24412 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24414 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
24415 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
24416 IF(MDME(IDC,1).GT.0) THEN
24417 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
24418 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
24419 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24420 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
24421 & WDTE(I,MDME(IDC,1))
24422 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24423 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24425 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
24426 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
24427 & VINT(111)+FGGF*WID2
24428 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
24429 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
24430 & VINT(114)+FZZF*WID2
24434 IF(MINT(61).GE.1) ICASE=3-ICASE
24435 IF(ICASE.EQ.2) GOTO 210
24437 ELSEIF(KFLA.EQ.24) THEN
24439 FAC=(AEM/(24D0*XW))*SHR
24440 DO 230 I=1,MDCY(KC,3)
24442 IF(MDME(IDC,1).LT.0) GOTO 230
24443 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24444 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24445 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
24448 C...W+/- -> q + qbar'
24449 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
24451 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
24452 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
24453 IF(I.GE.13) WID2=WID2*WIDS(7,3)
24455 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
24456 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
24457 IF(I.GE.13) WID2=WID2*WIDS(7,2)
24459 ELSEIF(I.LE.20) THEN
24460 C...W+/- -> l+/- + nu
24463 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
24465 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
24468 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
24469 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24470 WDTP(I)=FUDGE*WDTP(I)
24471 WDTP(0)=WDTP(0)+WDTP(I)
24472 IF(MDME(IDC,1).GT.0) THEN
24473 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24474 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24475 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24476 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24480 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
24481 C...h0 (or H0, or A0):
24483 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
24484 DO 270 I=1,MDCY(KFHIGG,3)
24485 IDC=I+MDCY(KFHIGG,2)-1
24486 IF(MDME(IDC,1).LT.0) GOTO 270
24487 KFC1=PYCOMP(KFDP(IDC,1))
24488 KFC2=PYCOMP(KFDP(IDC,2))
24489 RM1=PMAS(KFC1,1)**2/SH
24490 RM2=PMAS(KFC2,1)**2/SH
24491 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
24497 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
24498 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
24499 C...A0 behaves like beta, ho and H0 like beta**3.
24500 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
24501 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24502 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
24503 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
24504 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
24505 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
24506 IF(IHIGG.NE.3) THEN
24507 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24508 & PARU(151+10*IHIGG))**2
24512 IF(I.EQ.6) WID2=WIDS(6,1)
24513 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24514 ELSEIF(I.LE.12) THEN
24516 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
24517 C...A0 behaves like beta, ho and H0 like beta**3.
24518 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
24519 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
24520 & PARU(153+10*IHIGG)**2
24521 IF(I.EQ.12) WID2=WIDS(17,1)
24523 ELSEIF(I.EQ.13) THEN
24524 C...h0 -> g + g; quark loop contribution only
24527 DO 240 J=1,2*MSTP(1)
24528 EPS=(2D0*PMAS(J,1))**2/SH
24529 C...Loop integral; function of eps=4m^2/shat; different for A0.
24530 IF(EPS.LE.1D0) THEN
24531 IF(EPS.GT.1D-4) THEN
24533 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24535 RLN=LOG(4D0/EPS-2D0)
24537 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24538 PHIIM=0.5D0*PARU(1)*RLN
24540 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24543 IF(IHIGG.LE.2) THEN
24544 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
24545 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
24547 ETAREJ=-0.5D0*EPS*PHIRE
24548 ETAIMJ=-0.5D0*EPS*PHIIM
24550 C...Couplings (=1 for standard model Higgs).
24551 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24552 IF(MOD(J,2).EQ.1) THEN
24553 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
24554 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
24556 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
24557 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
24563 ETA2=ETARE**2+ETAIM**2
24564 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
24566 ELSEIF(I.EQ.14) THEN
24567 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
24571 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
24573 IF(J.LE.2*MSTP(1)) THEN
24575 EPS=(2D0*PMAS(J,1))**2/SH
24576 ELSEIF(J.LE.3*MSTP(1)) THEN
24577 JL=2*(J-2*MSTP(1))-1
24578 EJ=KCHG(10+JL,1)/3D0
24579 EPS=(2D0*PMAS(10+JL,1))**2/SH
24580 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24581 EPS=(2D0*PMAS(24,1))**2/SH
24583 EPS=(2D0*PMAS(37,1))**2/SH
24585 C...Loop integral; function of eps=4m^2/shat.
24586 IF(EPS.LE.1D0) THEN
24587 IF(EPS.GT.1D-4) THEN
24589 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24591 RLN=LOG(4D0/EPS-2D0)
24593 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24594 PHIIM=0.5D0*PARU(1)*RLN
24596 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24599 IF(J.LE.3*MSTP(1)) THEN
24600 C...Fermion loops: loop integral different for A0; charges.
24601 IF(IHIGG.LE.2) THEN
24602 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
24603 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
24605 PHIPRE=-0.5D0*EPS*PHIRE
24606 PHIPIM=-0.5D0*EPS*PHIIM
24608 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
24610 EJH=PARU(151+10*IHIGG)
24611 ELSEIF(J.LE.2*MSTP(1)) THEN
24613 EJH=PARU(152+10*IHIGG)
24616 EJH=PARU(153+10*IHIGG)
24618 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
24619 ETAREJ=EJC*EJH*PHIPRE
24620 ETAIMJ=EJC*EJH*PHIPIM
24621 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24622 C...W loops: loop integral and charges.
24623 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
24624 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
24625 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24626 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
24627 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
24630 C...Charged H loops: loop integral and charges.
24631 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
24632 & PARU(158+10*IHIGG+2*(IHIGG/3))
24633 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
24634 ETAIMJ=-EPS**2*PHIIM*FACHHH
24639 ETA2=ETARE**2+ETAIM**2
24640 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
24642 ELSEIF(I.EQ.15) THEN
24643 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
24647 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
24649 IF(J.LE.2*MSTP(1)) THEN
24651 AJ=SIGN(1D0,EJ+0.1D0)
24653 EPS=(2D0*PMAS(J,1))**2/SH
24654 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
24655 ELSEIF(J.LE.3*MSTP(1)) THEN
24656 JL=2*(J-2*MSTP(1))-1
24657 EJ=KCHG(10+JL,1)/3D0
24658 AJ=SIGN(1D0,EJ+0.1D0)
24660 EPS=(2D0*PMAS(10+JL,1))**2/SH
24661 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
24663 EPS=(2D0*PMAS(24,1))**2/SH
24664 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
24666 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
24667 IF(EPS.LE.1D0) THEN
24669 IF(EPS.GT.1D-4) THEN
24670 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24672 RLN=LOG(4D0/EPS-2D0)
24674 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24675 PHIIM=0.5D0*PARU(1)*RLN
24676 PSIRE=0.5D0*ROOT*RLN
24677 PSIIM=-0.5D0*ROOT*PARU(1)
24679 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24681 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
24684 IF(EPSP.LE.1D0) THEN
24685 ROOT=SQRT(1D0-EPSP)
24686 IF(EPSP.GT.1D-4) THEN
24687 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24689 RLN=LOG(4D0/EPSP-2D0)
24691 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
24692 PHIIMP=0.5D0*PARU(1)*RLN
24693 PSIREP=0.5D0*ROOT*RLN
24694 PSIIMP=-0.5D0*ROOT*PARU(1)
24696 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
24698 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
24701 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
24702 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
24703 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
24704 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
24705 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
24706 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
24707 IF(J.LE.3*MSTP(1)) THEN
24708 C...Fermion loops: loop integral different for A0; charges.
24709 IF(IHIGG.EQ.3) FXYRE=0D0
24710 IF(IHIGG.EQ.3) FXYIM=0D0
24711 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
24713 EJH=PARU(151+10*IHIGG)
24714 ELSEIF(J.LE.2*MSTP(1)) THEN
24716 EJH=PARU(152+10*IHIGG)
24719 EJH=PARU(153+10*IHIGG)
24721 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
24722 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
24723 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
24724 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24725 C...W loops: loop integral and charges.
24726 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
24727 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
24728 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
24729 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24730 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
24731 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
24734 C...Charged H loops: loop integral and charges.
24735 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
24736 & PARU(158+10*IHIGG+2*(IHIGG/3))
24737 ETAREJ=FACHHH*FXYRE
24738 ETAIMJ=FACHHH*FXYIM
24743 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
24744 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
24747 ELSEIF(I.LE.17) THEN
24748 C...h0 -> Z0 + Z0, W+ + W-
24749 PM1=PMAS(IABS(KFDP(IDC,1)),1)
24750 PG1=PMAS(IABS(KFDP(IDC,1)),2)
24751 IF(MINT(62).GE.1) THEN
24752 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
24753 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
24754 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
24755 MOFSV(IHIGG,I-15)=0
24756 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
24760 MOFSV(IHIGG,I-15)=1
24761 RMAS=SQRT(MAX(0D0,SH))
24762 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
24764 WIDWSV(IHIGG,I-15)=WIDW
24765 WID2SV(IHIGG,I-15)=WID2
24768 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
24769 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
24773 WIDW=WIDWSV(IHIGG,I-15)
24774 WID2=WID2SV(IHIGG,I-15)
24777 WDTP(I)=FAC*WIDW/(2D0*(18-I))
24778 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
24779 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
24780 & PARU(138+I+10*IHIGG)**2
24781 WID2=WID2*WIDS(7+I,1)
24783 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
24784 C...H0 -> Z0 + h0, A0-> Z0 + h0
24785 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
24786 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24787 IF(IHIGG.EQ.2) THEN
24788 WDTP(I)=WDTP(I)*PARU(179)**2
24789 ELSEIF(IHIGG.EQ.3) THEN
24790 WDTP(I)=WDTP(I)*PARU(186)**2
24792 WID2=WIDS(23,2)*WIDS(25,2)
24794 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
24795 C...H0 -> h0 + h0, A0-> h0 + h0
24796 WDTP(I)=FAC*0.25D0*
24797 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24798 IF(IHIGG.EQ.2) THEN
24799 WDTP(I)=WDTP(I)*PARU(176)**2
24800 ELSEIF(IHIGG.EQ.3) THEN
24801 WDTP(I)=WDTP(I)*PARU(169)**2
24804 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
24805 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
24806 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
24807 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24808 & *PARU(195+IHIGG)**2
24810 WID2=WIDS(24,2)*WIDS(37,3)
24811 ELSEIF(I.EQ.21) THEN
24812 WID2=WIDS(24,3)*WIDS(37,2)
24815 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
24817 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
24818 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24819 WID2=WIDS(36,2)*WIDS(23,2)
24821 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
24823 WDTP(I)=FAC*0.5D0*PARU(180)**2*
24824 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24825 WID2=WIDS(25,2)*WIDS(36,2)
24827 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
24829 WDTP(I)=FAC*0.25D0*PARU(177)**2*
24830 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24835 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
24838 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
24839 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
24840 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
24845 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
24847 IF(KFC2.EQ.KFC1) THEN
24851 IF(KFDP(IDC,1).LT.0) KSGN1=3
24853 IF(KFDP(IDC,2).LT.0) KSGN2=3
24854 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
24857 WDTP(I)=FUDGE*WDTP(I)
24858 WDTP(0)=WDTP(0)+WDTP(I)
24859 IF(MDME(IDC,1).GT.0) THEN
24860 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24861 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24862 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24863 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24867 ELSEIF(KFLA.EQ.32) THEN
24870 XWC=1D0/(16D0*XW*XW1)
24871 FAC=(AEM*XWC/3D0)*SHR
24874 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
24882 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24883 KFAI=IABS(MINT(15))
24884 EI=KCHG(KFAI,1)/3D0
24885 AI=SIGN(1D0,EI+0.1D0)
24888 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
24889 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
24890 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
24891 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
24892 VPI=PARU(119+2*KFAIC)
24893 API=PARU(120+2*KFAIC)
24894 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
24895 VPI=PARJ(178+2*KFAIC)
24896 API=PARJ(179+2*KFAIC)
24898 VPI=PARJ(186+2*KFAIC)
24899 API=PARJ(187+2*KFAIC)
24903 SQMZP=PMAS(32,1)**2
24905 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
24906 & MSTP(44).EQ.7) VINT(111)=1D0
24907 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
24908 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
24909 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
24910 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
24911 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
24912 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
24913 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
24914 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
24915 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
24916 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
24917 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
24919 DO 290 I=1,MDCY(KC,3)
24921 IF(MDME(IDC,1).LT.0) GOTO 290
24922 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24923 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24924 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
24928 C...Z'0 -> q + qbar
24930 AF=SIGN(1D0,EF+0.1D0)
24933 VPF=PARU(123-2*MOD(I,2))
24934 APF=PARU(124-2*MOD(I,2))
24935 ELSEIF(I.LE.4) THEN
24936 VPF=PARJ(182-2*MOD(I,2))
24937 APF=PARJ(183-2*MOD(I,2))
24939 VPF=PARJ(190-2*MOD(I,2))
24940 APF=PARJ(191-2*MOD(I,2))
24943 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
24944 & PYHFTH(SH,SH*RM1,1D0)
24945 IF(I.EQ.6) WID2=WIDS(6,1)
24946 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24947 ELSEIF(I.LE.16) THEN
24948 C...Z'0 -> l+ + l-, nu + nubar
24950 AF=SIGN(1D0,EF+0.1D0)
24953 VPF=PARU(127-2*MOD(I,2))
24954 APF=PARU(128-2*MOD(I,2))
24955 ELSEIF(I.LE.12) THEN
24956 VPF=PARJ(186-2*MOD(I,2))
24957 APF=PARJ(187-2*MOD(I,2))
24959 VPF=PARJ(194-2*MOD(I,2))
24960 APF=PARJ(195-2*MOD(I,2))
24963 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
24965 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
24966 IF(ICASE.EQ.1) THEN
24967 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24968 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
24969 & APF**2*(1D0-4D0*RM1))*BE34
24970 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24971 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
24972 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
24973 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
24974 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
24975 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
24976 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
24977 ELSEIF(MINT(61).EQ.2) THEN
24978 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
24979 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
24980 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
24981 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24982 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
24984 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
24987 ELSEIF(I.EQ.17) THEN
24989 WDTPZP=PARU(129)**2*XW1**2*
24990 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24991 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
24992 IF(ICASE.EQ.1) THEN
24995 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24996 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
24997 ELSEIF(MINT(61).EQ.2) THEN
25006 ELSEIF(I.EQ.18) THEN
25008 CZC=2D0*(1D0-2D0*XW)
25009 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25010 IF(ICASE.EQ.1) THEN
25011 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
25012 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
25013 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25014 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
25015 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
25016 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
25017 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
25018 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
25019 ELSEIF(MINT(61).EQ.2) THEN
25021 FGZF=0.25D0*PARU(142)*CZC*BE34C
25022 FGZPF=0.25D0*PARU(143)*CZC*BE34C
25023 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
25024 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
25025 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
25028 ELSEIF(I.EQ.19) THEN
25029 C...Z'0 -> Z0 + gamma.
25030 ELSEIF(I.EQ.20) THEN
25032 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25033 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
25034 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
25035 IF(ICASE.EQ.1) THEN
25038 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25039 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25040 ELSEIF(MINT(61).EQ.2) THEN
25048 WID2=WIDS(23,2)*WIDS(25,2)
25049 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
25050 C...Z' -> h0 + A0 or H0 + A0.
25051 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25059 IF(ICASE.EQ.1) THEN
25060 WDTPZ=CZAH**2*BE34C
25061 WDTP(I)=FAC*CZPAH**2*BE34C
25062 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25063 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
25064 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
25066 ELSEIF(MINT(61).EQ.2) THEN
25071 FZZPF=CZAH*CZPAH*BE34C
25072 FZPZPF=CZPAH**2*BE34C
25074 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
25075 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
25077 IF(ICASE.EQ.1) THEN
25078 VINT(117)=VINT(117)+FAC*WDTPZ
25079 WDTP(I)=FUDGE*WDTP(I)
25080 WDTP(0)=WDTP(0)+WDTP(I)
25082 IF(MDME(IDC,1).GT.0) THEN
25083 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25084 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25085 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25086 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25087 & WDTE(I,MDME(IDC,1))
25088 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25089 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25091 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25092 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25093 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
25094 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
25096 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
25098 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25099 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
25100 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
25102 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25103 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
25107 IF(MINT(61).GE.1) ICASE=3-ICASE
25108 IF(ICASE.EQ.2) GOTO 280
25110 ELSEIF(KFLA.EQ.34) THEN
25112 FAC=(AEM/(24D0*XW))*SHR
25113 DO 300 I=1,MDCY(KC,3)
25115 IF(MDME(IDC,1).LT.0) GOTO 300
25116 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25117 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25118 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
25122 C...W'+/- -> q + qbar'
25123 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
25124 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
25126 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25127 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25128 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25130 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25131 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25132 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25134 ELSEIF(I.LE.20) THEN
25135 C...W'+/- -> l+/- + nu
25136 FCOF=PARU(133)**2+PARU(134)**2
25138 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25140 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25143 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
25144 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25145 ELSEIF(I.EQ.21) THEN
25146 C...W'+/- -> W+/- + Z0
25147 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
25148 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25149 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25150 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
25151 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
25152 ELSEIF(I.EQ.23) THEN
25153 C...W'+/- -> W+/- + h0
25154 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25155 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
25156 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25157 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25159 WDTP(I)=FUDGE*WDTP(I)
25160 WDTP(0)=WDTP(0)+WDTP(I)
25161 IF(MDME(IDC,1).GT.0) THEN
25162 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25163 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25164 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25165 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25169 ELSEIF(KFLA.EQ.37) THEN
25171 C IF(MSTP(49).EQ.0) THEN
25174 C SHFS=PMAS(37,1)**2
25176 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25177 DO 310 I=1,MDCY(KC,3)
25179 IF(MDME(IDC,1).LT.0) GOTO 310
25180 KFC1=PYCOMP(KFDP(IDC,1))
25181 KFC2=PYCOMP(KFDP(IDC,2))
25182 RM1=PMAS(KFC1,1)**2/SH
25183 RM2=PMAS(KFC2,1)**2/SH
25184 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
25187 C...H+/- -> q + qbar'
25188 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
25189 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25190 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
25191 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
25192 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25194 IF(I.EQ.3) WID2=WIDS(6,2)
25195 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
25197 IF(I.EQ.3) WID2=WIDS(6,3)
25198 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
25200 ELSEIF(I.LE.8) THEN
25201 C...H+/- -> l+/- + nu
25202 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
25203 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
25204 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25206 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
25208 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
25210 ELSEIF(I.EQ.9) THEN
25211 C...H+/- -> W+/- + h0.
25212 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
25213 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25214 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25215 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25219 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25222 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25223 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25224 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25229 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25232 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
25234 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
25235 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25237 WDTP(I)=FUDGE*WDTP(I)
25238 WDTP(0)=WDTP(0)+WDTP(I)
25239 IF(MDME(IDC,1).GT.0) THEN
25240 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25241 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25242 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25243 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25247 ELSEIF(KFLA.EQ.41) THEN
25249 FAC=(AEM/(12D0*XW))*SHR
25250 DO 320 I=1,MDCY(KC,3)
25252 IF(MDME(IDC,1).LT.0) GOTO 320
25253 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25254 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25255 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
25260 ELSEIF(I.LE.9) THEN
25264 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25265 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25267 IF(I.EQ.4) WID2=WIDS(6,3)
25268 IF(I.EQ.5) WID2=WIDS(7,3)
25269 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
25270 IF(I.EQ.9) WID2=WIDS(17,3)
25272 IF(I.EQ.4) WID2=WIDS(6,2)
25273 IF(I.EQ.5) WID2=WIDS(7,2)
25274 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
25275 IF(I.EQ.9) WID2=WIDS(17,2)
25277 WDTP(I)=FUDGE*WDTP(I)
25278 WDTP(0)=WDTP(0)+WDTP(I)
25279 IF(MDME(IDC,1).GT.0) THEN
25280 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25281 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25282 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25283 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25287 ELSEIF(KFLA.EQ.42) THEN
25288 C...LQ (leptoquark).
25289 FAC=(AEM/4D0)*PARU(151)*SHR
25290 DO 330 I=1,MDCY(KC,3)
25292 IF(MDME(IDC,1).LT.0) GOTO 330
25293 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25294 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25295 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
25296 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25298 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
25299 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
25300 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
25301 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
25302 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
25303 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
25304 WDTP(I)=FUDGE*WDTP(I)
25305 WDTP(0)=WDTP(0)+WDTP(I)
25306 IF(MDME(IDC,1).GT.0) THEN
25307 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25308 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25309 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25310 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25314 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
25315 C...Techni-pi0 and techni-pi0':
25316 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
25317 DO 340 I=1,MDCY(KC,3)
25319 IF(MDME(IDC,1).LT.0) GOTO 340
25320 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25321 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
25324 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
25328 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
25329 & /(8D0*PARU(1))*SH*SHR
25330 IF(KFLA.EQ.KTECHN+111) THEN
25337 C...pi_tc -> f + fbar.
25339 IKA=IABS(KFDP(IDC,1))
25340 IF(IKA.LT.10) FCOF=3D0*RADC
25343 IF(IKA.GE.4.AND.IKA.LE.6) THEN
25344 FCOF=FCOF*RTCM(1+IKA)**2
25345 HM1=PYMRUN(KFDP(IDC,1),SH)
25346 HM2=PYMRUN(KFDP(IDC,2),SH)
25347 ELSEIF(IKA.EQ.15) THEN
25348 FCOF=FCOF*RTCM(8)**2
25350 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
25351 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25353 WDTP(I)=FUDGE*WDTP(I)
25354 WDTP(0)=WDTP(0)+WDTP(I)
25355 IF(MDME(IDC,1).GT.0) THEN
25356 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25357 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25358 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25359 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25363 ELSEIF(KFLA.EQ.KTECHN+211) THEN
25365 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
25366 DO 350 I=1,MDCY(KC,3)
25368 IF(MDME(IDC,1).LT.0) GOTO 350
25369 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25370 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
25372 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
25376 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
25378 C...pi_tc -> f + f'.
25380 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
25381 C...pi_tc+ -> W b b~
25382 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
25384 XMT2=PMAS(6,1)**2/SH
25385 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
25386 KFC3=PYCOMP(KFDP(IDC,3))
25387 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
25389 T0 = (1D0-CHECK**2)*
25390 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
25391 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
25392 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
25393 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
25394 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
25395 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
25404 IKA=IABS(KFDP(IDC,1))
25405 IF(IKA.LT.10) FCOF=3D0*RADC
25408 IF(I.GE.1.AND.I.LE.5) THEN
25410 FCOF=FCOF*RTCM(5)**2
25411 ELSEIF(I.LE.4) THEN
25412 FCOF=FCOF*RTCM(6)**2
25413 ELSEIF(I.EQ.5) THEN
25414 FCOF=FCOF*RTCM(7)**2
25416 HM1=PYMRUN(KFDP(IDC,1),SH)
25417 HM2=PYMRUN(KFDP(IDC,2),SH)
25418 ELSEIF(I.EQ.8) THEN
25419 FCOF=FCOF*RTCM(8)**2
25421 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
25422 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25424 WDTP(I)=FUDGE*WDTP(I)
25425 WDTP(0)=WDTP(0)+WDTP(I)
25426 IF(MDME(IDC,1).GT.0) THEN
25427 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25428 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25429 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25430 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25434 ELSEIF(KFLA.EQ.KTECHN+331) THEN
25436 FAC=(SH/PARP(46)**2)*SHR
25437 DO 360 I=1,MDCY(KC,3)
25439 IF(MDME(IDC,1).LT.0) GOTO 360
25440 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25441 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25442 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
25445 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
25446 IF(I.EQ.2) WID2=WIDS(6,1)
25448 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
25450 WDTP(I)=FUDGE*WDTP(I)
25451 WDTP(0)=WDTP(0)+WDTP(I)
25452 IF(MDME(IDC,1).GT.0) THEN
25453 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25454 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25455 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25456 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25460 ELSEIF(KFLA.EQ.KTECHN+113) THEN
25462 ALPRHT=2.16D0*(3D0/ITCM(1))
25463 FAC=(ALPRHT/12D0)*SHR
25464 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
25468 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
25470 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
25471 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25472 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25473 DO 370 I=1,MDCY(KC,3)
25475 IF(MDME(IDC,1).LT.0) GOTO 370
25476 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25477 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25478 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
25481 C...rho_tc0 -> W+ + W-.
25482 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
25483 WDTP(I)=FAC*RTCM(3)**4*
25484 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25485 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25486 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
25487 & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
25489 ELSEIF(I.EQ.2) THEN
25490 C...rho_tc0 -> W+ + pi_tc-.
25491 C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
25492 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25493 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25494 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25495 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
25496 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
25497 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
25498 ELSEIF(I.EQ.3) THEN
25499 C...rho_tc0 -> pi_tc+ + W-.
25500 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25501 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25502 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25503 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
25504 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
25505 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
25506 ELSEIF(I.EQ.4) THEN
25507 C...rho_tc0 -> pi_tc+ + pi_tc-.
25508 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
25509 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25510 WID2=WIDS(PYCOMP(KTECHN+211),1)
25511 ELSEIF(I.EQ.5) THEN
25512 C...rho_tc0 -> gamma + pi_tc0
25513 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25514 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25516 WID2=WIDS(PYCOMP(KTECHN+111),2)
25517 ELSEIF(I.EQ.6) THEN
25518 C...rho_tc0 -> gamma + pi_tc0'
25519 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25520 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
25521 WID2=WIDS(PYCOMP(KTECHN+221),2)
25522 ELSEIF(I.EQ.7) THEN
25523 C...rho_tc0 -> Z0 + pi_tc0
25524 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25525 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25527 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
25528 ELSEIF(I.EQ.8) THEN
25529 C...rho_tc0 -> Z0 + pi_tc0'
25530 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25531 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
25533 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
25534 ELSEIF(I.EQ.9) THEN
25535 C...rho_tc0 -> gamma + Z0
25536 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25537 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
25539 ELSEIF(I.EQ.10) THEN
25540 C...rho_tc0 -> Z0 + Z0
25541 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25542 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
25546 C...rho_tc0 -> f + fbar.
25551 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
25555 IF(IA.GE.17) WID2=WIDS(IA,1)
25558 AI=SIGN(1D0,EI+0.1D0)
25562 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
25563 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
25564 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
25565 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
25567 WDTP(I)=FUDGE*WDTP(I)
25568 WDTP(0)=WDTP(0)+WDTP(I)
25569 IF(MDME(IDC,1).GT.0) THEN
25570 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25571 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25572 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25573 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25577 ELSEIF(KFLA.EQ.KTECHN+213) THEN
25579 ALPRHT=2.16D0*(3D0/ITCM(1))
25580 FAC=(ALPRHT/12D0)*SHR
25584 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
25586 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
25587 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
25588 DO 380 I=1,MDCY(KC,3)
25590 IF(MDME(IDC,1).LT.0) GOTO 380
25591 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25592 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25593 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
25595 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25596 c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
25599 C...rho_tc+ -> W+ + Z0.
25601 WDTP(I)=FAC*RTCM(3)**4*
25602 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25603 VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
25604 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
25606 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
25609 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
25611 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
25614 WID2=WIDS(24,2)*WIDS(23,2)
25616 WID2=WIDS(24,3)*WIDS(23,2)
25618 ELSEIF(I.EQ.2) THEN
25619 C...rho_tc+ -> W+ + pi_tc0.
25620 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25621 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25622 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25623 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
25624 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
25626 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
25628 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
25630 ELSEIF(I.EQ.3) THEN
25631 C...rho_tc+ -> pi_tc+ + Z0.
25632 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25633 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25634 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25635 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
25636 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
25637 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25638 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25641 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
25643 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
25645 ELSEIF(I.EQ.4) THEN
25646 C...rho_tc+ -> pi_tc+ + pi_tc0.
25647 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
25648 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25650 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
25652 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
25654 ELSEIF(I.EQ.5) THEN
25655 C...rho_tc+ -> pi_tc+ + gamma
25656 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25657 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25660 WID2=WIDS(PYCOMP(KTECHN+211),2)
25662 WID2=WIDS(PYCOMP(KTECHN+211),3)
25664 ELSEIF(I.EQ.6) THEN
25665 C...rho_tc+ -> W+ + pi_tc0'
25666 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25667 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
25669 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
25671 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
25673 ELSEIF(I.EQ.7) THEN
25674 C...rho_tc+ -> W+ + gamma
25675 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25676 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
25683 C...rho_tc+ -> f + fbar'.
25687 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
25689 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
25690 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
25691 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
25693 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
25694 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
25695 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
25700 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25702 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25705 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25706 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25708 WDTP(I)=FUDGE*WDTP(I)
25709 WDTP(0)=WDTP(0)+WDTP(I)
25710 IF(MDME(IDC,1).GT.0) THEN
25711 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25712 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25713 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25714 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25718 ELSEIF(KFLA.EQ.KTECHN+223) THEN
25720 ALPRHT=2.16D0*(3D0/ITCM(1))
25721 FAC=(ALPRHT/12D0)*SHR
25722 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
25725 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
25727 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25728 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25729 DO 390 I=1,MDCY(KC,3)
25731 IF(MDME(IDC,1).LT.0) GOTO 390
25732 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25733 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25734 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
25737 C...omega_tc0 -> gamma + pi_tc0.
25738 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
25739 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
25740 WID2=WIDS(PYCOMP(KTECHN+111),2)
25741 ELSEIF(I.EQ.2) THEN
25742 C...omega_tc0 -> Z0 + pi_tc0
25743 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25744 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
25746 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
25747 ELSEIF(I.EQ.3) THEN
25748 C...omega_tc0 -> gamma + pi_tc0'
25749 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25750 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
25752 WID2=WIDS(PYCOMP(KTECHN+221),2)
25753 ELSEIF(I.EQ.4) THEN
25754 C...omega_tc0 -> Z0 + pi_tc0'
25755 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25756 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
25758 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
25759 ELSEIF(I.EQ.5) THEN
25760 C...omega_tc0 -> W+ + pi_tc-
25761 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25762 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
25763 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
25764 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25765 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
25766 ELSEIF(I.EQ.6) THEN
25767 C...omega_tc0 -> pi_tc+ + W-
25768 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25769 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
25770 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
25771 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25772 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
25773 ELSEIF(I.EQ.7) THEN
25774 C...omega_tc0 -> W+ + W-.
25775 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
25776 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
25777 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25778 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25779 & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
25781 ELSEIF(I.EQ.8) THEN
25782 C...omega_tc0 -> pi_tc+ + pi_tc-.
25783 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
25784 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25785 WID2=WIDS(PYCOMP(KTECHN+211),1)
25786 C...omega_tc0 -> gamma + Z0
25787 ELSEIF(I.EQ.9) THEN
25788 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25789 & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
25791 C...omega_tc0 -> Z0 + Z0
25792 ELSEIF(I.EQ.10) THEN
25793 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25794 & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
25795 & /24D0/RTCM(12)**2*SHR**3
25798 C...omega_tc0 -> f + fbar.
25803 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
25807 IF(IA.GE.17) WID2=WIDS(IA,1)
25810 AI=SIGN(1D0,EI+0.1D0)
25812 VALI=-0.5D0*(VI+AI)
25813 VARI=-0.5D0*(VI-AI)
25814 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
25815 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
25816 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
25817 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
25819 WDTP(I)=FUDGE*WDTP(I)
25820 WDTP(0)=WDTP(0)+WDTP(I)
25821 IF(MDME(IDC,1).GT.0) THEN
25822 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25823 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25824 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25825 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25829 C.....V8 -> quark anti-quark
25830 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
25833 IF(ITCM(2).EQ.0) THEN
25835 ELSEIF(ITCM(2).EQ.1) THEN
25838 DO 400 I=1,MDCY(KC,3)
25840 IF(MDME(IDC,1).LT.0) GOTO 400
25841 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25843 IF(RM1.GT.0.25D0) GOTO 400
25845 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
25850 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
25851 IF(I.EQ.6) WID2=WIDS(6,1)
25852 WDTP(I)=FUDGE*WDTP(I)
25853 WDTP(0)=WDTP(0)+WDTP(I)
25854 IF(MDME(IDC,1).GT.0) THEN
25855 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25856 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25857 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25858 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25862 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
25863 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
25865 DO 410 I=1,MDCY(KC,3)
25867 IF(MDME(IDC,1).LT.0) GOTO 410
25868 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25869 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25870 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
25874 IF(KFLA.EQ.KTECHN+100111) THEN
25879 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
25880 & /(2D0*PARU(1))*SH*SHR*CLEBG
25883 C...pi_tc -> f + fbar.
25884 IF(I.EQ.6) WID2=WIDS(6,1)
25886 IKA=IABS(KFDP(IDC,1))
25887 IF(IKA.LT.10) FCOF=3D0*RADC
25888 HM1=PYMRUN(KFDP(IDC,1),SH)
25889 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
25890 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25892 WDTP(I)=FUDGE*WDTP(I)
25893 WDTP(0)=WDTP(0)+WDTP(I)
25894 IF(MDME(IDC,1).GT.0) THEN
25895 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25896 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25897 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25898 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25902 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
25904 ALPRHT=2.16D0*(3D0/ITCM(1))
25906 SIN2T=2D0*TANT3/(TANT3**2+1D0)
25907 SINT3=TANT3/SQRT(TANT3**2+1D0)
25910 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
25911 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
25912 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
25913 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
25914 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
25916 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
25918 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
25920 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
25922 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
25923 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
25924 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
25925 IF(ITCM(2).EQ.0) THEN
25930 DO 420 I=1,MDCY(KC,3)
25931 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
25932 & KFLA.EQ.KTECHN+300113)) GOTO 420
25934 IF(MDME(IDC,1).LT.0) GOTO 420
25935 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25936 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25937 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
25940 IF(I.EQ.6) WID2=WIDS(6,1)
25942 IF(KFLA.EQ.KTECHN+200113) THEN
25945 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
25948 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
25953 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
25954 FMIX=1D0/TANT3/SIN2T
25958 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
25959 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
25960 ELSEIF(I.EQ.7) THEN
25961 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
25962 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
25963 PSH=SHR*(1D0-RM1)/2D0
25964 WDTP(I)=AS/9D0*PSH**3/RM82
25966 WDTP(I)=2D0*WDTP(I)*CSXPP**2
25967 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
25969 WDTP(I)=5D0*WDTP(I)
25970 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
25973 WDTP(I)=FUDGE*WDTP(I)
25974 WDTP(0)=WDTP(0)+WDTP(I)
25975 IF(MDME(IDC,1).GT.0) THEN
25976 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25977 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25978 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25979 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25983 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
25984 C...d* excited quark.
25985 FAC=(SH/RTCM(41)**2)*SHR
25986 DO 430 I=1,MDCY(KC,3)
25988 IF(MDME(IDC,1).LT.0) GOTO 430
25989 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25990 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25991 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
25995 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
25997 ELSEIF(I.EQ.2) THEN
25998 C...d* -> gamma + d.
25999 QF=-RTCM(43)/2D0+RTCM(44)/6D0
26000 WDTP(I)=FAC*AEM*QF**2/4D0
26002 ELSEIF(I.EQ.3) THEN
26004 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26005 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26006 & (1D0-RM1)**2*(2D0+RM1)
26008 ELSEIF(I.EQ.4) THEN
26010 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26011 & (1D0-RM1)**2*(2D0+RM1)
26012 IF(KFLR.GT.0) WID2=WIDS(24,3)
26013 IF(KFLR.LT.0) WID2=WIDS(24,2)
26015 WDTP(I)=FUDGE*WDTP(I)
26016 WDTP(0)=WDTP(0)+WDTP(I)
26017 IF(MDME(IDC,1).GT.0) THEN
26018 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26019 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26020 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26021 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26025 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
26026 C...u* excited quark.
26027 FAC=(SH/RTCM(41)**2)*SHR
26028 DO 440 I=1,MDCY(KC,3)
26030 IF(MDME(IDC,1).LT.0) GOTO 440
26031 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26032 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26033 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
26037 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26039 ELSEIF(I.EQ.2) THEN
26040 C...u* -> gamma + u.
26041 QF=RTCM(43)/2D0+RTCM(44)/6D0
26042 WDTP(I)=FAC*AEM*QF**2/4D0
26044 ELSEIF(I.EQ.3) THEN
26046 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26047 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26048 & (1D0-RM1)**2*(2D0+RM1)
26050 ELSEIF(I.EQ.4) THEN
26052 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26053 & (1D0-RM1)**2*(2D0+RM1)
26054 IF(KFLR.GT.0) WID2=WIDS(24,2)
26055 IF(KFLR.LT.0) WID2=WIDS(24,3)
26057 WDTP(I)=FUDGE*WDTP(I)
26058 WDTP(0)=WDTP(0)+WDTP(I)
26059 IF(MDME(IDC,1).GT.0) THEN
26060 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26061 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26062 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26063 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26067 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
26068 C...e* excited lepton.
26069 FAC=(SH/RTCM(41)**2)*SHR
26070 DO 450 I=1,MDCY(KC,3)
26072 IF(MDME(IDC,1).LT.0) GOTO 450
26073 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26074 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26075 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
26078 C...e* -> gamma + e.
26079 QF=-RTCM(43)/2D0-RTCM(44)/2D0
26080 WDTP(I)=FAC*AEM*QF**2/4D0
26082 ELSEIF(I.EQ.2) THEN
26084 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26085 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26086 & (1D0-RM1)**2*(2D0+RM1)
26088 ELSEIF(I.EQ.3) THEN
26090 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26091 & (1D0-RM1)**2*(2D0+RM1)
26092 IF(KFLR.GT.0) WID2=WIDS(24,3)
26093 IF(KFLR.LT.0) WID2=WIDS(24,2)
26095 WDTP(I)=FUDGE*WDTP(I)
26096 WDTP(0)=WDTP(0)+WDTP(I)
26097 IF(MDME(IDC,1).GT.0) THEN
26098 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26099 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26100 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26101 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26105 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
26106 C...nu*_e excited neutrino.
26107 FAC=(SH/RTCM(41)**2)*SHR
26108 DO 460 I=1,MDCY(KC,3)
26110 IF(MDME(IDC,1).LT.0) GOTO 460
26111 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26112 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26113 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
26116 C...nu*_e -> Z0 + nu*_e.
26117 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26118 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26119 & (1D0-RM1)**2*(2D0+RM1)
26121 ELSEIF(I.EQ.2) THEN
26122 C...nu*_e -> W+ + e.
26123 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26124 & (1D0-RM1)**2*(2D0+RM1)
26125 IF(KFLR.GT.0) WID2=WIDS(24,2)
26126 IF(KFLR.LT.0) WID2=WIDS(24,3)
26128 WDTP(I)=FUDGE*WDTP(I)
26129 WDTP(0)=WDTP(0)+WDTP(I)
26130 IF(MDME(IDC,1).GT.0) THEN
26131 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26132 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26133 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26134 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26138 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
26139 C...G* (graviton resonance):
26140 FAC=(PARP(50)**2/PARU(1))*SHR
26141 DO 470 I=1,MDCY(KC,3)
26143 IF(MDME(IDC,1).LT.0) GOTO 470
26144 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26145 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26146 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
26151 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
26152 & PYHFTH(SH,SH*RM1,1D0)
26153 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
26154 & (1D0+8D0*RM1/3D0)/320D0
26155 IF(I.EQ.6) WID2=WIDS(6,1)
26156 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
26157 ELSEIF(I.LE.16) THEN
26158 C...G* -> l+ + l-, nu + nubar
26160 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
26161 & (1D0+8D0*RM1/3D0)/320D0
26162 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
26163 ELSEIF(I.EQ.17) THEN
26166 ELSEIF(I.EQ.18) THEN
26167 C...G* -> gamma + gamma.
26169 ELSEIF(I.EQ.19) THEN
26171 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
26172 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
26174 ELSEIF(I.EQ.20) THEN
26176 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
26177 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
26180 WDTP(I)=FUDGE*WDTP(I)
26181 WDTP(0)=WDTP(0)+WDTP(I)
26182 IF(MDME(IDC,1).GT.0) THEN
26183 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26184 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26185 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26186 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26190 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
26191 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
26192 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
26193 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
26194 DO 480 I=1,MDCY(KC,3)
26196 IF(MDME(IDC,1).LT.0) GOTO 480
26197 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26198 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26199 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26200 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
26203 C...nu_lR -> l- qbar q'
26204 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
26205 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
26206 ELSEIF(I.LE.18) THEN
26207 C...nu_lR -> l+ q qbar'
26208 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
26209 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
26211 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
26213 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
26215 X=(PM1+PM2+PM3)/SHR
26216 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
26218 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
26219 WDTP(I)=FAC*FCOF*FX*FY
26220 WDTP(I)=FUDGE*WDTP(I)
26221 WDTP(0)=WDTP(0)+WDTP(I)
26222 IF(MDME(IDC,1).GT.0) THEN
26223 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26224 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26225 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26226 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26230 ELSEIF(KFLA.EQ.9900023) THEN
26232 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
26233 DO 490 I=1,MDCY(KC,3)
26235 IF(MDME(IDC,1).LT.0) GOTO 490
26236 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26237 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26238 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
26242 C...Z_R0 -> q + qbar
26244 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
26245 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
26247 IF(I.EQ.6) WID2=WIDS(6,1)
26248 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
26249 C...Z_R0 -> l+ + l-
26253 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
26254 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
26259 ELSEIF(I.LE.15) THEN
26260 C...Z0 -> nu_R + nu_R, assumed Majorana.
26264 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
26267 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
26268 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
26269 WDTP(I)=FUDGE*WDTP(I)
26270 WDTP(0)=WDTP(0)+WDTP(I)
26271 IF(MDME(IDC,1).GT.0) THEN
26272 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26273 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26274 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26275 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26279 ELSEIF(KFLA.EQ.9900024) THEN
26281 FAC=(AEM/(24D0*XW))*SHR
26282 DO 500 I=1,MDCY(KC,3)
26284 IF(MDME(IDC,1).LT.0) GOTO 500
26285 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26286 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26287 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
26290 C...W_R+/- -> q + qbar'
26291 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
26293 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
26295 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
26297 ELSEIF(I.LE.12) THEN
26298 C...W_R+/- -> l+/- + nu_R
26301 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26302 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26303 WDTP(I)=FUDGE*WDTP(I)
26304 WDTP(0)=WDTP(0)+WDTP(I)
26305 IF(MDME(IDC,1).GT.0) THEN
26306 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26307 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26308 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26309 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26313 ELSEIF(KFLA.EQ.9900041) THEN
26315 FAC=(1D0/(8D0*PARU(1)))*SHR
26316 DO 510 I=1,MDCY(KC,3)
26318 IF(MDME(IDC,1).LT.0) GOTO 510
26319 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26320 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26321 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
26324 C...H_L++/-- -> l+/- + l'+/-
26325 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
26326 & (IABS(KFDP(IDC,2))-9)/2)**2
26327 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
26328 ELSEIF(I.EQ.7) THEN
26329 C...H_L++/-- -> W_L+/- + W_L+/-
26330 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
26331 & (3D0*RM1+0.25D0/RM1-1D0)
26332 WID2=WIDS(24,4+(1-KFLS)/2)
26335 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26336 WDTP(I)=FUDGE*WDTP(I)
26337 WDTP(0)=WDTP(0)+WDTP(I)
26338 IF(MDME(IDC,1).GT.0) THEN
26339 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26340 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26341 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26342 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26346 ELSEIF(KFLA.EQ.9900042) THEN
26348 FAC=(1D0/(8D0*PARU(1)))*SHR
26349 DO 520 I=1,MDCY(KC,3)
26351 IF(MDME(IDC,1).LT.0) GOTO 520
26352 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26353 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26354 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
26357 C...H_R++/-- -> l+/- + l'+/-
26358 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
26359 & (IABS(KFDP(IDC,2))-9)/2)**2
26360 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
26361 ELSEIF(I.EQ.7) THEN
26362 C...H_R++/-- -> W_R+/- + W_R+/-
26363 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
26364 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
26367 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26368 WDTP(I)=FUDGE*WDTP(I)
26369 WDTP(0)=WDTP(0)+WDTP(I)
26370 IF(MDME(IDC,1).GT.0) THEN
26371 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26372 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26373 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26374 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26378 ELSEIF(KFLA.EQ.KTECHN+115) THEN
26380 C...Need to update to alpha_rho
26381 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
26382 FAC=(ALPRHT/12D0)*SHR
26383 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26387 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26389 XWRHT=1D0/(4D0*XW*(1D0-XW))
26390 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26391 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26392 DO 530 I=1,MDCY(KC,3)
26394 IF(MDME(IDC,1).LT.0) GOTO 530
26395 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26396 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26397 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
26399 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26402 FACPA=PCM**2+1.5D0*RM1
26405 C...a2_tc0 -> W+ + W-
26407 AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
26408 C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
26410 C...a2_tc0 -> W+ + pi_tc- + c.c.
26411 ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
26412 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
26414 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26416 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
26418 ELSEIF(I.EQ.4) THEN
26419 C...a2_tc0 -> Z0 + pi_tc0'
26420 VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
26421 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26423 WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
26424 ELSEIF(I.GE.5.AND.I.LE.10) THEN
26425 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
26426 FACPA=PCM**2*(1D0+RM1+RM2)
26430 C...a_T^0 -> gamma rho_T^0
26431 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
26432 WID2=WIDS(PYCOMP(KTECHN+113),2)
26433 ELSEIF(I.EQ.6) THEN
26434 C...a_T^0 -> gamma omega_T
26435 VA2=1D0/RTCM(50)**4
26436 WID2=WIDS(PYCOMP(KTECHN+223),2)
26437 ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
26438 C...a_T^0 -> W^+- rho_T^-+
26439 AA2=.25D0/XW/RTCM(51)**4
26441 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
26443 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
26445 ELSEIF(I.EQ.9) THEN
26446 C...a_T^0 -> Z^0 rho_T^0
26447 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
26448 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
26449 ELSEIF(I.EQ.10) THEN
26450 C...a_T^0 -> Z^0 omega_T
26451 VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
26452 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
26454 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
26456 C...a2_tc0 -> f + fbar.
26461 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26465 IF(IA.GE.17) WID2=WIDS(IA,1)
26468 AI=SIGN(1D0,EI+0.1D0)
26472 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26473 & ((VALI*BWZR)**2+(VALI*BWZI)**2+
26474 & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26475 & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
26477 WDTP(I)=FUDGE*WDTP(I)
26478 WDTP(0)=WDTP(0)+WDTP(I)
26479 IF(MDME(IDC,1).GT.0) THEN
26480 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26481 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26482 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26483 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26487 ELSEIF(KFLA.EQ.KTECHN+215) THEN
26489 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
26490 FAC=(ALPRHT/12D0)*SHR
26494 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
26496 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
26497 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26498 DO 540 I=1,MDCY(KC,3)
26500 IF(MDME(IDC,1).LT.0) GOTO 540
26501 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26502 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26503 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
26505 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26514 C...a2_tc+ -> gamma + W+.
26516 AA2=RTCM(3)**2/RTCM(49)**2
26517 WID2=WIDS(24,ICHANN)
26518 C...a2_tc+ -> gamma + pi_tc+.
26519 ELSEIF(I.EQ.2) THEN
26520 AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
26521 WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
26522 C...a2_tc+ -> W+ + Z
26523 ELSEIF(I.EQ.3) THEN
26524 AA2=RTCM(3)**2*(1D0/4D0/XW1 +
26525 & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
26526 WID2=WIDS(24,ICHANN)*WIDS(23,2)
26527 C...a2_tc+ -> W+ + pi_tc0.
26528 ELSEIF(I.EQ.4) THEN
26529 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
26530 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
26531 C...a2_tc+ -> W+ + pi_tc'0.
26532 ELSEIF(I.EQ.5) THEN
26533 VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
26534 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
26535 C...a2_tc+ -> Z0 + pi_tc+.
26536 ELSEIF(I.EQ.6) THEN
26537 AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
26539 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
26541 WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26543 ELSEIF(I.LE.10) THEN
26544 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
26545 FACPA=PCM**2*(1D0+RM1+RM2)
26548 C...a2_tc+ -> gamma + rho_tc+
26550 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
26551 WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
26552 C...a2_tc+ -> W+ + rho_T^0
26553 ELSEIF(I.EQ.8) THEN
26554 AA2=1D0/(4D0*XW)/RTCM(51)**4
26555 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
26556 C...a2_tc+ -> W+ + omega_T
26557 ELSEIF(I.EQ.9) THEN
26558 VA2=.25D0/XW/RTCM(50)**4
26559 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
26560 C...a2_tc+ -> Z^0 + rho_T^+
26561 ELSEIF(I.EQ.10) THEN
26562 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
26563 AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
26564 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
26566 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
26568 C...a2_tc+ -> f + fbar'.
26572 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
26574 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
26575 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
26576 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
26578 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
26579 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
26580 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
26585 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26587 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26590 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26591 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26593 WDTP(I)=FUDGE*WDTP(I)
26594 WDTP(0)=WDTP(0)+WDTP(I)
26595 IF(MDME(IDC,1).GT.0) THEN
26596 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26597 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26598 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26599 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26610 C***********************************************************************
26613 C...Calculates partial width and differential cross-section maxima
26614 C...of channels/processes not allowed on mass-shell, and selects
26615 C...masses in such channels/processes.
26617 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
26619 C...Double precision and integer declarations.
26620 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26621 IMPLICIT INTEGER(I-N)
26622 INTEGER PYK,PYCHGE,PYCOMP
26624 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26625 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26626 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
26627 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
26628 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26629 COMMON/PYINT1/MINT(400),VINT(400)
26630 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
26631 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
26632 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
26635 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
26636 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
26637 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
26640 C...Find if particles equal, maximum mass, matrix elements, etc.
26646 IF(KFD(1).EQ.KFD(2)) MEQL=1
26648 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
26649 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
26655 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
26658 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
26659 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
26660 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
26661 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
26662 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
26663 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
26666 C...Find where Breit-Wigners are required, else select discrete masses.
26668 KFCA=PYCOMP(KFD(I))
26670 PMD(I)=PMAS(KFCA,1)
26671 PGD(I)=PMAS(KFCA,2)
26676 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
26679 RMG(I)=(PMG(I)/PMMX)**2
26685 C...Find allowed mass range and Breit-Wigner parameters.
26687 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
26689 PMU(I)=PMMX-PARP(42)
26690 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
26691 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
26692 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
26694 IF(MLM.EQ.2) ILM=3-I
26695 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
26696 IF(MBW(3-I).EQ.0) THEN
26697 PMU(I)=PMMX-PMD(3-I)
26699 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
26701 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
26702 & MIN(PMU(I),CKIN(NOFF+2*ILM))
26703 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
26704 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
26705 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
26706 IF(MBW(I).EQ.1) THEN
26707 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26708 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26709 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
26712 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
26714 IF(MLM.EQ.2) ILM=3-I
26715 PML(I)=MAX(CKIN(48+I),PARP(42))
26716 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
26717 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
26718 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
26719 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
26720 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
26721 IF(MBW(I).EQ.1) THEN
26722 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26723 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26724 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
26729 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
26731 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
26736 C...Calculation of partial width of resonance.
26737 IF(MOFSH.EQ.1) THEN
26739 C..If only one integration, pick that to be the inner.
26740 IF(MBW(1).EQ.0) THEN
26746 ELSEIF(MBW(2).EQ.0) THEN
26750 C...Start outer loop of integration.
26751 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
26752 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
26753 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
26759 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
26760 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
26761 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
26765 C...Start inner loop of integration.
26767 PMU1=MIN(PMU(1),PMMX-PM2)
26768 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
26769 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
26770 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
26771 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
26779 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
26780 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
26783 C...Evaluate function value - inner loop.
26784 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26785 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
26786 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
26787 & RM2**2+10D0*RM1*RM2)
26788 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
26791 C...Go to next position in inner loop.
26797 ELSEIF(NPT1.LE.8) THEN
26799 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
26801 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
26802 INX1(NPT1)=INX1(ISH1)
26805 ELSEIF(NPT1.LT.100) THEN
26808 IF(ISH1.GT.NPT1) ISH1=2
26809 IF(ISH1.EQ.ISN1) GOTO 160
26810 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
26811 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
26813 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
26814 INX1(NPT1)=INX1(ISH1)
26819 C...Calculate integral over inner loop.
26822 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
26823 & (XPT1(INX1(IPT1))-XPT1(IPT1))
26825 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
26826 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
26827 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
26830 C...Go to next position in outer loop.
26836 ELSEIF(NPT2.LE.8) THEN
26838 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
26840 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
26841 INX2(NPT2)=INX2(ISH2)
26844 ELSEIF(NPT2.LT.100) THEN
26847 IF(ISH2.GT.NPT2) ISH2=2
26848 IF(ISH2.EQ.ISN2) GOTO 200
26849 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
26850 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
26852 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
26853 INX2(NPT2)=INX2(ISH2)
26858 C...Calculate integral over outer loop.
26861 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
26862 & (XPT2(INX2(IPT2))-XPT2(IPT2))
26864 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
26865 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
26870 C...Save result; second integration for user-selected mass range.
26871 IF(LOOP.EQ.1) WIDW=FSUM2
26873 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
26874 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
26881 C...Select two decay product masses of a resonance.
26882 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
26884 IF(MBW(I).EQ.0) GOTO 230
26885 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
26887 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
26888 RMG(I)=(PMG(I)/PMMX)**2
26890 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
26891 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
26893 C...Weight with matrix element (if none known, use beta factor).
26894 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
26896 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
26897 ELSEIF(MMED.EQ.2) THEN
26898 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
26899 & RMG(2)**2+10D0*RMG(1)*RMG(2))
26900 ELSEIF(MMED.EQ.3) THEN
26901 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
26905 IF(WTBE.LT.PYR(0)) GOTO 220
26909 C...Find suitable set of masses for initialization of 2 -> 2 processes.
26910 ELSEIF(MOFSH.EQ.3) THEN
26911 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
26912 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
26914 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
26916 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
26920 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
26921 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
26922 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
26927 C...Evaluate importance of excluded tails of Breit-Wigners.
26928 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
26929 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
26933 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
26937 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
26938 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
26940 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
26941 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
26942 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
26943 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
26945 C...Pick one particle to be the lighter (if improves efficiency).
26946 ELSEIF(MOFSH.EQ.4) THEN
26947 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
26948 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
26949 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
26951 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
26953 IF(MBW(I).EQ.0) GOTO 270
26955 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
26957 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
26959 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
26960 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
26961 IF(RBR.LT.0.8D0) THEN
26962 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
26963 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
26964 ELSEIF(RBR.LT.0.9D0) THEN
26965 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
26966 ELSEIF(RBR.LT.1.5D0) THEN
26967 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
26969 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
26970 & (PMV**2-PML(I)**2))))
26973 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
26974 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
26975 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
26976 NGEN(0,1)=NGEN(0,1)+1
26977 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
26987 C...Give weight for selected mass distribution.
26990 IF(MBW(I).EQ.0) GOTO 280
26992 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
26994 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
26995 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
26996 & (PMD(I)*PGD(I))**2)/PARU(1)
27000 FI0=(ATV-ATL(I))/PARU(1)
27001 FI1=PMV**2-PML(I)**2
27002 FI2=2D0*LOG(PMV/PML(I))
27003 FI3=1D0/PML(I)**2-1D0/PMV**2
27004 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27005 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
27006 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
27009 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
27011 VINT(80)=VINT(80)*FI0
27013 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27019 C***********************************************************************
27022 C...Handles the possibility of colour reconnection in W+W- events,
27023 C...Based on the main scenarios of the Sjostrand and Khoze study:
27024 C...I, II, II', intermediate and instantaneous; plus one model
27025 C...along the lines of the Gustafson and Hakkinen: GH.
27026 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
27027 C...is as if first resonance is W+ and second W-.
27029 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
27031 C...Double precision and integer declarations.
27032 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27033 IMPLICIT INTEGER(I-N)
27034 INTEGER PYK,PYCHGE,PYCOMP
27035 C...Parameter value; number of points in MC integration.
27036 PARAMETER (NPT=100)
27038 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27039 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27040 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27041 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27042 COMMON/PYINT1/MINT(400),VINT(400)
27043 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27045 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
27046 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
27047 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
27048 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
27049 &TMC(20),IJOIN(100)
27051 C...Functions to give four-product and to do determinants.
27052 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)
27053 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
27054 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
27055 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
27057 C...Only allow fraction of recoupling for GH, intermediate and
27059 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27060 IF(PYR(0).GT.PARP(120)) RETURN
27064 C...Common part for scenarios I, II, II', and GH.
27065 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
27066 &MSTP(115).EQ.5) THEN
27068 C...Read out frequently-used parameters.
27072 IF(ISUB.EQ.22) PMW=PMAS(23,1)
27074 IF(ISUB.EQ.22) PGW=PMAS(23,2)
27081 C...Find range of decay products of the W's.
27082 C...Background: the W's are stored in IW1 and IW2.
27083 C...Their direct decay products in NSD1+1 through NSD1+4.
27084 C...Products after shower (if any) in NSD1+5 through NAFT1
27085 C...for first W and in NAFT1+1 through N for the second.
27086 IF(NAFT1.GT.NSD1+4) THEN
27093 IF(N.GT.NAFT1) THEN
27101 C...Rearrange parton shower products along strings.
27103 CALL PYPREP(NSD1+1)
27104 IF(MINT(51).NE.0) RETURN
27106 C...Find partons pointing back to W+ and W-; store them with quark
27107 C...end of string first.
27113 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
27114 IF(IABS(K(I,2)).GE.22) GOTO 120
27115 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
27116 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
27126 IF(K(I,1).EQ.1) ISGP=0
27127 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
27128 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
27138 IF(K(I,1).EQ.1) ISGM=0
27142 C...Boost to W+W- rest frame (not strictly needed).
27144 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
27146 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27147 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27148 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27150 C...Select decay vertices of W+ and W-.
27151 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
27152 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
27153 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
27154 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
27157 XP(J)=TP*P(IW1,J)/P(IW1,4)
27158 XM(J)=TM*P(IW2,J)/P(IW2,4)
27161 C...Begin scenario I specifics.
27162 IF(MSTP(115).EQ.1) THEN
27164 C...Reconstruct velocity and direction of W+ string pieces.
27166 IF(K(INP(IIP),2).LT.0) GOTO 170
27169 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
27170 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
27174 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
27175 DIRP(IIP,J)=V1(J)-V2(J)
27177 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
27179 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
27181 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
27185 C...Reconstruct velocity and direction of W- string pieces.
27187 IF(K(INM(IIM),2).LT.0) GOTO 200
27190 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
27191 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
27195 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
27196 DIRM(IIM,J)=V1(J)-V2(J)
27198 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
27200 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
27202 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
27206 C...Loop over number of space-time points.
27211 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
27212 R=SQRT(-LOG(PYR(0)))
27214 X=BLOWR*RHAD*R*COS(PHI)
27215 Y=BLOWR*RHAD*R*SIN(PHI)
27216 R=SQRT(-LOG(PYR(0)))
27218 Z=BLOWR*RHAD*R*COS(PHI)
27219 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
27221 C...Reject impossible points. Weight for sample distribution.
27222 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
27223 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
27224 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
27226 C...Loop over W+ string pieces and find one with largest weight.
27234 IF(K(INP(IIP),2).LT.0) GOTO 220
27235 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
27236 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
27238 XB(J)=XD(J)+BEDG*BETP(IIP,J)
27240 XB(4)=BETP(IIP,4)*(XD(4)-BED)
27241 SR2=XB(1)**2+XB(2)**2+XB(3)**2
27242 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
27243 & DIRP(IIP,3)*XB(3))**2
27244 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
27246 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
27247 IF(WTP.GT.WTMAXP) THEN
27253 C...Loop over W- string pieces and find one with largest weight.
27261 IF(K(INM(IIM),2).LT.0) GOTO 240
27262 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
27263 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
27265 XB(J)=XD(J)+BEDG*BETM(IIM,J)
27267 XB(4)=BETM(IIM,4)*(XD(4)-BED)
27268 SR2=XB(1)**2+XB(2)**2+XB(3)**2
27269 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
27270 & DIRM(IIM,3)*XB(3))**2
27271 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
27273 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
27274 IF(WTM.GT.WTMAXM) THEN
27280 C...Result of integration.
27282 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
27283 WT=WTMAXP*WTMAXM/WTSMP
27291 RES=BLOWR**3*BLOWT*SUM/NPT
27293 C...Decide whether to reconnect and, if so, where.
27295 PREC=1D0-EXP(-FACT*RES)
27296 IF(PREC.GT.PYR(0)) THEN
27301 IF(RSUM.LE.0D0) GOTO 270
27307 C...Begin scenario II and II' specifics.
27308 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
27310 C...Loop through all string pieces, one from W+ and one from W-.
27314 IF(K(INP(IIP),2).LT.0) GOTO 340
27318 IF(K(INM(IIM),2).LT.0) GOTO 330
27322 C...Find endpoint velocity vectors.
27324 V1P(J)=P(I1P,J)/P(I1P,4)
27325 V2P(J)=P(I2P,J)/P(I2P,4)
27326 V1M(J)=P(I1M,J)/P(I1M,4)
27327 V2M(J)=P(I2M,J)/P(I2M,4)
27330 C...Define q matrix and find t.
27332 Q(1,J)=V2P(J)-V1P(J)
27333 Q(2,J)=-(V2M(J)-V1M(J))
27334 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
27335 Q(4,J)=V1P(J)-V1M(J)
27337 T=-DETER(1,2,3)/DETER(1,2,4)
27339 C...Find alpha and beta; i.e. coordinates of crossing point.
27342 S13=Q(3,1)+Q(4,1)*T
27345 S23=Q(3,2)+Q(4,2)*T
27346 DEN=S11*S22-S12*S21
27347 ALP=(S12*S23-S22*S13)/DEN
27348 BET=(S21*S13-S11*S23)/DEN
27350 C...Check if solution acceptable.
27352 IF(T.LT.GTMAX) IANSW=0
27353 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
27354 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
27356 C...Find point of crossing and check that not inconsistent.
27358 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
27359 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
27361 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
27362 & (XPP(3)-XMM(3))**2
27363 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
27364 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
27365 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
27367 C...Find string eigentimes at crossing.
27368 IF(IANSW.EQ.1) THEN
27369 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
27370 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
27371 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
27372 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
27378 C...Order crossings by time. End loop over crossings.
27379 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
27381 DO 310 I1=NCROSS,1,-1
27382 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
27402 C...Loop over crossings; find first (if any) acceptable one.
27404 IF(NCROSS.GE.1) THEN
27406 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
27407 IF(PNFRAG.GT.PYR(0)) THEN
27408 C...Scenario II: only compare with fragmentation time.
27409 IF(MSTP(115).EQ.2) THEN
27414 C...Scenario II': also require that string length decreases.
27422 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
27423 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
27424 IF(ELNEW.LT.ELOLD) THEN
27436 C...Begin scenario GH specifics.
27437 ELSEIF(MSTP(115).EQ.5) THEN
27439 C...Loop through all string pieces, one from W+ and one from W-.
27443 IF(K(INP(IIP),2).LT.0) GOTO 380
27447 IF(K(INM(IIM),2).LT.0) GOTO 370
27451 C...Look for largest decrease of (exponent of) Lambda measure.
27452 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
27453 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
27454 ELDIF=ELNEW/MAX(1D-10,ELOLD)
27455 IF(ELDIF.LT.ELMIN) THEN
27467 C...Common for scenarios I, II, II' and GH: reconnect strings.
27471 DO 390 IS=1,NNP+NNM
27475 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
27477 ELSEIF(IS.LE.IIP+NNM) THEN
27478 I=INM(IS-IIP-NNM+IIM)
27483 IF(K(I,2).LT.0) THEN
27484 CALL PYJOIN(NJOIN,IJOIN)
27489 C...Restore original event record if no reconnection.
27491 DO 400 I=NSD1+1,NOLD
27492 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
27493 K(I,4)=MOD(K(I,4),MSTU(5)**2)
27494 K(I,5)=MOD(K(I,5),MSTU(5)**2)
27503 C...Boost back system.
27504 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
27505 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
27506 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
27507 & BEWW(1),BEWW(2),BEWW(3))
27509 C...Common part for intermediate and instantaneous scenarios.
27510 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27513 C...Remove old shower products and reset showering ones.
27515 DO 420 I=NSD1+1,NSD1+4
27517 K(I,4)=MOD(K(I,4),MSTU(5)**2)
27518 K(I,5)=MOD(K(I,5),MSTU(5)**2)
27521 C...Identify quark-antiquark pairs.
27525 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
27528 C...Reconnect strings.
27531 CALL PYJOIN(2,IJOIN)
27534 CALL PYJOIN(2,IJOIN)
27536 C...Do new parton showers in intermediate scenario.
27537 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
27540 if(parj(200).ne.1.) CALL PYSHOW(IQ1,IQ2,P(IW1,5))
27541 if(parj(200).eq.1.) CALL PYSHOWQ(IQ1,IQ2,P(IW1,5))
27542 if(parj(200).ne.1.) CALL PYSHOW(IQ3,IQ4,P(IW2,5))
27543 if(parj(200).eq.1.) CALL PYSHOWQ(IQ3,IQ4,P(IW2,5))
27546 C...Do new parton showers in instantaneous scenario.
27547 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
27548 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
27549 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
27550 PPM=SQRT(MAX(0D0,PPM2))
27551 if(parj(200).ne.1.) CALL PYSHOW(IQ1,IQ4,PPM)
27552 if(parj(200).eq.1.) CALL PYSHOWQ(IQ1,IQ4,PPM)
27553 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
27554 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
27555 PPM=SQRT(MAX(0D0,PPM2))
27556 if(parj(200).ne.1.) CALL PYSHOW(IQ3,IQ2,PPM)
27557 if(parj(200).eq.1.) CALL PYSHOWQ(IQ3,IQ2,PPM)
27564 C***********************************************************************
27567 C...Checks generated variables against pre-set kinematical limits;
27568 C...also calculates limits on variables used in generation.
27570 SUBROUTINE PYKLIM(ILIM)
27572 C...Double precision and integer declarations.
27573 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27574 IMPLICIT INTEGER(I-N)
27575 INTEGER PYK,PYCHGE,PYCOMP
27577 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27578 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27579 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27580 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
27581 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27582 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27583 COMMON/PYINT1/MINT(400),VINT(400)
27584 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27585 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
27588 C...Common kinematical expressions.
27592 IF(ISUB.EQ.96) GOTO 100
27596 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
27597 CKIN09=MAX(CKIN(9),CKIN(13))
27598 CKIN10=MIN(CKIN(10),CKIN(14))
27599 CKIN11=MAX(CKIN(11),CKIN(15))
27600 CKIN12=MIN(CKIN(12),CKIN(16))
27602 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
27603 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
27604 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
27605 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
27610 RM3=SQM3/(TAU*VINT(2))
27611 RM4=SQM4/(TAU*VINT(2))
27612 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
27615 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
27616 &PTHMIN=MAX(CKIN(3),CKIN(5))
27619 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
27620 C...pre-set kinematical limits.
27625 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
27626 X1=SQRT(TAUE)*EXP(YST)
27627 X2=SQRT(TAUE)*EXP(-YST)
27629 IF(MINT(47).NE.1) THEN
27630 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
27631 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
27632 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
27633 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
27635 IF(MINT(45).NE.1) THEN
27636 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
27638 IF(MINT(46).NE.1) THEN
27639 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
27641 IF(MINT(45).EQ.2) THEN
27642 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
27644 IF(MINT(46).EQ.2) THEN
27645 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
27647 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
27648 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
27649 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
27650 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
27651 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
27652 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
27653 Y3=YST+0.5D0*LOG(EXPY3)
27654 Y4=YST+0.5D0*LOG(EXPY4)
27659 STH=SQRT(MAX(0D0,1D0-CTH**2))
27660 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
27661 & CTH)**2-4D0*RM3))
27662 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
27663 & CTH)**2-4D0*RM4))
27664 IF(STH.GE.1D-10) THEN
27665 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
27667 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
27669 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
27670 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
27671 ETALAR=MAX(ETA3,ETA4)
27672 ETASMA=MIN(ETA3,ETA4)
27674 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
27675 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
27676 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
27677 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
27679 RPTS=4D0*VINT(71)**2/SH
27680 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
27681 RM34=MAX(1D-20,2D0*RM3*RM4)
27682 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
27683 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
27684 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
27685 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
27686 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
27687 IF(PTH.LT.PTHMIN) MINT(51)=1
27688 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
27689 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
27690 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
27691 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
27692 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
27693 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
27694 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
27695 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
27696 IF(THA.LT.CKIN(35)) MINT(51)=1
27697 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
27698 IF(UHA.LT.CKIN(37)) MINT(51)=1
27699 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
27701 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
27702 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
27703 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
27706 C...Additional cuts on W2 (approximately) in DIS.
27707 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
27709 IF(IABS(MINT(12)).LT.20) XBJ=X1
27711 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
27712 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
27713 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
27716 ELSEIF(ILIM.EQ.1) THEN
27717 C...Calculate limits on tau
27718 C...0) due to definition
27721 C...1) due to limits on subsystem mass
27722 TAUMN1=CKIN(1)**2/VINT(2)
27724 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
27725 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
27726 TM3=SQRT(SQM3+PTHMIN**2)
27727 TM4=SQRT(SQM4+PTHMIN**2)
27729 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
27730 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
27732 C...3) due to limits on pT-hat and cos(theta-hat)
27733 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
27734 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
27736 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
27737 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
27738 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
27740 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
27741 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
27742 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
27743 C...4) due to limits on x1 and x2
27744 TAUMN4=CKIN(21)*CKIN(23)
27745 TAUMX4=CKIN(22)*CKIN(24)
27746 C...5) due to limits on xF
27748 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
27749 C...6) due to limits on that and uhat
27750 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
27752 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
27753 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
27755 C...Net effect of all separate limits.
27756 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
27757 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
27758 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
27761 ELSEIF(MINT(47).EQ.5) THEN
27762 VINT(31)=MIN(VINT(31),1D0-2D-10)
27763 ELSEIF(MINT(47).GE.6) THEN
27764 VINT(31)=MIN(VINT(31),1D0-1D-10)
27766 IF(VINT(31).LE.VINT(11)) MINT(51)=1
27768 ELSEIF(ILIM.EQ.2) THEN
27769 C...Calculate limits on y*
27771 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
27773 C...0) due to kinematics
27776 C...1) due to explicit limits
27779 C...2) due to limits on x1
27780 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
27781 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
27782 C...3) due to limits on x2
27783 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
27784 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
27785 C...4) due to limits on xF
27786 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
27787 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
27788 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
27789 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
27790 C...5) due to simultaneous limits on y-large and y-small
27791 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
27792 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
27793 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
27794 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
27795 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
27796 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
27797 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
27799 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
27800 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
27801 RZMX=BE34*MIN(CKIN(28),CTHLIM)
27802 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
27803 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
27804 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
27805 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
27806 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
27807 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
27809 C...Net effect of all separate limits.
27810 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
27811 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
27812 IF(MINT(47).EQ.1) THEN
27815 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
27816 VINT(12)=(1D0-1D-9)*YSTMX0
27817 VINT(32)=(1D0+1D-9)*YSTMX0
27818 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
27819 VINT(12)=-(1D0+1D-9)*YSTMX0
27820 VINT(32)=-(1D0-1D-9)*YSTMX0
27821 ELSEIF(MINT(47).EQ.5) THEN
27822 YSTEE=LOG((1D0-1D-10)/TAURT)
27823 VINT(12)=MAX(VINT(12),-YSTEE)
27824 VINT(32)=MIN(VINT(32),YSTEE)
27826 IF(VINT(32).LE.VINT(12)) MINT(51)=1
27828 ELSEIF(ILIM.EQ.3) THEN
27829 C...Calculate limits on cos(theta-hat)
27831 C...0) due to definition
27836 C...1) due to explicit limits
27837 CTNMN1=MIN(0D0,CKIN(27))
27838 CTNMX1=MIN(0D0,CKIN(28))
27839 CTPMN1=MAX(0D0,CKIN(27))
27840 CTPMX1=MAX(0D0,CKIN(28))
27841 C...2) due to limits on pT-hat
27842 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
27846 IF(CKIN(4).GE.0D0) THEN
27847 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
27848 & (BE34**2*TAU*VINT(2))))
27851 C...3) due to limits on y-large and y-small
27852 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
27853 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
27854 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
27855 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
27856 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
27857 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
27858 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
27859 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
27860 C...4) due to limits on that
27866 IF(CKIN(35).GT.0D0) THEN
27867 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
27868 IF(CTLIM.GT.0D0) THEN
27875 IF(CKIN(36).GT.0D0) THEN
27876 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
27877 IF(CTLIM.LT.0D0) THEN
27884 C...5) due to limits on uhat
27889 IF(CKIN(37).GT.0D0) THEN
27890 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
27891 IF(CTLIM.LT.0D0) THEN
27898 IF(CKIN(38).GT.0D0) THEN
27899 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
27900 IF(CTLIM.GT.0D0) THEN
27908 C...Net effect of all separate limits.
27909 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
27910 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
27911 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
27912 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
27913 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
27915 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
27916 IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
27918 ELSEIF(ILIM.EQ.4) THEN
27919 C...Calculate limits on tau'
27920 C...0) due to kinematics
27922 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
27923 PQRAT=(VINT(201)+VINT(206))/VINT(1)
27924 TAPMN0=(SQRT(TAU)+PQRAT)**2
27927 C...1) due to explicit limits
27928 TAPMN1=CKIN(31)**2/VINT(2)
27930 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
27932 C...Net effect of all separate limits.
27933 VINT(16)=MAX(TAPMN0,TAPMN1)
27934 VINT(36)=MIN(TAPMX0,TAPMX1)
27935 IF(MINT(47).EQ.1) THEN
27938 ELSEIF(MINT(47).EQ.5) THEN
27939 VINT(36)=MIN(VINT(36),1D0-2D-10)
27940 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
27941 VINT(36)=MIN(VINT(36),1D0-1D-10)
27943 IF(VINT(36).LE.VINT(16)) MINT(51)=1
27948 C...Special case for low-pT and multiple interactions:
27949 C...effective kinematical limits for tau, y*, cos(theta-hat).
27950 100 IF(ILIM.EQ.0) THEN
27951 ELSEIF(ILIM.EQ.1) THEN
27952 IF(MSTP(82).LE.1) THEN
27953 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
27956 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
27959 ELSEIF(ILIM.EQ.2) THEN
27960 VINT(12)=0.5D0*LOG(VINT(21))
27962 ELSEIF(ILIM.EQ.3) THEN
27963 IF(MSTP(82).LE.1) THEN
27964 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
27965 & (VINT(21)*VINT(2))
27967 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
27968 & (VINT(21)*VINT(2))
27970 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
27979 C*********************************************************************
27982 C...Maps a uniform distribution into a distribution of a kinematical
27983 C...variable according to one of the possibilities allowed. It is
27984 C...assumed that kinematical limits have been set by a PYKLIM call.
27986 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
27988 C...Double precision and integer declarations.
27989 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27990 IMPLICIT INTEGER(I-N)
27991 INTEGER PYK,PYCHGE,PYCOMP
27993 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27994 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27995 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27996 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27997 COMMON/PYINT1/MINT(400),VINT(400)
27998 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27999 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
28001 C...Convert VVAR to tau variable.
28007 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
28010 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
28013 ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
28017 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28019 ELSEIF(MVAR.EQ.1) THEN
28020 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
28021 ELSEIF(MVAR.EQ.2) THEN
28022 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
28023 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
28024 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
28025 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
28026 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
28027 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
28028 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
28029 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
28030 ELSEIF(MINT(47).EQ.5) THEN
28031 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
28032 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
28033 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28035 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
28036 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
28037 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28039 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
28041 C...Convert VVAR to y* variable.
28042 ELSEIF(IVAR.EQ.2) THEN
28046 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28047 IF(MINT(47).EQ.1) THEN
28049 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28050 YST=-0.5D0*LOG(TAUE)
28051 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28052 YST=0.5D0*LOG(TAUE)
28053 ELSEIF(MVAR.EQ.1) THEN
28054 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
28055 ELSEIF(MVAR.EQ.2) THEN
28056 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
28057 ELSEIF(MVAR.EQ.3) THEN
28058 AUPP=ATAN(EXP(YSTMAX))
28059 ALOW=ATAN(EXP(YSTMIN))
28060 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
28061 ELSEIF(MVAR.EQ.4) THEN
28062 YST0=-0.5D0*LOG(TAUE)
28063 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
28064 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28065 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
28067 YST0=-0.5D0*LOG(TAUE)
28068 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28069 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
28070 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
28072 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
28074 C...Convert VVAR to cos(theta-hat) variable.
28075 ELSEIF(IVAR.EQ.3) THEN
28076 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
28078 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28079 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28087 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28088 VCTN=VVAR*(ANEG+APOS)/ANEG
28089 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
28091 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28092 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
28094 ELSEIF(MVAR.EQ.2) THEN
28095 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28096 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28097 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28098 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28099 ANEG=LOG(RMNMIN/RMNMAX)
28100 APOS=LOG(RMPMIN/RMPMAX)
28101 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28102 VCTN=VVAR*(ANEG+APOS)/ANEG
28103 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
28105 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28106 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
28108 ELSEIF(MVAR.EQ.3) THEN
28109 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28110 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28111 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28112 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28113 ANEG=LOG(RMNMAX/RMNMIN)
28114 APOS=LOG(RMPMAX/RMPMIN)
28115 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28116 VCTN=VVAR*(ANEG+APOS)/ANEG
28117 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
28119 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28120 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
28122 ELSEIF(MVAR.EQ.4) THEN
28123 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28124 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28125 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28126 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28127 ANEG=1D0/RMNMAX-1D0/RMNMIN
28128 APOS=1D0/RMPMAX-1D0/RMPMIN
28129 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28130 VCTN=VVAR*(ANEG+APOS)/ANEG
28131 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
28133 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28134 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
28136 ELSEIF(MVAR.EQ.5) THEN
28137 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28138 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28139 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28140 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28141 ANEG=1D0/RMNMIN-1D0/RMNMAX
28142 APOS=1D0/RMPMIN-1D0/RMPMAX
28143 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28144 VCTN=VVAR*(ANEG+APOS)/ANEG
28145 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
28147 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28148 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
28151 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
28152 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
28155 C...Convert VVAR to tau' variable.
28156 ELSEIF(IVAR.EQ.4) THEN
28160 IF(MINT(47).EQ.1) THEN
28162 ELSEIF(MVAR.EQ.1) THEN
28163 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
28164 ELSEIF(MVAR.EQ.2) THEN
28165 AUPP=(1D0-TAU/TAUPMX)**4
28166 ALOW=(1D0-TAU/TAUPMN)**4
28167 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
28168 ELSEIF(MINT(47).EQ.5) THEN
28169 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
28170 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
28171 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28173 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
28174 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
28175 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28177 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
28179 C...Selection of extra variables needed in 2 -> 3 process:
28180 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
28181 C...Since no options are available, the functions of PYKLIM
28182 C...and PYKMAP are joint for these choices.
28183 ELSEIF(IVAR.EQ.5) THEN
28185 C...Read out total energy and particle masses.
28188 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
28189 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
28191 SHP=VINT(26)*VINT(2)
28195 PM3=SQRT(VINT(21))*VINT(1)
28196 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
28203 C...Specify coefficients of pT choice; upper and lower limits.
28204 IF(MPTPK.EQ.1) THEN
28212 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
28214 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
28216 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
28218 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
28221 C...Select transverse momenta according to
28222 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
28225 IF(HMX.LT.1.0001D0*HMN) THEN
28231 IF(RPT.LT.HWT1) THEN
28232 PTS1=PTSMN1+PYR(0)*HDE
28233 ELSEIF(RPT.LT.HWT1+HWT2) THEN
28234 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
28236 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
28238 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
28239 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
28242 IF(HMX.LT.1.0001D0*HMN) THEN
28248 IF(RPT.LT.HWT1) THEN
28249 PTS2=PTSMN2+PYR(0)*HDE
28250 ELSEIF(RPT.LT.HWT1+HWT2) THEN
28251 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
28253 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
28255 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
28256 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
28258 C...Select azimuthal angles and check pT choice.
28259 PHI1=PARU(2)*PYR(0)
28260 PHI2=PARU(2)*PYR(0)
28262 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
28263 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
28264 & CKIN(56)**2)) THEN
28269 C...Calculate transverse masses and check phase space not closed.
28276 PM12=(PMT1+PMT2)**2
28277 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
28282 C...Select rapidity for particle 3 and check phase space not closed.
28283 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
28284 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
28285 IF(Y3MAX.LT.1D-6) THEN
28289 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
28293 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
28296 PMS12=PE12**2-PZ12**2
28297 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
28298 IF(SQL12.LT.1D-6*SHP) THEN
28302 PMM1=PMS12+PMS1-PMS2
28303 PMM2=PMS12+PMS2-PMS1
28304 TFAC=-SHPR/(2D0*PMS12)
28305 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
28306 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
28307 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
28308 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
28310 C...Construct relative mirror weights and make choice.
28311 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
28315 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
28316 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
28318 WTP=WTPU/(WTPU+WTNU)
28319 WTN=WTNU/(WTPU+WTNU)
28321 IF(WTN.GT.PYR(0)) EPS=-1D0
28323 C...Store result of variable choice and associated weights.
28333 IF(EPS.GT.0D0) THEN
28342 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
28343 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
28344 VINT(219)=0.5D0*(PMS12-PTS3)
28351 C***********************************************************************
28354 C...Differential matrix elements for all included subprocesses
28355 C...Note that what is coded is (disregarding the COMFAC factor)
28356 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
28357 C...when d(sigma-hat) is given in the zero-width limit, the delta
28358 C...function in tau is replaced by a (modified) Breit-Wigner:
28359 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
28360 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
28361 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
28362 C...i.e., dimensionless quantities
28363 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
28364 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
28365 C...(2pi)^4 delta^4(P - sum p_i)
28366 C...COMFAC contains the factor pi/s (or equivalent) and
28367 C...the conversion factor from GeV^-2 to mb
28369 SUBROUTINE PYSIGH(NCHN,SIGS)
28371 C...Double precision and integer declarations
28372 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28373 IMPLICIT INTEGER(I-N)
28374 INTEGER PYK,PYCHGE,PYCOMP
28375 C...Parameter statement to help give large particle numbers.
28376 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
28377 &KEXCIT=4000000,KDIMEN=5000000)
28379 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28380 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28381 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28382 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28383 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28384 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28385 COMMON/PYINT1/MINT(400),VINT(400)
28386 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28387 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
28388 COMMON/PYINT4/MWID(500),WIDS(500,5)
28389 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
28390 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
28391 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
28392 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
28393 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
28394 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
28395 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
28396 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
28397 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
28398 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
28399 COMMON/PYTCCO/COEFX(194:380,2)
28400 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
28401 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
28402 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYSGCM/,/PYTCCO/
28403 C...Local arrays and complex variables
28404 DIMENSION XPQ(-25:25)
28406 C...Map of processes onto which routine to call
28407 C...in order to evaluate cross section:
28408 C...0 = not implemented;
28409 C...1 = standard QCD (including photons);
28410 C...2 = heavy flavours;
28412 C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
28414 C...6 = Technicolor;
28415 C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
28416 DIMENSION MAPPR(500)
28417 DATA (MAPPR(I),I=1,180)/
28418 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
28419 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
28420 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
28421 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
28422 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
28423 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
28424 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
28425 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
28426 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
28427 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
28428 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
28429 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
28430 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
28431 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
28432 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
28433 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
28434 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
28435 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
28436 DATA (MAPPR(I),I=181,500)/
28437 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
28438 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
28440 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
28442 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
28443 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
28444 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
28445 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
28446 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
28447 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
28449 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
28450 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
28452 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
28453 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
28456 C...Reset number of channels and cross-section
28460 C...Read process to consider.
28465 C...Read kinematical variables and limits
28483 C...Derive kinematical quantities
28485 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
28486 X(1)=SQRT(TAUE)*EXP(YST)
28487 X(2)=SQRT(TAUE)*EXP(-YST)
28488 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
28489 IF(X(1).GT.1D0-1D-7) RETURN
28490 ELSEIF(MINT(45).EQ.3) THEN
28491 X(1)=MIN(1D0-1.1D-10,X(1))
28493 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
28494 IF(X(2).GT.1D0-1D-7) RETURN
28495 ELSEIF(MINT(46).EQ.3) THEN
28496 X(2)=MIN(1D0-1.1D-10,X(2))
28498 SH=MAX(1D0,TAU*VINT(2))
28503 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
28504 RPTS=4D0*VINT(71)**2/SH
28505 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
28506 RM34=MAX(1D-20,2D0*RM3*RM4)
28508 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
28509 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
28510 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
28511 IF(ISTSB.EQ.0) THEN
28513 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
28514 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
28516 C...Kinematics with incoming masses tricky: now depends on how
28517 C...subprocess has been set up w.r.t. order of incoming partons.
28519 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
28521 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
28522 IF(ISUB.EQ.35) THEN
28526 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28527 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
28528 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
28530 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
28532 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
28539 C...Choice of Q2 scale for hard process (e.g. alpha_s).
28540 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
28542 ELSEIF(ISTSB.EQ.8) THEN
28543 IF(MINT(107).EQ.4) Q2=VINT(307)
28544 IF(MINT(108).EQ.4) Q2=VINT(308)
28545 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
28547 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
28549 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
28550 IF(MSTP(32).EQ.1) THEN
28551 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
28552 ELSEIF(MSTP(32).EQ.2) THEN
28553 Q2=SQPTH+0.5D0*(SQM3+SQM4)
28554 ELSEIF(MSTP(32).EQ.3) THEN
28556 ELSEIF(MSTP(32).EQ.4) THEN
28558 ELSEIF(MSTP(32).EQ.5) THEN
28560 ELSEIF(MSTP(32).EQ.6) THEN
28562 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
28564 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
28565 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
28566 & (SQPTH+0.5D0*(SQM3+SQM4))
28567 ELSEIF(MSTP(32).EQ.7) THEN
28568 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
28569 ELSEIF(MSTP(32).EQ.8) THEN
28570 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
28571 ELSEIF(MSTP(32).EQ.9) THEN
28572 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
28573 ELSEIF(MSTP(32).EQ.10) THEN
28576 ELSEIF(MSTP(32).EQ.11) THEN
28577 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
28578 ELSEIF(MSTP(32).EQ.12) THEN
28581 ELSEIF(MSTP(32).EQ.13) THEN
28584 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
28585 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
28586 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
28589 C...Choice of Q2 scale for parton densities.
28592 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
28593 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
28596 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28598 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
28599 & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
28600 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
28601 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
28602 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
28603 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
28604 IF(MSTP(39).EQ.2) Q2SF=
28605 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
28606 IF(MSTP(39).EQ.3) Q2SF=SH
28607 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
28608 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
28610 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
28611 IF(MSTP(39).EQ.7) Q2SF=
28612 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
28613 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
28617 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
28621 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
28622 IF(MSTP(69).GE.2) Q2SF=VINT(2)
28624 C...Identify to which class(es) subprocess belongs
28628 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
28629 & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
28630 & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
28631 & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
28632 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
28633 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
28634 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
28635 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
28636 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
28637 IF (ISTSB.EQ.9) ISQCD=1
28638 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
28639 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
28640 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
28641 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
28642 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
28643 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
28644 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
28645 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
28646 C...WBF is special case of ISJETS
28647 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
28648 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
28649 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
28650 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
28651 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
28652 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
28653 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
28654 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
28655 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
28656 C...Some processes with photons also belong here.
28657 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
28658 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
28659 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
28660 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
28661 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
28662 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
28664 C...Choice of Q2 scale for parton-shower activity.
28665 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
28666 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
28668 IF(MINT(43).EQ.3) XBJ=X(1)
28669 IF(MSTP(22).EQ.1) THEN
28671 ELSEIF(MSTP(22).EQ.2) THEN
28672 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
28673 ELSEIF(MSTP(22).EQ.3) THEN
28674 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
28676 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
28679 C...For multiple interactions, start from scale defined above
28680 C...For all other QCD or "+jets"-type events, start shower from pThard.
28681 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
28682 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
28683 C...Max shower scale = s for ME corrected processes.
28684 C...(pT-ordering: max pT2 is s/4)
28686 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
28687 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
28688 C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
28689 C...(pT-ordering: max pT2 is s/4)
28691 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
28693 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
28695 C...Elastic and diffractive events not associated with scales so set 0.
28696 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
28701 C...Store derived kinematical quantities
28708 IF(ISTSB.NE.8) VINT(48)=SQPTH
28709 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
28710 VINT(50)=TAUP*VINT(2)
28711 VINT(49)=SQRT(MAX(0D0,VINT(50)))
28715 VINT(53)=SQRT(Q2SF)
28717 VINT(55)=SQRT(Q2PS)
28719 C...Set starting scale for multiple interactions
28720 IF (ISUBSV.EQ.95) THEN
28722 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
28723 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
28724 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
28725 & ISUBSV.NE.96)) THEN
28726 C...All accessible phase space allowed.
28727 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
28729 C...Scale of hard process sets limit.
28730 C...2 -> 1. Limit is tau = x1*x2.
28731 C...2 -> 2. Limit is XT2 for hard process + FS masses.
28732 C...2 -> n > 2. Limit is tau' = tau of outer process.
28734 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
28736 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
28737 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
28739 VINT(62)=0.25D0*XT2GMX*VINT(2)
28740 VINT(61)=SQRT(MAX(0D0,VINT(62)))
28742 C...Calculate parton distributions
28743 IF(ISTSB.LE.0) GOTO 160
28744 IF(MINT(47).GE.2) THEN
28745 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
28747 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
28748 IF(ISUB.EQ.99) THEN
28749 IF(MINT(140+I).EQ.0) THEN
28750 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
28752 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
28757 MINT(105)=MINT(102+I)
28758 MINT(109)=MINT(106+I)
28759 VINT(120)=VINT(2+I)
28761 C.... Store side in MINT(124)
28764 IF(MSTP(57).LE.1) THEN
28765 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
28767 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
28769 C...Safety margin against heavy flavour very close to threshold,
28770 C...e.g. caused by mismatch in c and b masses.
28771 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
28775 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
28780 XSFX(I,KFL)=XPQ(KFL)
28785 C...Calculate alpha_em, alpha_strong and K-factor
28788 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
28789 &1D0-(PMAS(24,1)/PMAS(23,1))**2
28791 XWC=1D0/(16D0*XW*XW1)
28793 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
28794 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
28797 IF(MSTP(33).EQ.1) THEN
28799 ELSEIF(MSTP(33).EQ.2) THEN
28801 FACA=PARP(32)/PARP(31)
28802 ELSEIF(MSTP(33).EQ.3) THEN
28804 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
28805 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
28812 C...Set flags for allowed reacting partons/leptons
28817 IF(MINT(44+I).EQ.1) THEN
28818 KFAC(I,MINT(10+I))=1
28819 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
28820 KFAC(I,MINT(10+I))=1
28826 KFAC(I,J)=KFIN(I,J)
28827 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
28828 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
28833 C...Lower and upper limit for fermion flavour loops
28839 IF(KFAC(1,-J).EQ.1) MMIN1=-J
28840 IF(KFAC(1,J).EQ.1) MMAX1=J
28841 IF(KFAC(2,-J).EQ.1) MMIN2=-J
28842 IF(KFAC(2,J).EQ.1) MMAX2=J
28844 MMINA=MIN(MMIN1,MMIN2)
28845 MMAXA=MAX(MMAX1,MMAX2)
28847 C...Common resonance mass and width combinations
28850 GMMZ=PMAS(23,1)*PMAS(23,2)
28851 GMMW=PMAS(24,1)*PMAS(24,2)
28853 C...Polarization factors...implemented so far for W+W-(25)
28854 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
28855 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
28856 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
28857 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
28859 C...Phase space integral in tau
28860 COMFAC=PARU(1)*PARU(5)/VINT(2)
28861 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
28862 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
28863 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
28864 ATAU1=LOG(TAUMAX/TAUMIN)
28865 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
28866 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
28867 IF(MINT(72).GE.1) THEN
28870 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
28872 IF(ATAUD.GT.1D-10) H1=H1+
28873 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
28874 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
28876 IF(ATAUD.GT.1D-10) H1=H1+
28877 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
28879 IF(MINT(72).GE.2) THEN
28882 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
28884 IF(ATAUD.GT.1D-10) H1=H1+
28885 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
28886 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
28888 IF(ATAUD.GT.1D-10) H1=H1+
28889 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
28891 IF(MINT(72).EQ.3) THEN
28894 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
28896 IF(ATAUD.GT.1D-10) H1=H1+
28897 & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
28898 ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
28900 IF(ATAUD.GT.1D-10) H1=H1+
28901 & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
28903 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
28904 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
28905 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
28906 & MAX(2D-10,1D0-TAU)
28907 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
28908 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
28909 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
28910 & MAX(1D-10,1D0-TAU)
28912 COMFAC=COMFAC*ATAU1/(TAU*H1)
28915 C...Phase space integral in y*
28916 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
28918 AYST0=YSTMAX-YSTMIN
28919 IF(AYST0.LT.1D-10) THEN
28922 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
28924 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
28925 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
28926 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
28927 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
28928 IF(MINT(45).EQ.3) THEN
28929 YST0=-0.5D0*LOG(TAUE)
28930 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
28931 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28932 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
28933 & MAX(1D-10,1D0-EXP(YST-YST0))
28935 IF(MINT(46).EQ.3) THEN
28936 YST0=-0.5D0*LOG(TAUE)
28937 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
28938 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28939 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
28940 & MAX(1D-10,1D0-EXP(-YST-YST0))
28942 COMFAC=COMFAC*AYST0/H2
28946 C...2 -> 1 processes: reduction in angular part of phase space integral
28947 C...for case of decaying resonance
28948 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
28949 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
28950 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
28951 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
28952 & KFPR(ISUB,1).EQ.39) THEN
28953 COMFAC=COMFAC*0.5D0*ACTH0
28955 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
28956 & CTPMAX**3-CTPMIN**3)
28960 C...2 -> 2 processes: angular part of phase space integral
28961 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
28962 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
28963 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
28964 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
28965 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
28966 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
28967 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
28968 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
28969 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
28970 H3=COEF(ISUBSV,13)+
28971 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
28972 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
28973 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
28974 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
28975 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
28977 C...2 -> 2 processes: take into account final state Breit-Wigners
28978 COMFAC=COMFAC*VINT(80)
28981 C...2 -> 3, 4 processes: phace space integral in tau'
28982 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28983 ATAUP1=LOG(TAUPMX/TAUPMN)
28984 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
28985 H4=COEF(ISUBSV,18)+
28986 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
28987 IF(MINT(47).EQ.5) THEN
28988 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
28989 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
28990 ELSEIF(MINT(47).GE.6) THEN
28991 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
28992 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
28994 COMFAC=COMFAC*ATAUP1/H4
28997 C...2 -> 3, 4 processes: effective W/Z parton distributions
28998 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
28999 IF(1D0-TAU/TAUP.GT.1D-4) THEN
29000 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
29002 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
29007 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
29008 IF(ISTSB.EQ.5) THEN
29009 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
29010 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
29013 C...Phase space integral for low-pT and multiple interactions
29014 IF(ISTSB.EQ.9) THEN
29015 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
29016 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
29017 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
29018 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
29019 COMFAC=COMFAC*ATAU1/H1
29020 AYST0=YSTMAX-YSTMIN
29021 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29022 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29023 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29024 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29025 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29026 COMFAC=COMFAC*AYST0/H2
29027 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
29028 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
29029 C...introduced to make cross-section finite for xT2 -> 0
29030 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
29034 C...Real gamma + gamma: include factor 2 when different nature
29035 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
29036 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
29038 C...Extra factors to include the effects of
29039 C...longitudinal resolved photons (but not direct or DIS ones).
29041 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
29042 & MINT(106+ISDE).LE.3) THEN
29045 IF(MSTP(16).EQ.0) THEN
29046 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
29047 & XY=VINT(304+ISDE)
29049 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
29050 & XY=VINT(308+ISDE)
29052 Q2GA=VINT(306+ISDE)
29053 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
29054 & Q2GA.GT.0D0) THEN
29056 IF(MSTP(17).EQ.1) THEN
29057 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
29058 ELSEIF(MSTP(17).EQ.2) THEN
29059 REDUCE=4D0*Q2GA/(Q2+Q2GA)
29060 ELSEIF(MSTP(17).EQ.3) THEN
29061 PMVIRT=PMAS(PYCOMP(113),1)
29062 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29063 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
29064 PMVIRT=PMAS(PYCOMP(113),1)
29065 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29066 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
29067 PMVIRT=PMAS(PYCOMP(113),1)
29068 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29069 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
29070 PMVSMN=4D0*PARP(15)**2
29071 PMVSMX=4D0*VINT(154)**2
29072 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29073 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
29074 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
29075 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
29076 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
29077 PMVIRT=PMAS(PYCOMP(113),1)
29078 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29079 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
29080 PMVIRT=PMAS(PYCOMP(113),1)
29081 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29082 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
29083 PMVSMN=4D0*PARP(15)**2
29084 PMVSMX=4D0*VINT(154)**2
29085 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29086 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
29087 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
29090 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
29091 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
29092 & (1D0-2D0*BEAMAS**2/Q2GA))
29093 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
29098 COMFAC=COMFAC*VINT(314+ISDE)
29101 C...Evaluate cross sections - done in separate routines by kind
29102 C...of physics, to keep PYSIGH of sensible size.
29104 C...Standard QCD (including photons).
29105 CALL PYSGQC(NCHN,SIGS)
29106 ELSEIF(MAP.EQ.2) THEN
29107 C...Heavy flavours.
29108 CALL PYSGHF(NCHN,SIGS)
29109 ELSEIF(MAP.EQ.3) THEN
29111 CALL PYSGWZ(NCHN,SIGS)
29112 ELSEIF(MAP.EQ.4) THEN
29113 C...Higgs (2 doublets; including longitudinal W/Z scattering).
29114 CALL PYSGHG(NCHN,SIGS)
29115 ELSEIF(MAP.EQ.5) THEN
29117 CALL PYSGSU(NCHN,SIGS)
29118 ELSEIF(MAP.EQ.6) THEN
29120 CALL PYSGTC(NCHN,SIGS)
29121 ELSEIF(MAP.EQ.7) THEN
29122 C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29123 CALL PYSGEX(NCHN,SIGS)
29126 C...Multiply with parton distributions
29127 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
29129 IF(MINT(45).GE.2) THEN
29131 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
29133 IF(MINT(46).GE.2) THEN
29135 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
29137 SIGS=SIGS+SIGH(ICHN)
29144 C*********************************************************************
29147 C...Subprocess cross sections for QCD processes,
29148 C...including photons.
29149 C...Auxiliary to PYSIGH.
29151 SUBROUTINE PYSGQC(NCHN,SIGS)
29153 C...Double precision and integer declarations
29154 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29155 IMPLICIT INTEGER(I-N)
29156 INTEGER PYK,PYCHGE,PYCOMP
29157 C...Parameter statement to help give large particle numbers.
29158 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29159 &KEXCIT=4000000,KDIMEN=5000000)
29161 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29162 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29163 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29164 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29165 COMMON/PYINT1/MINT(400),VINT(400)
29166 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29167 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29168 COMMON/PYINT4/MWID(500),WIDS(500,5)
29169 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29170 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29171 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29172 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29173 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29174 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
29175 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
29177 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
29179 C...Differential cross section expressions.
29181 IF(ISUB.LE.20) THEN
29182 IF(ISUB.EQ.10) THEN
29183 C...f + f' -> f + f' (gamma/Z/W exchange)
29184 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
29185 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
29186 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
29187 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
29188 DO 110 I=MMIN1,MMAX1
29189 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
29191 DO 100 J=MMIN2,MMAX2
29192 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
29194 C...Electroweak couplings
29195 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
29196 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
29198 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
29199 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
29202 C...gamma/Z exchange, only gamma exchange, or only Z exchange
29203 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
29204 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
29205 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
29206 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
29207 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
29208 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
29209 ELSEIF(MSTP(21).EQ.2) THEN
29210 FACNCF=FACGGF*EI**2*EJ**2
29212 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
29213 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
29215 C...Extrafactor 2 for only one incoming neutrino spin state.
29216 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
29217 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
29225 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
29226 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
29227 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
29228 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
29229 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
29239 ELSEIF(ISUB.EQ.11) THEN
29240 C...f + f' -> f + f' (g exchange)
29241 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
29242 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
29243 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
29244 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
29245 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
29246 DO 130 I=MMIN1,MMAX1
29248 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
29249 DO 120 J=MMIN2,MMAX2
29251 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
29257 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
29259 SIGH(NCHN)=0.5D0*SIGH(NCHN)
29264 SIGH(NCHN)=0.5D0*FACQQ2
29269 ELSEIF(ISUB.EQ.12) THEN
29270 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
29271 CALL PYWIDT(21,SH,WDTP,WDTE)
29272 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
29273 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
29274 DO 140 I=MMINA,MMAXA
29275 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29276 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
29284 ELSEIF(ISUB.EQ.13) THEN
29285 C...f + fbar -> g + g (q + qbar -> g + g only)
29286 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29288 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29290 DO 150 I=MMINA,MMAXA
29291 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29292 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
29297 SIGH(NCHN)=0.5D0*FACGG1
29302 SIGH(NCHN)=0.5D0*FACGG2
29305 ELSEIF(ISUB.EQ.14) THEN
29306 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
29307 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
29308 DO 160 I=MMINA,MMAXA
29309 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29310 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
29311 EI=KCHG(IABS(I),1)/3D0
29316 SIGH(NCHN)=FACGG*EI**2
29319 ELSEIF(ISUB.EQ.18) THEN
29320 C...f + fbar -> gamma + gamma
29321 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
29322 DO 170 I=MMINA,MMAXA
29323 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
29324 EI=KCHG(IABS(I),1)/3D0
29326 IF(IABS(I).LE.10) FCOI=FACA/3D0
29331 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
29335 ELSEIF(ISUB.LE.40) THEN
29336 IF(ISUB.EQ.28) THEN
29337 C...f + g -> f + g (q + g -> q + g only)
29338 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
29340 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
29342 DO 190 I=MMINA,MMAXA
29343 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
29345 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
29346 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
29349 ISIG(NCHN,3-ISDE)=21
29354 ISIG(NCHN,3-ISDE)=21
29360 ELSEIF(ISUB.EQ.29) THEN
29361 C...f + g -> f + gamma (q + g -> q + gamma only)
29362 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
29363 DO 210 I=MMINA,MMAXA
29364 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
29365 EI=KCHG(IABS(I),1)/3D0
29368 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
29369 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
29372 ISIG(NCHN,3-ISDE)=21
29378 ELSEIF(ISUB.EQ.33) THEN
29379 C...f + gamma -> f + g (q + gamma -> q + g only)
29380 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
29381 DO 230 I=MMINA,MMAXA
29382 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
29383 EI=KCHG(IABS(I),1)/3D0
29386 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
29387 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
29390 ISIG(NCHN,3-ISDE)=22
29396 ELSEIF(ISUB.EQ.34) THEN
29397 C...f + gamma -> f + gamma
29398 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
29399 DO 250 I=MMINA,MMAXA
29400 IF(I.EQ.0) GOTO 250
29401 EI=KCHG(IABS(I),1)/3D0
29404 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
29405 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
29408 ISIG(NCHN,3-ISDE)=22
29415 ELSEIF(ISUB.LE.80) THEN
29416 IF(ISUB.EQ.53) THEN
29417 C...g + g -> f + fbar (g + g -> q + qbar only)
29418 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
29420 C...Begin by d, u, s flavours.
29422 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
29423 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
29424 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
29425 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
29426 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
29427 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
29428 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29429 & UH2/SH2)*FLAVWT*FACA
29430 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29431 & TH2/SH2)*FLAVWT*FACA
29442 C...Next c and b flavours: modified that and uhat for fixed
29443 C...cos(theta-hat).
29445 SQMAVG=PMAS(IFL,1)**2
29446 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
29447 BE34=SQRT(1D0-4D0*SQMAVG/SH)
29448 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29449 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29450 THUHQ=THQ*UHQ-SQMAVG*SH
29451 IF(MSTP(34).EQ.0) THEN
29452 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
29453 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
29455 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29456 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
29457 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29458 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
29460 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
29461 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
29465 ISIG(NCHN,3)=1+2*(IFL-3)
29470 ISIG(NCHN,3)=2+2*(IFL-3)
29476 ELSEIF(ISUB.EQ.54) THEN
29477 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
29478 CALL PYWIDT(21,SH,WDTP,WDTE)
29480 DO 280 I=1,MIN(8,MDCY(21,3))
29482 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29485 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
29486 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
29493 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
29501 ELSEIF(ISUB.EQ.58) THEN
29502 C...gamma + gamma -> f + fbar
29503 CALL PYWIDT(22,SH,WDTP,WDTE)
29505 DO 290 I=1,MIN(12,MDCY(22,3))
29506 IF(I.LE.8) EF= KCHG(I,1)/3D0
29507 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
29508 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29511 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
29512 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
29520 ELSEIF(ISUB.EQ.68) THEN
29522 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
29523 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
29525 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
29527 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
29533 SIGH(NCHN)=0.5D0*FACGG1
29538 SIGH(NCHN)=0.5D0*FACGG2
29543 SIGH(NCHN)=0.5D0*FACGG3
29546 ELSEIF(ISUB.EQ.80) THEN
29547 C...q + gamma -> q' + pi+/-
29548 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
29549 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
29550 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
29551 DELSH=UH*SQRT(ASSH*Q2FPSH)
29552 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
29553 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
29554 DELUH=SH*SQRT(ASUH*Q2FPUH)
29555 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
29556 IF(I.EQ.0) GOTO 320
29557 EI=KCHG(IABS(I),1)/3D0
29558 EJ=SIGN(1D0-ABS(EI),EI)
29560 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
29561 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
29564 ISIG(NCHN,3-ISDE)=22
29566 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
29571 ELSEIF(ISUB.LE.100) THEN
29572 IF(ISUB.EQ.91) THEN
29573 C...Elastic scattering
29574 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
29576 ELSEIF(ISUB.EQ.92) THEN
29577 C...Single diffractive scattering (first side, i.e. XB)
29578 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
29580 ELSEIF(ISUB.EQ.93) THEN
29581 C...Single diffractive scattering (second side, i.e. AX)
29582 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
29584 ELSEIF(ISUB.EQ.94) THEN
29585 C...Double diffractive scattering
29586 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
29588 ELSEIF(ISUB.EQ.95) THEN
29589 C...Low-pT scattering
29590 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
29592 ELSEIF(ISUB.EQ.96) THEN
29593 C...Multiple interactions: sum of QCD processes
29594 CALL PYWIDT(21,SH,WDTP,WDTE)
29596 C...q + q' -> q + q'
29597 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
29598 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
29599 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
29600 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
29601 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
29602 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
29604 IF(I.EQ.0) GOTO 340
29606 IF(J.EQ.0) GOTO 330
29612 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
29614 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
29619 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
29624 C...q + qbar -> q' + qbar' or g + g
29625 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
29626 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
29627 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29629 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29632 IF(I.EQ.0) GOTO 350
29642 SIGH(NCHN)=0.5D0*FACGG1
29647 SIGH(NCHN)=0.5D0*FACGG2
29651 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
29653 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
29656 IF(I.EQ.0) GOTO 370
29660 ISIG(NCHN,3-ISDE)=21
29665 ISIG(NCHN,3-ISDE)=21
29671 C...g + g -> q + qbar (only d, u, s)
29674 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
29675 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
29676 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
29677 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
29678 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
29679 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
29680 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29681 & UH2/SH2)*FLAVWT*FACA
29682 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29683 & TH2/SH2)*FLAVWT*FACA
29695 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
29698 SQMAVG=PMAS(IFL,1)**2
29699 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
29700 BE34=SQRT(1D0-4D0*SQMAVG/SH)
29701 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29702 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29703 THUHQ=THQ*UHQ-SQMAVG*SH
29704 IF(MSTP(34).EQ.0) THEN
29705 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
29706 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
29708 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29709 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
29710 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29711 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
29713 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
29714 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
29718 ISIG(NCHN,3)=531+2*(IFL-3)
29723 ISIG(NCHN,3)=532+2*(IFL-3)
29729 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
29730 & 2D0*TH/SH+TH2/SH2)*FACA
29731 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
29732 & 2D0*SH/UH+SH2/UH2)*FACA
29733 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
29734 & 2D0*UH/TH+UH2/TH2)
29739 SIGH(NCHN)=0.5D0*FACGG1
29744 SIGH(NCHN)=0.5D0*FACGG2
29749 SIGH(NCHN)=0.5D0*FACGG3
29751 ELSEIF(ISUB.EQ.99) THEN
29752 C...f + gamma* -> f.
29753 IF(MINT(107).EQ.4) THEN
29762 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
29763 PM2RHO=PMAS(PYCOMP(113),1)**2
29764 IF(MSTP(19).EQ.0) THEN
29766 ELSEIF(MSTP(19).EQ.1) THEN
29767 COMFAC=COMFAC/(Q2GA+PM2RHO)
29768 ELSEIF(MSTP(19).EQ.2) THEN
29769 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
29771 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
29773 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
29774 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
29775 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
29776 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
29778 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
29780 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
29782 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
29783 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
29785 DO 390 I=MMINA,MMAXA
29786 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
29787 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
29788 EI=KCHG(IABS(I),1)/3D0
29791 ISIG(NCHN,3-ISDE)=22
29793 SIGH(NCHN)=COMFAC*EI**2
29798 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
29799 C...g + g -> gamma + gamma or g + g -> g + gamma
29814 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
29816 EI=KCHG(IABS(I),1)/3D0
29818 IF(ISUB.EQ.115) EIWT=EI
29823 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
29824 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
29827 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
29828 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
29829 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
29830 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
29836 CALL PYWAUX(1,EPSS,W1SR,W1SI)
29837 CALL PYWAUX(1,EPST,W1TR,W1TI)
29838 CALL PYWAUX(1,EPSU,W1UR,W1UI)
29839 CALL PYWAUX(2,EPSS,W2SR,W2SI)
29840 CALL PYWAUX(2,EPST,W2TR,W2TI)
29841 CALL PYWAUX(2,EPSU,W2UR,W2UI)
29842 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
29843 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
29844 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
29845 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
29846 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
29847 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
29848 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
29849 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
29850 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
29851 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
29852 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
29853 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
29854 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
29855 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
29856 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
29857 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
29858 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
29859 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
29860 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
29861 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
29862 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
29863 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
29864 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
29865 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
29866 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
29867 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
29868 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
29869 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
29870 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
29871 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
29872 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
29873 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
29874 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
29875 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
29876 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
29877 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
29878 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
29879 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
29880 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
29881 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
29882 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
29883 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
29884 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
29885 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
29886 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
29887 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
29888 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
29889 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
29890 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
29891 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
29892 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
29893 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
29894 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
29895 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
29896 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
29897 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
29899 A0STUR=A0STUR+EIWT*B0STUR
29900 A0STUI=A0STUI+EIWT*B0STUI
29901 A0TSUR=A0TSUR+EIWT*B0TSUR
29902 A0TSUI=A0TSUI+EIWT*B0TSUI
29903 A0UTSR=A0UTSR+EIWT*B0UTSR
29904 A0UTSI=A0UTSI+EIWT*B0UTSI
29905 A1STUR=A1STUR+EIWT*B1STUR
29906 A1STUI=A1STUI+EIWT*B1STUI
29907 A2STUR=A2STUR+EIWT*B2STUR
29908 A2STUI=A2STUI+EIWT*B2STUI
29910 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
29911 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
29912 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
29913 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
29914 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
29919 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
29920 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
29923 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
29924 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
29926 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29928 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29930 IF(ISUB.EQ.131) THEN
29931 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
29932 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
29934 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
29936 DO 430 I=MMINA,MMAXA
29937 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
29938 EI=KCHG(IABS(I),1)/3D0
29941 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
29942 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
29945 ISIG(NCHN,3-ISDE)=22
29951 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
29952 C...f + gamma*_(T,L) -> f + gamma
29954 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29956 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29958 IF(ISUB.EQ.133) THEN
29959 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
29960 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
29962 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
29964 DO 450 I=MMINA,MMAXA
29965 IF(I.EQ.0) GOTO 450
29966 EI=KCHG(IABS(I),1)/3D0
29969 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
29970 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
29973 ISIG(NCHN,3-ISDE)=22
29979 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
29980 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
29982 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29984 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29986 CALL PYWIDT(21,SH,WDTP,WDTE)
29988 DO 460 I=1,MIN(8,MDCY(21,3))
29990 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29993 IF(ISUB.EQ.135) THEN
29994 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
29995 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
29997 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
29999 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30006 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30014 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
30015 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
30017 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
30019 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
30020 CALL PYWIDT(22,SH,WDTP,WDTE)
30022 DO 470 I=1,MIN(12,MDCY(22,3))
30023 IF(I.LE.8) EF= KCHG(I,1)/3D0
30024 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30025 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30028 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
30029 IF(ISUB.EQ.137) THEN
30030 FPARAM=-SH*(TH+UH)/DLAMB2
30031 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
30032 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
30033 & 2D0*PH1*PH2*FPARAM**2)
30034 ELSEIF(ISUB.EQ.138) THEN
30035 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30036 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
30037 & 2D0*PH1**2*(TH-UH)**2)
30038 ELSEIF(ISUB.EQ.139) THEN
30039 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30040 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
30041 & 2D0*PH2**2*(TH-UH)**2)
30043 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
30044 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
30046 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30060 C*********************************************************************
30063 C...Subprocess cross sections for heavy flavour production,
30064 C...open and closed.
30065 C...Auxiliary to PYSIGH.
30067 SUBROUTINE PYSGHF(NCHN,SIGS)
30069 C...Double precision and integer declarations
30070 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30071 IMPLICIT INTEGER(I-N)
30072 INTEGER PYK,PYCHGE,PYCOMP
30073 C...Parameter statement to help give large particle numbers.
30074 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30075 &KEXCIT=4000000,KDIMEN=5000000)
30077 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30078 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30079 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30080 COMMON/PYINT1/MINT(400),VINT(400)
30081 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30082 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30083 COMMON/PYINT4/MWID(500),WIDS(500,5)
30084 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30085 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30086 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30087 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30088 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
30091 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30093 C...Determine where are charmonium/bottomonium wave function parameters.
30095 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
30097 C...Convert bottomonium process into equivalent charmonium ones.
30098 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
30100 C...Differential cross section expressions.
30102 IF(ISUB.LE.100) THEN
30103 IF(ISUB.EQ.81) THEN
30104 C...q + qbar -> Q + Qbar
30105 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30106 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30107 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30108 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
30110 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
30112 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30113 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30115 DO 100 I=MMINA,MMAXA
30116 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30117 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
30125 ELSEIF(ISUB.EQ.82) THEN
30126 C...g + g -> Q + Qbar
30127 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30128 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30129 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30130 THUHQ=THQ*UHQ-SQMAVG*SH
30131 IF(MSTP(34).EQ.0) THEN
30132 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30133 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30135 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30136 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30137 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30138 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30140 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
30141 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
30142 IF(MSTP(35).GE.1) THEN
30143 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
30144 FACQQ1=FACQQ1*FATRE
30145 FACQQ2=FACQQ2*FATRE
30148 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30149 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30152 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
30165 ELSEIF(ISUB.EQ.83) THEN
30166 C...f + q -> f' + Q
30167 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
30168 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
30169 DO 130 I=MMIN1,MMAX1
30170 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
30171 DO 120 J=MMIN2,MMAX2
30172 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
30173 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
30174 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
30175 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
30181 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
30182 & (IABS(I)+1)/2)*VINT(180+J)
30183 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
30184 & (MINT(55)+1)/2)*VINT(180+J)
30187 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
30188 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30191 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
30192 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30195 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
30196 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
30198 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
30204 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
30205 & (IABS(J)+1)/2)*VINT(180+I)
30206 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
30207 & (MINT(55)+1)/2)*VINT(180+I)
30209 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
30210 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30213 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
30214 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30217 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
30218 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
30223 ELSEIF(ISUB.EQ.84) THEN
30224 C...g + gamma -> Q + Qbar
30225 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30226 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30227 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30228 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
30229 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
30231 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
30233 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30234 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30236 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30243 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30251 ELSEIF(ISUB.EQ.85) THEN
30252 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
30253 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30254 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30255 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30256 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
30257 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
30258 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
30259 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
30260 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
30261 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
30262 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
30264 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
30265 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
30266 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
30268 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30276 ELSEIF(ISUB.EQ.86) THEN
30277 C...g + g -> J/Psi + g
30278 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
30279 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30280 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30281 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30289 ELSEIF(ISUB.EQ.87) THEN
30290 C...g + g -> chi_0c + g
30291 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30292 QGTW=(SH*TH*UH)/SH**3
30294 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
30295 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
30296 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
30297 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
30298 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
30299 & (QGTW*(QGTW-RGTW*PGTW)**4)
30300 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30308 ELSEIF(ISUB.EQ.88) THEN
30309 C...g + g -> chi_1c + g
30310 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30311 QGTW=(SH*TH*UH)/SH**3
30313 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
30314 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
30315 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
30316 & (QGTW-RGTW*PGTW)**4
30317 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30325 ELSEIF(ISUB.EQ.89) THEN
30326 C...g + g -> chi_2c + g
30327 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30328 QGTW=(SH*TH*UH)/SH**3
30330 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
30331 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
30332 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
30333 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
30334 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
30335 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
30336 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30345 ELSEIF(ISUB.LE.200) THEN
30346 IF(ISUB.EQ.104) THEN
30347 C...g + g -> chi_c0.
30349 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
30350 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
30351 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
30352 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30360 ELSEIF(ISUB.EQ.105) THEN
30361 C...g + g -> chi_c2.
30363 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
30364 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
30365 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
30366 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30374 ELSEIF(ISUB.EQ.106) THEN
30375 C...g + g -> J/Psi + gamma.
30376 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
30377 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
30378 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30379 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30380 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30388 ELSEIF(ISUB.EQ.107) THEN
30389 C...g + gamma -> J/Psi + g.
30390 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
30391 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*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,21)*KFAC(2,22).NE.0) THEN
30401 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30409 ELSEIF(ISUB.EQ.108) THEN
30410 C...gamma + gamma -> J/Psi + gamma.
30411 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
30412 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
30413 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30414 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30415 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30425 C...Additional code by Stefan Wolf
30428 C...Common code for quarkonium production.
30435 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
30436 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
30438 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
30439 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
30443 IF(MSTP(145).EQ.1) THEN
30444 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
30445 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
30446 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
30447 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
30448 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
30449 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
30450 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
30451 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
30452 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
30453 & ISUB.GE.437) THEN
30454 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
30455 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
30456 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
30457 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
30458 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
30459 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
30463 SMQQ2=SQMQQ*VINT(2)
30464 C...Polarisation frames
30465 IF(MSTP(146).EQ.1) THEN
30467 POLH1=SQRT(AQ2-SMQQ2)
30468 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
30471 AX=AQ*BQ/(POLH1*POLH2)
30473 ELSEIF(MSTP(146).EQ.2) THEN
30474 C...Gottfried Jackson frame
30476 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
30479 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
30480 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
30481 ELSEIF(MSTP(146).EQ.3) THEN
30484 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
30487 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
30488 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
30489 ELSEIF(MSTP(146).EQ.4) THEN
30490 C...Collins Soper frame
30492 POLH2=SQRT(VINT(2)*POLH1)
30495 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
30496 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
30498 C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
30499 EL1K10=AZ*ATILK1+BZ*BTILK1
30500 EL1K20=AZ*ATILK2+BZ*BTILK2
30503 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
30504 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
30509 IF(ISUB.EQ.421) THEN
30510 C...g + g -> QQ~[3S11] + g
30511 IF(MSTP(145).EQ.0) THEN
30512 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
30513 * & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
30514 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
30515 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
30516 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
30517 * & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
30519 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
30520 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
30524 IF(MSTP(147).EQ.0) THEN
30525 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30526 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30527 ELSEIF(MSTP(147).EQ.1) THEN
30528 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30529 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30530 ELSEIF(MSTP(147).EQ.3) THEN
30531 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30532 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30533 ELSEIF(MSTP(147).EQ.4) THEN
30534 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30535 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30536 ELSEIF(MSTP(147).EQ.5) THEN
30537 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30538 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30539 ELSEIF(MSTP(147).EQ.6) THEN
30540 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30541 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30543 FACQQG=COMFAC*FF*FACQQG
30545 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30550 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
30553 ELSEIF(ISUB.EQ.422) THEN
30554 C...g + g -> QQ~[3S18] + g
30555 IF(MSTP(145).EQ.0) THEN
30556 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
30557 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
30559 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
30561 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
30562 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
30563 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
30567 IF(MSTP(147).EQ.0) THEN
30568 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30569 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30570 ELSEIF(MSTP(147).EQ.1) THEN
30571 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30572 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30573 ELSEIF(MSTP(147).EQ.3) THEN
30574 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30575 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30576 ELSEIF(MSTP(147).EQ.4) THEN
30577 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30578 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30579 ELSEIF(MSTP(147).EQ.5) THEN
30580 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30581 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30582 ELSEIF(MSTP(147).EQ.6) THEN
30583 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30584 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30586 FACQQG=COMFAC*FF*FACQQG
30588 C...Split total contribution into different colour flows just like
30589 C...in g g -> g g (recalculate kinematics for massless partons).
30590 THP=-0.5D0*SH*(1D0-CTH)
30591 UHP=-0.5D0*SH*(1D0+CTH)
30592 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
30593 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
30594 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
30595 FACGGS=FACGG1+FACGG2+FACGG3
30596 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30601 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
30606 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
30611 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
30614 ELSEIF(ISUB.EQ.423) THEN
30615 C...g + g -> QQ~[1S08] + g
30616 IF(MSTP(145).EQ.0) THEN
30617 * FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
30618 * & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
30619 * & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
30620 * & (SHTH2*THUH2*UHSH2)
30621 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
30622 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
30623 & TH2/(SHTH2*THUH2))*
30624 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
30626 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
30627 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
30628 & TH2/(SHTH2*THUH2))*
30629 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
30630 IF(MSTP(147).EQ.0) THEN
30632 ELSEIF(MSTP(147).EQ.1) THEN
30633 FACQQG=COMFAC*2D0*FA
30634 ELSEIF(MSTP(147).EQ.3) THEN
30636 ELSEIF(MSTP(147).EQ.4) THEN
30638 ELSEIF(MSTP(147).EQ.5) THEN
30640 ELSEIF(MSTP(147).EQ.6) THEN
30644 C...Split total contribution into different colour flows just like
30645 C...in g g -> g g (recalculate kinematics for massless partons).
30646 THP=-0.5D0*SH*(1D0-CTH)
30647 UHP=-0.5D0*SH*(1D0+CTH)
30648 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
30649 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
30650 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
30651 FACGGS=FACGG1+FACGG2+FACGG3
30652 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30657 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
30662 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
30667 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
30670 ELSEIF(ISUB.EQ.424) THEN
30671 C...g + g -> QQ~[3PJ8] + g
30673 IF(MSTP(145).EQ.0) THEN
30674 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
30675 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
30676 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
30678 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
30679 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
30680 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
30682 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
30683 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
30684 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
30686 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
30687 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
30688 & +451D0*SH*TH**5+126D0*TH**6)
30689 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
30690 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
30691 & +171D0*SH*TH**5+42D0*TH**6)
30692 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
30693 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
30694 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
30695 & +99D0*SH*TH**3+35D0*TH**4)
30696 & +7D0*SQMQQ**8*SHTH*POLY)/
30697 & (SH*TH*UH*SQMQQR*SQMQQ*
30698 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
30700 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
30701 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
30702 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
30703 & -SQMQQ*SHTH2*POLY**2*
30704 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
30705 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
30706 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
30707 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
30708 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
30709 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
30710 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
30711 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
30712 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
30713 & +145D0*SH*TH**5+34D0*TH**6)
30714 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
30715 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
30717 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
30718 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
30719 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
30720 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
30721 & +3D0*SQMQQ**8*SHTH*POLY)
30722 BB=4D0*SHTH2*POLY**3
30723 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
30724 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
30725 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
30726 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
30727 & +84D0*SH*TH**9+20D0*TH**10)
30728 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
30729 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
30730 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
30732 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
30733 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
30734 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
30736 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
30737 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
30738 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
30739 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
30740 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
30742 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
30743 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
30744 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
30746 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
30747 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
30748 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
30749 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
30751 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
30752 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
30753 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
30754 & +394D0*SH*TH**9+84D0*TH**10)
30755 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
30756 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
30757 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
30758 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
30759 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
30760 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
30761 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
30762 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
30763 & +266D0*SH*TH**6+84D0*TH**7)
30764 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
30765 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
30767 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
30768 & +7D0*SH*TH**3+4*TH**4)
30769 & +SQMQQ**8*SH*(SH-TH)**2*TH
30770 DD=2D0*TH2*SHTH2*POLY**3
30771 & *(-SH2+2*SH*TH+2*TH2)
30772 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
30773 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
30774 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
30775 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
30776 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
30777 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
30778 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
30779 & -210D0*SH*TH**8-60D0*TH**9)
30780 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
30781 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
30782 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
30784 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
30785 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
30786 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
30787 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
30788 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
30789 & -30D0*SH*TH**6-24D0*TH**7)
30790 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
30791 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
30793 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
30794 IF(MSTP(147).EQ.0) THEN
30795 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30796 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30797 ELSEIF(MSTP(147).EQ.1) THEN
30798 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30799 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30800 ELSEIF(MSTP(147).EQ.3) THEN
30801 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30802 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30803 ELSEIF(MSTP(147).EQ.4) THEN
30804 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30805 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30806 ELSEIF(MSTP(147).EQ.5) THEN
30807 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30808 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30809 ELSEIF(MSTP(147).EQ.6) THEN
30810 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30811 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30813 FACQQG=COMFAC*FF*FACQQG
30815 C...Split total contribution into different colour flows just like
30816 C...in g g -> g g (recalculate kinematics for massless partons).
30817 THP=-0.5D0*SH*(1D0-CTH)
30818 UHP=-0.5D0*SH*(1D0+CTH)
30819 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
30820 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
30821 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
30822 FACGGS=FACGG1+FACGG2+FACGG3
30823 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30828 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
30833 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
30838 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
30841 ELSEIF(ISUB.EQ.425) THEN
30842 C...q + g -> q + QQ~[3S18]
30843 IF(MSTP(145).EQ.0) THEN
30844 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
30845 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
30846 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
30848 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
30849 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
30854 IF(MSTP(147).EQ.0) THEN
30855 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30856 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30857 ELSEIF(MSTP(147).EQ.1) THEN
30858 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30859 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30860 ELSEIF(MSTP(147).EQ.3) THEN
30861 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30862 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30863 ELSEIF(MSTP(147).EQ.4) THEN
30864 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30865 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30866 ELSEIF(MSTP(147).EQ.5) THEN
30867 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30868 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30869 ELSEIF(MSTP(147).EQ.6) THEN
30870 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30871 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30873 FACQQG=COMFAC*FF*FACQQG
30875 C...Split total contribution into different colour flows just like
30876 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30877 C...(recalculate kinematics for massless partons).
30878 THP=-0.5D0*SH*(1D0-CTH)
30879 UHP=-0.5D0*SH*(1D0+CTH)
30880 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30881 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30882 FACQGS=FACQG1+FACQG2
30883 DO 2442 I=MMINA,MMAXA
30884 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
30886 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
30887 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
30890 ISIG(NCHN,3-ISDE)=21
30892 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
30895 ISIG(NCHN,3-ISDE)=21
30897 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
30901 ELSEIF(ISUB.EQ.426) THEN
30902 C...q + g -> q + QQ~[1S08]
30903 IF(MSTP(145).EQ.0) THEN
30904 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
30905 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
30907 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
30908 IF(MSTP(147).EQ.0) THEN
30910 ELSEIF(MSTP(147).EQ.1) THEN
30911 FACQQG=COMFAC*2D0*FA
30912 ELSEIF(MSTP(147).EQ.3) THEN
30914 ELSEIF(MSTP(147).EQ.4) THEN
30916 ELSEIF(MSTP(147).EQ.5) THEN
30918 ELSEIF(MSTP(147).EQ.6) THEN
30922 C...Split total contribution into different colour flows just like
30923 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30924 C...(recalculate kinematics for massless partons).
30925 THP=-0.5D0*SH*(1D0-CTH)
30926 UHP=-0.5D0*SH*(1D0+CTH)
30927 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30928 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30929 FACQGS=FACQG1+FACQG2
30930 DO 2444 I=MMINA,MMAXA
30931 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
30933 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
30934 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
30937 ISIG(NCHN,3-ISDE)=21
30939 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
30942 ISIG(NCHN,3-ISDE)=21
30944 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
30948 ELSEIF(ISUB.EQ.427) THEN
30949 C...q + g -> q + QQ~[3PJ8]
30950 IF(MSTP(145).EQ.0) THEN
30951 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
30952 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
30953 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
30954 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
30956 FF=10D0*PARU(1)*AS**3/
30957 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
30958 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
30959 BB=8D0*(SHTH2+TH*UH)
30960 CC=8D0*UHSH*(SHTH+THUH)
30961 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
30962 IF(MSTP(147).EQ.0) THEN
30963 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30964 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30965 ELSEIF(MSTP(147).EQ.1) THEN
30966 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30967 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30968 ELSEIF(MSTP(147).EQ.3) THEN
30969 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30970 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30971 ELSEIF(MSTP(147).EQ.4) THEN
30972 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30973 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30974 ELSEIF(MSTP(147).EQ.5) THEN
30975 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30976 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30977 ELSEIF(MSTP(147).EQ.6) THEN
30978 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30979 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30981 FACQQG=COMFAC*FF*FACQQG
30983 C...Split total contribution into different colour flows just like
30984 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30985 C...(recalculate kinematics for massless partons).
30986 THP=-0.5D0*SH*(1D0-CTH)
30987 UHP=-0.5D0*SH*(1D0+CTH)
30988 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30989 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30990 FACQGS=FACQG1+FACQG2
30991 DO 2446 I=MMINA,MMAXA
30992 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
30994 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
30995 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
30998 ISIG(NCHN,3-ISDE)=21
31000 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
31003 ISIG(NCHN,3-ISDE)=21
31005 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
31009 ELSEIF(ISUB.EQ.428) THEN
31010 C...q + q~ -> g + QQ~[3S18]
31011 IF(MSTP(145).EQ.0) THEN
31012 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
31013 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
31014 & (SQMQQ*SQMQQR*TH*UH*THUH2)
31016 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
31017 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
31022 IF(MSTP(147).EQ.0) THEN
31023 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31024 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31025 ELSEIF(MSTP(147).EQ.1) THEN
31026 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31027 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31028 ELSEIF(MSTP(147).EQ.3) THEN
31029 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31030 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31031 ELSEIF(MSTP(147).EQ.4) THEN
31032 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31033 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31034 ELSEIF(MSTP(147).EQ.5) THEN
31035 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31036 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31037 ELSEIF(MSTP(147).EQ.6) THEN
31038 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31039 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31041 FACQQG=COMFAC*FF*FACQQG
31043 C...Split total contribution into different colour flows just like
31044 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31045 C...(recalculate kinematics for massless partons).
31046 THP=-0.5D0*SH*(1D0-CTH)
31047 UHP=-0.5D0*SH*(1D0+CTH)
31048 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31049 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31050 FACGGS=FACGG1+FACGG2
31051 DO 2447 I=MMINA,MMAXA
31052 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31053 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
31058 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31063 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31066 ELSEIF(ISUB.EQ.429) THEN
31067 C...q + q~ -> g + QQ~[1S08]
31068 IF(MSTP(145).EQ.0) THEN
31069 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
31070 & (TH2+UH2)/(SQMQQR*SH*THUH2)
31072 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
31073 IF(MSTP(147).EQ.0) THEN
31075 ELSEIF(MSTP(147).EQ.1) THEN
31076 FACQQG=COMFAC*2D0*FA
31077 ELSEIF(MSTP(147).EQ.3) THEN
31079 ELSEIF(MSTP(147).EQ.4) THEN
31081 ELSEIF(MSTP(147).EQ.5) THEN
31083 ELSEIF(MSTP(147).EQ.6) THEN
31087 C...Split total contribution into different colour flows just like
31088 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31089 C...(recalculate kinematics for massless partons).
31090 THP=-0.5D0*SH*(1D0-CTH)
31091 UHP=-0.5D0*SH*(1D0+CTH)
31092 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31093 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31094 FACGGS=FACGG1+FACGG2
31095 DO 2448 I=MMINA,MMAXA
31096 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31097 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
31102 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31107 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31110 ELSEIF(ISUB.EQ.430) THEN
31111 C...q + q~ -> g + QQ~[3PJ8]
31112 IF(MSTP(145).EQ.0) THEN
31113 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
31114 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
31115 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
31116 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
31118 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
31119 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
31120 BB=8D0*(UHSH2+SH*TH)
31121 CC=8D0*(SHTH2+SH*UH)
31122 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
31123 IF(MSTP(147).EQ.0) THEN
31124 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31125 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31126 ELSEIF(MSTP(147).EQ.1) THEN
31127 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31128 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31129 ELSEIF(MSTP(147).EQ.3) THEN
31130 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31131 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31132 ELSEIF(MSTP(147).EQ.4) THEN
31133 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31134 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31135 ELSEIF(MSTP(147).EQ.5) THEN
31136 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31137 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31138 ELSEIF(MSTP(147).EQ.6) THEN
31139 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31140 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31142 FACQQG=COMFAC*FF*FACQQG
31144 C...Split total contribution into different colour flows just like
31145 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31146 C...(recalculate kinematics for massless partons).
31147 THP=-0.5D0*SH*(1D0-CTH)
31148 UHP=-0.5D0*SH*(1D0+CTH)
31149 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31150 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31151 FACGGS=FACGG1+FACGG2
31152 DO 2449 I=MMINA,MMAXA
31153 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31154 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
31159 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
31164 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
31167 ELSEIF(ISUB.EQ.431) THEN
31168 C...g + g -> QQ~[3P01] + g
31169 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31170 QGTW=(SH*TH*UH)/SH**3
31172 IF(MSTP(145).EQ.0) THEN
31173 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
31174 & (9D0*RGTW**2*PGTW**4*
31175 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
31176 & -6D0*RGTW*PGTW**3*QGTW*
31177 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
31178 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
31179 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
31180 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31182 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
31183 & (9D0*RGTW**2*PGTW**4*
31184 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
31185 & -6D0*RGTW*PGTW**3*QGTW*
31186 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
31187 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
31188 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
31189 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31190 IF(MSTP(147).EQ.0) THEN
31192 ELSEIF(MSTP(147).EQ.1) THEN
31193 FACQQG=COMFAC*2D0*FC1
31194 ELSEIF(MSTP(147).EQ.3) THEN
31196 ELSEIF(MSTP(147).EQ.4) THEN
31198 ELSEIF(MSTP(147).EQ.5) THEN
31200 ELSEIF(MSTP(147).EQ.6) THEN
31204 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31209 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31212 ELSEIF(ISUB.EQ.432) THEN
31213 C...g + g -> QQ~[3P11] + g
31214 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31215 QGTW=(SH*TH*UH)/SH**3
31217 IF(MSTP(145).EQ.0) THEN
31218 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
31219 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
31220 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
31221 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
31223 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
31224 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
31225 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
31226 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
31227 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
31228 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
31229 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
31230 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
31231 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
31232 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
31233 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
31234 C4=-4D0*THUH*(TH-UH)**2*
31235 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
31236 & -SH2*TH*UH*(TH2+UH2))
31237 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
31238 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
31239 & +SH2*(5D0*THUH2-17D0*TH*UH)))
31240 IF(MSTP(147).EQ.0) THEN
31241 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31242 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31243 ELSEIF(MSTP(147).EQ.1) THEN
31244 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31245 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
31246 ELSEIF(MSTP(147).EQ.3) THEN
31247 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31248 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31249 ELSEIF(MSTP(147).EQ.4) THEN
31250 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31251 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31252 ELSEIF(MSTP(147).EQ.5) THEN
31253 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
31254 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
31255 ELSEIF(MSTP(147).EQ.6) THEN
31256 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31257 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31259 FACQQG=COMFAC*FF*FACQQG
31261 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31266 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31269 ELSEIF(ISUB.EQ.433) THEN
31270 C...g + g -> QQ~[3P21] + g
31271 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31272 QGTW=(SH*TH*UH)/SH**3
31274 IF(MSTP(145).EQ.0) THEN
31275 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
31276 & (12D0*RGTW**2*PGTW**4*
31277 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
31278 & -3D0*RGTW*PGTW**3*QGTW*
31279 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
31280 & +2D0*PGTW**2*QGTW**2*
31281 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
31282 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
31283 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31285 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
31286 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
31287 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
31289 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
31290 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
31291 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
31292 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
31293 & +10D0*(SH2**2+TH2**2))
31294 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
31295 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
31296 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
31297 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
31298 & +4D0*SH*TH*UH2**4*SHTH2)
31299 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
31300 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
31301 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
31302 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
31303 & +10D0*(SH2**2+UH2**2))
31304 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
31305 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
31306 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
31307 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
31308 & +4D0*SH*UH*TH2**4*UHSH2)
31309 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
31310 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
31311 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
31312 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
31313 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
31314 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
31315 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
31316 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
31317 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
31318 & +3D0*(TH2**3+UH2**3)))
31319 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
31320 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
31321 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
31322 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
31323 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
31324 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
31325 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
31327 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
31329 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
31331 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
31332 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
31333 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
31334 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
31335 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
31336 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
31338 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
31340 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
31342 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
31343 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
31344 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
31345 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
31346 & +4D0*SH*TH2**2*UH2**2*THUH2
31347 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
31348 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
31349 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
31350 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
31351 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
31352 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
31353 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
31354 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
31355 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
31356 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
31357 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
31358 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
31359 & +2D0*(TH2**3+UH2**3))
31360 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
31361 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
31362 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
31363 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
31364 IF(MSTP(147).EQ.0) THEN
31365 FACQQG=1D0/3D0*(C1*3D0
31366 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
31367 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
31368 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
31369 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
31370 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
31371 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31372 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31373 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
31374 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31375 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31376 & *(EL1K20*EL2K20-EL1K21*EL2K21)
31377 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
31378 ELSEIF(MSTP(147).EQ.1) THEN
31380 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
31381 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
31382 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
31383 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
31384 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
31385 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
31386 & +EL1K10*EL2K20*EL1K11*EL2K11)
31387 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
31388 & +EL1K10*EL2K20*EL1K21*EL2K21)
31389 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
31390 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
31391 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
31392 & +EL1K20*EL2K20*EL1K11*EL2K11)
31393 ELSEIF(MSTP(147).EQ.2) THEN
31395 & -C2*EL1K11*EL2K11
31396 & -C3*EL1K21*EL2K21
31397 & -C4*EL1K11*EL2K21
31398 & +C5*(EL1K11*EL2K11)**2
31399 & +C6*(EL1K21*EL2K21)**2
31400 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
31401 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
31402 & +(C9+C0)*(EL1K11*EL2K21)**2)
31404 FACQQG=COMFAC*FF*FACQQG
31406 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31411 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31414 ELSEIF(ISUB.EQ.434) THEN
31415 C...q + g -> q + QQ~[3P01]
31416 IF(MSTP(145).EQ.0) THEN
31417 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
31418 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
31420 FA=-PARU(1)*AS**3*(16D0/243D0)*
31421 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
31422 IF(MSTP(147).EQ.0) THEN
31424 ELSEIF(MSTP(147).EQ.1) THEN
31425 FACQQG=COMFAC*2D0*FA
31426 ELSEIF(MSTP(147).EQ.3) THEN
31428 ELSEIF(MSTP(147).EQ.4) THEN
31430 ELSEIF(MSTP(147).EQ.5) THEN
31432 ELSEIF(MSTP(147).EQ.6) THEN
31436 DO 2452 I=MMINA,MMAXA
31437 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
31439 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
31440 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
31443 ISIG(NCHN,3-ISDE)=21
31445 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31449 ELSEIF(ISUB.EQ.435) THEN
31450 C...q + g -> q + QQ~[3P11]
31451 IF(MSTP(145).EQ.0) THEN
31452 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
31453 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
31455 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
31460 IF(MSTP(147).EQ.0) THEN
31461 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31462 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31463 ELSEIF(MSTP(147).EQ.1) THEN
31464 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31465 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
31466 ELSEIF(MSTP(147).EQ.3) THEN
31467 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31468 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31469 ELSEIF(MSTP(147).EQ.4) THEN
31470 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31471 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31472 ELSEIF(MSTP(147).EQ.5) THEN
31473 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
31474 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
31475 ELSEIF(MSTP(147).EQ.6) THEN
31476 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31477 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31479 FACQQG=COMFAC*FF*FACQQG
31481 DO 2454 I=MMINA,MMAXA
31482 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
31484 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
31485 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
31488 ISIG(NCHN,3-ISDE)=21
31490 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31494 ELSEIF(ISUB.EQ.436) THEN
31495 C...q + g -> q + QQ~[3P21]
31496 IF(MSTP(145).EQ.0) THEN
31497 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
31498 & ((6D0*SQMQQ**2+TH2)*UHSH2
31499 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
31500 & (SQMQQR*TH*UHSH2**2)
31502 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
31504 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
31513 IF(MSTP(147).EQ.0) THEN
31514 FACQQG=1D0/3D0*(C1*3D0
31515 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
31516 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
31517 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
31518 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
31519 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
31520 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31521 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31522 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
31523 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31524 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31525 & *(EL1K20*EL2K20-EL1K21*EL2K21)
31526 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
31527 ELSEIF(MSTP(147).EQ.1) THEN
31529 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
31530 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
31531 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
31532 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
31533 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
31534 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
31535 & +EL1K10*EL2K20*EL1K11*EL2K11)
31536 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
31537 & +EL1K10*EL2K20*EL1K21*EL2K21)
31538 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
31539 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
31540 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
31541 & +EL1K20*EL2K20*EL1K11*EL2K11)
31542 ELSEIF(MSTP(147).EQ.2) THEN
31544 & -C2*EL1K11*EL2K11
31545 & -C3*EL1K21*EL2K21
31546 & -C4*EL1K11*EL2K21
31547 & +C5*(EL1K11*EL2K11)**2
31548 & +C6*(EL1K21*EL2K21)**2
31549 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
31550 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
31551 & +(C9+C0)*(EL1K11*EL2K21)**2)
31553 FACQQG=COMFAC*FF*FACQQG
31555 DO 2456 I=MMINA,MMAXA
31556 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
31558 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
31559 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
31562 ISIG(NCHN,3-ISDE)=21
31564 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31568 ELSEIF(ISUB.EQ.437) THEN
31569 C...q + q~ -> g + QQ~[3P01]
31570 IF(MSTP(145).EQ.0) THEN
31571 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
31572 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
31574 FA=PARU(1)*AS**3*(128D0/729D0)*
31575 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
31576 IF(MSTP(147).EQ.0) THEN
31578 ELSEIF(MSTP(147).EQ.1) THEN
31579 FACQQG=COMFAC*2D0*FA
31580 ELSEIF(MSTP(147).EQ.3) THEN
31582 ELSEIF(MSTP(147).EQ.4) THEN
31584 ELSEIF(MSTP(147).EQ.5) THEN
31586 ELSEIF(MSTP(147).EQ.6) THEN
31590 DO 2457 I=MMINA,MMAXA
31591 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31592 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
31597 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31600 ELSEIF(ISUB.EQ.438) THEN
31601 C...q + q~ -> g + QQ~[3P11]
31602 IF(MSTP(145).EQ.0) THEN
31603 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
31604 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
31606 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
31611 IF(MSTP(147).EQ.0) THEN
31612 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31613 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31614 ELSEIF(MSTP(147).EQ.1) THEN
31615 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31616 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
31617 ELSEIF(MSTP(147).EQ.3) THEN
31618 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31619 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31620 ELSEIF(MSTP(147).EQ.4) THEN
31621 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31622 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31623 ELSEIF(MSTP(147).EQ.5) THEN
31624 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
31625 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
31626 ELSEIF(MSTP(147).EQ.6) THEN
31627 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31628 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31630 FACQQG=COMFAC*FF*FACQQG
31632 DO 2458 I=MMINA,MMAXA
31633 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31634 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
31639 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31642 ELSEIF(ISUB.EQ.439) THEN
31643 C...q + q~ -> g + QQ~[3P21]
31644 IF(MSTP(145).EQ.0) THEN
31645 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
31646 & ((6D0*SQMQQ**2+SH2)*THUH2
31647 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
31648 & (SQMQQR*SH*THUH2**2)
31650 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
31652 C2=4D0*(SH2+UH2+2D0*SH*THUH)
31653 C3=4D0*(SH2+TH2+2D0*SH*THUH)
31654 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
31661 IF(MSTP(147).EQ.0) THEN
31662 FACQQG=1D0/3D0*(C1*3D0
31663 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
31664 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
31665 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
31666 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
31667 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
31668 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31669 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31670 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
31671 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31672 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31673 & *(EL1K20*EL2K20-EL1K21*EL2K21)
31674 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
31675 ELSEIF(MSTP(147).EQ.1) THEN
31677 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
31678 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
31679 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
31680 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
31681 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
31682 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
31683 & +EL1K10*EL2K20*EL1K11*EL2K11)
31684 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
31685 & +EL1K10*EL2K20*EL1K21*EL2K21)
31686 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
31687 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
31688 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
31689 & +EL1K20*EL2K20*EL1K11*EL2K11)
31690 ELSEIF(MSTP(147).EQ.2) THEN
31692 & -C2*EL1K11*EL2K11
31693 & -C3*EL1K21*EL2K21
31694 & -C4*EL1K11*EL2K21
31695 & +C5*(EL1K11*EL2K11)**2
31696 & +C6*(EL1K21*EL2K21)**2
31697 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
31698 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
31699 & +(C9+C0)*(EL1K11*EL2K21)**2)
31701 FACQQG=COMFAC*FF*FACQQG
31703 DO 2459 I=MMINA,MMAXA
31704 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31705 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
31710 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31720 C*********************************************************************
31723 C...Subprocess cross sections for W/Z processes,
31724 C...except that longitudinal WW scattering is in Higgs sector.
31725 C...Auxiliary to PYSIGH.
31727 SUBROUTINE PYSGWZ(NCHN,SIGS)
31729 C...Double precision and integer declarations
31730 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31731 IMPLICIT INTEGER(I-N)
31732 INTEGER PYK,PYCHGE,PYCOMP
31733 C...Parameter statement to help give large particle numbers.
31734 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31735 &KEXCIT=4000000,KDIMEN=5000000)
31737 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31738 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31739 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
31740 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
31741 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31742 COMMON/PYINT1/MINT(400),VINT(400)
31743 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31744 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31745 COMMON/PYINT4/MWID(500),WIDS(500,5)
31746 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
31747 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
31748 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
31749 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
31750 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
31751 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
31752 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
31753 C...Local arrays and complex numbers
31754 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
31756 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
31758 C...Differential cross section expressions.
31760 IF(ISUB.LE.20) THEN
31762 C...f + fbar -> gamma*/Z0
31764 CALL PYWIDT(23,SH,WDTP,WDTE)
31766 FACZ=4D0*COMFAC*3D0
31769 DO 100 I=MMINA,MMAXA
31770 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
31771 EI=KCHG(IABS(I),1)/3D0
31775 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
31777 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
31782 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
31783 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
31784 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
31785 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
31788 ELSEIF(ISUB.EQ.2) THEN
31789 C...f + fbar' -> W+/-
31790 CALL PYWIDT(24,SH,WDTP,WDTE)
31792 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
31793 HP=AEM/(24D0*XW)*SH
31794 DO 120 I=MMIN1,MMAX1
31795 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
31797 DO 110 J=MMIN2,MMAX2
31798 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
31800 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
31801 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31803 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31805 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
31810 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
31811 SIGH(NCHN)=HI*FACBW*HF
31815 ELSEIF(ISUB.EQ.15) THEN
31816 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
31817 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31818 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31822 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31823 DO 130 I=1,MIN(16,MDCY(23,3))
31825 IF(MDME(IDC,1).LT.0) GOTO 130
31827 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
31831 AF=SIGN(1D0,EF+0.1D0)
31833 ELSEIF(I.LE.16) THEN
31835 AF=SIGN(1D0,EF+0.1D0)
31838 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31839 IF(4D0*RM1.LT.1D0) THEN
31841 IF(I.LE.8) FCOF=3D0*RADC4
31842 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31844 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31845 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31846 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31847 & AF**2*(1D0-4D0*RM1))*BE34
31851 C...Propagators: as simulated in PYOFSH and as desired
31852 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31856 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31858 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31859 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31860 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31861 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31862 C...Loop over flavours; consider full gamma/Z structure
31863 DO 140 I=MMINA,MMAXA
31864 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31865 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
31866 EI=KCHG(IABS(I),1)/3D0
31873 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
31874 & (VI**2+AI**2)*HFZZ)/HBW4
31877 ELSEIF(ISUB.EQ.16) THEN
31878 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
31879 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31880 C...Propagators: as simulated in PYOFSH and as desired
31881 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31882 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31883 GMMWC=SQRT(SQM4)*WDTP(0)
31884 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31885 FACWG=FACWG*HBW4C/HBW4
31886 DO 160 I=MMIN1,MMAX1
31888 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
31889 DO 150 J=MMIN2,MMAX2
31891 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
31892 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
31893 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31894 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31895 FCKM=VCKM((IA+1)/2,(JA+1)/2)
31900 SIGH(NCHN)=FACWG*FCKM*WIDSC
31904 ELSEIF(ISUB.EQ.19) THEN
31905 C...f + fbar -> gamma + (gamma*/Z0)
31906 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31907 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31911 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31912 DO 170 I=1,MIN(16,MDCY(23,3))
31914 IF(MDME(IDC,1).LT.0) GOTO 170
31916 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
31920 AF=SIGN(1D0,EF+0.1D0)
31922 ELSEIF(I.LE.16) THEN
31924 AF=SIGN(1D0,EF+0.1D0)
31927 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31928 IF(4D0*RM1.LT.1D0) THEN
31930 IF(I.LE.8) FCOF=3D0*RADC4
31931 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31933 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31934 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31935 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31936 & AF**2*(1D0-4D0*RM1))*BE34
31940 C...Propagators: as simulated in PYOFSH and as desired
31941 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31945 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31947 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31948 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31949 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31950 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31951 C...Loop over flavours; consider full gamma/Z structure
31952 DO 180 I=MMINA,MMAXA
31953 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
31954 EI=KCHG(IABS(I),1)/3D0
31958 IF(IABS(I).LE.10) FCOI=FACA/3D0
31963 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
31964 & (VI**2+AI**2)*HFZZ)/HBW4
31967 ELSEIF(ISUB.EQ.20) THEN
31968 C...f + fbar' -> gamma + W+/-
31969 FACGW=COMFAC*0.5D0*AEM**2/XW
31970 C...Propagators: as simulated in PYOFSH and as desired
31971 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31972 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31973 GMMWC=SQRT(SQM4)*WDTP(0)
31974 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31975 FACGW=FACGW*HBW4C/HBW4
31976 C...Anomalous couplings
31977 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31980 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
31981 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
31982 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
31983 & (4D0*SQMW))/(TH+UH)**2
31985 DO 200 I=MMIN1,MMAX1
31987 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
31988 DO 190 J=MMIN2,MMAX2
31990 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
31991 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
31992 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31994 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31995 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31997 FACWR=UH/(TH+UH)-1D0/3D0
31998 FCKM=VCKM((IA+1)/2,(JA+1)/2)
32005 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
32010 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
32015 ELSEIF(ISUB.LE.40) THEN
32016 IF(ISUB.EQ.22) THEN
32017 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
32018 C...Kinematics dependence
32019 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
32020 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
32021 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32027 RADC3=1D0+PYALPS(SQM3)/PARU(1)
32028 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32029 DO 230 I=1,MIN(16,MDCY(23,3))
32031 IF(MDME(IDC,1).LT.0) GOTO 230
32033 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
32034 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
32037 AF=SIGN(1D0,EF+0.1D0)
32039 ELSEIF(I.LE.16) THEN
32041 AF=SIGN(1D0,EF+0.1D0)
32044 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
32045 IF(4D0*RM1.LT.1D0) THEN
32047 IF(I.LE.8) FCOF=3D0*RADC3
32048 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32050 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32051 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32052 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32053 & AF**2*(1D0-4D0*RM1))*BE34
32056 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32057 IF(4D0*RM1.LT.1D0) THEN
32059 IF(I.LE.8) FCOF=3D0*RADC4
32060 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32062 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32063 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32064 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32065 & AF**2*(1D0-4D0*RM1))*BE34
32069 C...Propagators: as simulated in PYOFSH and as desired
32070 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32071 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32075 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32077 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32079 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
32080 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
32081 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
32086 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32088 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32090 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
32091 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
32092 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
32094 C...Loop over flavours; separate left- and right-handed couplings
32095 DO 270 I=MMINA,MMAXA
32096 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
32097 EI=KCHG(IABS(I),1)/3D0
32103 IF(IABS(I).LE.10) FCOI=FACA/3D0
32105 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
32106 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
32107 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
32108 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
32110 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
32111 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
32112 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
32113 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
32118 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
32121 ELSEIF(ISUB.EQ.23) THEN
32122 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
32123 FACZW=COMFAC*0.5D0*(AEM/XW)**2
32124 FACZW=FACZW*WIDS(23,2)
32125 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32126 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
32127 DO 290 I=MMIN1,MMAX1
32129 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
32130 DO 280 J=MMIN2,MMAX2
32132 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
32133 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
32134 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32136 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32138 AI=SIGN(1D0,EI+0.1D0)
32141 AJ=SIGN(1D0,EJ+0.1D0)
32143 IF(VI+AI.GT.0) THEN
32152 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
32154 IF(IA.LE.10) FCOI=FACA/3D0
32159 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
32160 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
32161 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
32162 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
32163 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
32164 & WIDS(24,(5-KCHW)/2)
32165 C***Protect against slightly negative cross sections. (Reason yet to be
32166 C***sorted out. One possibility: addition of width to the W propagator.)
32167 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
32171 ELSEIF(ISUB.EQ.25) THEN
32172 C...f + fbar -> W+ + W-
32173 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
32175 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
32176 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
32177 CALL PYWIDT(24,SQM3,WDTP,WDTE)
32178 GMMW3=SQRT(SQM3)*WDTP(0)
32179 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
32180 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32181 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32182 GMMW4=SQRT(SQM4)*WDTP(0)
32183 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
32184 C...Kinematical functions
32185 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32186 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
32187 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
32188 GT=THUH34+4D0*THUH/TH2
32189 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
32190 GU=THUH34+4D0*THUH/UH2
32191 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
32192 C...Common factors and couplings
32193 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
32194 FACWW=FACWW*WIDS(24,1)
32196 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
32197 CZZ=AEM**2/(32D0*XW**2)*HBWZC
32198 CNG=AEM**2/(4D0*XW)
32199 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
32200 CNN=AEM**2/(16D0*XW**2)
32201 C...Coulomb factor for W+W- pair
32202 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
32203 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
32204 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
32205 IF(COULE.LT.100D0*PMAS(24,2)) THEN
32206 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
32207 & PMAS(24,2)**2)-COULE))
32209 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
32211 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
32212 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
32213 & PMAS(24,2)**2)+COULE))
32215 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
32218 IF(MSTP(40).EQ.1) THEN
32219 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
32220 & MAX(1D-10,2D0*COULP*COULP1))
32221 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
32222 ELSEIF(MSTP(40).EQ.2) THEN
32223 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
32224 COULCP=DCMPLX(0D0,DBLE(COULP))
32225 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
32226 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
32227 & (4D0*COULCP)*LOG(COULCD)
32228 COULCS=DCMPLX(0D0,0D0)
32231 COULXX=(ISTP-0.5)/NSTP
32232 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
32233 & (1D0+COULXX/COULCD))
32235 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
32237 FACCOU=ABS(COULCR)**2
32238 ELSEIF(MSTP(40).EQ.3) THEN
32239 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
32240 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
32241 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
32243 ELSEIF(MSTP(40).EQ.4) THEN
32244 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
32250 C...Loop over allowed flavours
32251 DO 310 I=MMINA,MMAXA
32252 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
32253 EI=KCHG(IABS(I),1)/3D0
32254 AI=SIGN(1D0,EI+0.1D0)
32257 IF(IABS(I).LE.10) FCOI=FACA/3D0
32258 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
32260 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
32261 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
32263 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
32264 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
32267 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
32268 BET=SQRT(1D0-4D0*XMW02/SH)
32269 GAT=1D0/SQRT(1D0-BET**2)
32271 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
32272 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
32273 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
32274 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
32275 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
32276 & (1D0-2D0*BET*CTH+BET**2))
32277 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
32278 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
32279 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
32280 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
32281 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
32282 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
32283 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
32290 SIGH(NCHN)=FACWW*FCOI*DSIGWW
32293 ELSEIF(ISUB.EQ.30) THEN
32294 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
32295 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
32297 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32301 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32302 DO 320 I=1,MIN(16,MDCY(23,3))
32304 IF(MDME(IDC,1).LT.0) GOTO 320
32306 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32310 AF=SIGN(1D0,EF+0.1D0)
32312 ELSEIF(I.LE.16) THEN
32314 AF=SIGN(1D0,EF+0.1D0)
32317 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32318 IF(4D0*RM1.LT.1D0) THEN
32320 IF(I.LE.8) FCOF=3D0*RADC4
32321 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32323 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32324 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32325 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32326 & AF**2*(1D0-4D0*RM1))*BE34
32330 C...Propagators: as simulated in PYOFSH and as desired
32331 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32335 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32337 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32338 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32339 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32340 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32341 C...Loop over flavours; consider full gamma/Z structure
32342 DO 340 I=MMINA,MMAXA
32343 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
32344 EI=KCHG(IABS(I),1)/3D0
32347 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
32348 & (VI**2+AI**2)*HFZZ)/HBW4
32350 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
32351 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
32354 ISIG(NCHN,3-ISDE)=21
32360 ELSEIF(ISUB.EQ.31) THEN
32361 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
32362 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
32363 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
32364 C...Propagators: as simulated in PYOFSH and as desired
32365 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32366 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32367 GMMWC=SQRT(SQM4)*WDTP(0)
32368 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32369 FACWQ=FACWQ*HBW4C/HBW4
32370 DO 360 I=MMINA,MMAXA
32371 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
32373 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
32374 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32376 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
32377 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
32380 ISIG(NCHN,3-ISDE)=21
32382 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
32386 ELSEIF(ISUB.EQ.35) THEN
32387 C...f + gamma -> f + (gamma*/Z0)
32388 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
32389 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
32390 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
32391 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
32392 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
32393 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
32395 FZQN=SH2+UH2+2D0*SQM4*TH
32398 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
32399 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32403 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32404 DO 370 I=1,MIN(16,MDCY(23,3))
32406 IF(MDME(IDC,1).LT.0) GOTO 370
32408 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32412 AF=SIGN(1D0,EF+0.1D0)
32414 ELSEIF(I.LE.16) THEN
32416 AF=SIGN(1D0,EF+0.1D0)
32419 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32420 IF(4D0*RM1.LT.1D0) THEN
32422 IF(I.LE.8) FCOF=3D0*RADC4
32423 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32425 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32426 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32427 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32428 & AF**2*(1D0-4D0*RM1))*BE34
32432 C...Propagators: as simulated in PYOFSH and as desired
32433 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32437 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32439 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32440 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32441 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32442 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32443 C...Loop over flavours; consider full gamma/Z structure
32444 DO 390 I=MMINA,MMAXA
32445 IF(I.EQ.0) GOTO 390
32446 EI=KCHG(IABS(I),1)/3D0
32449 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
32450 & (VI**2+AI**2)*HFZZ)/HBW4
32451 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
32453 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
32454 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
32457 ISIG(NCHN,3-ISDE)=22
32459 SIGH(NCHN)=FACZQ*FZQN/FZQD
32463 ELSEIF(ISUB.EQ.36) THEN
32464 C...f + gamma -> f' + W+/-
32465 FWQ=COMFAC*AEM**2/(2D0*XW)*
32466 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
32467 C...Propagators: as simulated in PYOFSH and as desired
32468 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32469 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32470 GMMWC=SQRT(SQM4)*WDTP(0)
32471 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32473 DO 410 I=MMINA,MMAXA
32474 IF(I.EQ.0) GOTO 410
32476 EIA=ABS(KCHG(IABS(I),1)/3D0)
32477 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
32478 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
32479 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32481 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
32482 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
32485 ISIG(NCHN,3-ISDE)=22
32487 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
32492 ELSEIF(ISUB.LE.100) THEN
32493 IF(ISUB.EQ.69) THEN
32494 C...gamma + gamma -> W+ + W-
32495 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
32496 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
32497 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
32498 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
32499 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
32507 ELSEIF(ISUB.EQ.70) THEN
32508 C...gamma + W+/- -> Z0 + W+/-
32509 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
32510 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
32511 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
32512 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
32513 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
32514 DO 440 KCHW=1,-1,-2
32516 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
32519 ISIG(NCHN,3-ISDE)=24*KCHW
32521 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
32530 C*********************************************************************
32533 C...Subprocess cross sections for Higgs processes,
32534 C...except Higgs pairs in PYSGSU, but including WW scattering.
32535 C...Auxiliary to PYSIGH.
32537 SUBROUTINE PYSGHG(NCHN,SIGS)
32539 C...Double precision and integer declarations
32540 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32541 IMPLICIT INTEGER(I-N)
32542 INTEGER PYK,PYCHGE,PYCOMP
32543 C...Parameter statement to help give large particle numbers.
32544 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32545 &KEXCIT=4000000,KDIMEN=5000000)
32547 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32548 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32549 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32550 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32551 COMMON/PYINT1/MINT(400),VINT(400)
32552 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
32553 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
32554 COMMON/PYINT4/MWID(500),WIDS(500,5)
32555 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
32556 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32557 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
32558 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
32559 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
32560 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
32561 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
32562 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
32563 C...Local arrays and complex variables
32564 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
32565 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
32566 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
32568 C...Convert H or A process into equivalent h one
32571 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
32572 KFHIGG=KFPR(ISUB,1)
32574 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
32575 &ISUB.LE.190)) THEN
32577 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
32579 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
32580 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
32581 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
32582 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
32583 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
32584 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
32585 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
32586 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
32587 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
32588 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
32589 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
32590 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
32592 SQMH=PMAS(KFHIGG,1)**2
32593 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
32595 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32596 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
32597 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
32598 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
32599 IF(MSTP(46).LE.4) THEN
32600 HDTLH=LOG(PMAS(25,1)/PARP(44))
32601 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
32602 HDTNR=-1D0/18D0+HDTLH/6D0
32604 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
32605 HDTLQ=LOG(PARP(45)/PARP(44))
32606 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
32607 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
32610 C...Calculate lowest and next-to-lowest order partial wave amplitudes
32611 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
32615 HDTLS=LOG(SH/PARP(44)**2)
32616 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
32617 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
32618 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
32619 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
32620 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
32621 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
32622 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
32623 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
32625 C...Unitarize partial wave amplitudes with Pade or K-matrix method
32626 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
32627 A00U=A00L/(1D0-A004/A00L)
32628 A20U=A20L/(1D0-A204/A20L)
32629 A11U=A11L/(1D0-A114/A11L)
32631 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
32632 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
32633 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
32637 C...Differential cross section expressions.
32639 IF(ISUB.LE.60) THEN
32641 C...f + fbar -> h0 (or H0, or A0)
32642 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32644 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32645 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32647 HP=AEM/(8D0*XW)*SH/SQMW*SH
32648 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32649 DO 100 I=MMINA,MMAXA
32650 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
32652 RMQ=PYMRUN(IA,SH)**2/SH
32654 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
32655 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
32657 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
32658 IF(IA.GT.10) IKFI=3
32659 HI=HI*PARU(150+10*IHIGG+IKFI)**2
32660 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
32661 HI=HI/(1D0+RMSS(41))**2
32662 IF(IHIGG.NE.3) THEN
32663 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
32664 & PARU(151+10*IHIGG))**2
32672 SIGH(NCHN)=HI*FACBW*HF
32675 ELSEIF(ISUB.EQ.5) THEN
32677 CALL PYWIDT(25,SH,WDTP,WDTE)
32679 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32680 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
32681 HP=AEM/(8D0*XW)*SH/SQMW*SH
32682 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32684 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
32685 DO 120 I=MMIN1,MMAX1
32686 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
32687 DO 110 J=MMIN2,MMAX2
32688 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
32689 EI=KCHG(IABS(I),1)/3D0
32692 EJ=KCHG(IABS(J),1)/3D0
32699 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
32703 ELSEIF(ISUB.EQ.8) THEN
32705 CALL PYWIDT(25,SH,WDTP,WDTE)
32707 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32708 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
32709 HP=AEM/(8D0*XW)*SH/SQMW*SH
32710 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32712 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
32713 DO 140 I=MMIN1,MMAX1
32714 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
32715 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
32716 DO 130 J=MMIN2,MMAX2
32717 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
32718 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
32719 IF(EI*EJ.GT.0D0) GOTO 130
32724 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
32728 ELSEIF(ISUB.EQ.24) THEN
32729 C...f + fbar -> Z0 + h0 (or H0, or A0)
32730 C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
32731 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32732 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32733 GMMZ3=SQRT(SQM3)*WDTP(0)
32734 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
32735 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32736 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32737 GMMH4=SQRT(SQM4)*WDTP(0)
32738 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
32739 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32740 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
32741 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
32742 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
32743 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
32744 & PARU(154+10*IHIGG)**2
32745 DO 150 I=MMINA,MMAXA
32746 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
32747 EI=KCHG(IABS(I),1)/3D0
32751 IF(IABS(I).LE.10) FCOI=FACA/3D0
32756 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
32759 ELSEIF(ISUB.EQ.26) THEN
32760 C...f + fbar' -> W+/- + h0 (or H0, or A0)
32761 C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
32762 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
32763 CALL PYWIDT(24,SQM3,WDTP,WDTE)
32764 GMMW3=SQRT(SQM3)*WDTP(0)
32765 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
32766 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32767 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32768 GMMH4=SQRT(SQM4)*WDTP(0)
32769 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
32770 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32771 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
32772 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
32773 FACHW=FACHW*WIDS(KFHIGG,2)
32774 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
32775 & PARU(155+10*IHIGG)**2
32776 DO 170 I=MMIN1,MMAX1
32778 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
32779 DO 160 J=MMIN2,MMAX2
32781 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
32782 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
32783 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32785 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32787 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
32789 IF(IA.LE.10) FCOI=FACA/3D0
32794 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
32798 ELSEIF(ISUB.EQ.32) THEN
32799 C...f + g -> f + h0 (q + g -> q + h0 only)
32800 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
32801 C...H propagator: as simulated in PYOFSH and as desired
32802 SQMHC=PMAS(25,1)**2
32803 GMMHC=PMAS(25,1)*PMAS(25,2)
32804 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
32805 CALL PYWIDT(25,SQM4,WDTP,WDTE)
32806 GMMHCC=SQRT(SQM4)*WDTP(0)
32807 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
32808 FHCQ=FHCQ*HBW4C/HBW4
32809 DO 190 I=MMINA,MMAXA
32811 IF(IA.NE.5) GOTO 190
32812 SQML=PYMRUN(IA,SH)**2
32814 FACHCQ=FHCQ*SQML/SQMW*
32815 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
32816 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
32817 & (SQM4-SQMQ-SH)/SH)
32819 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
32820 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
32823 ISIG(NCHN,3-ISDE)=21
32825 SIGH(NCHN)=FACHCQ*WIDS(25,2)
32830 ELSEIF(ISUB.LE.80) THEN
32831 IF(ISUB.EQ.71) THEN
32832 C...Z0 + Z0 -> Z0 + Z0
32833 IF(SH.LE.4.01D0*SQMZ) GOTO 220
32835 IF(MSTP(46).LE.2) THEN
32836 C...Exact scattering ME:s for on-mass-shell gauge bosons
32837 BE2=1D0-4D0*SQMZ/SH
32838 TH=-0.5D0*SH*BE2*(1D0-CTH)
32839 UH=-0.5D0*SH*BE2*(1D0+CTH)
32840 IF(MAX(TH,UH).GT.-1D0) GOTO 220
32841 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
32842 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
32843 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
32844 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
32845 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
32846 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
32847 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
32848 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
32849 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
32850 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
32851 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
32852 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
32853 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
32854 & (ASHIM+ATHIM+AUHIM)**2)
32855 IF(MSTP(46).EQ.2) FACZZ=0D0
32858 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32859 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
32860 & ABS(A00U+2D0*A20U)**2
32862 FACZZ=FACZZ*WIDS(23,1)
32864 DO 210 I=MMIN1,MMAX1
32865 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
32866 EI=KCHG(IABS(I),1)/3D0
32870 DO 200 J=MMIN2,MMAX2
32871 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
32872 EJ=KCHG(IABS(J),1)/3D0
32880 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
32885 ELSEIF(ISUB.EQ.72) THEN
32886 C...Z0 + Z0 -> W+ + W-
32887 IF(SH.LE.4.01D0*SQMZ) GOTO 250
32889 IF(MSTP(46).LE.2) THEN
32890 C...Exact scattering ME:s for on-mass-shell gauge bosons
32891 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
32893 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
32894 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
32895 IF(MAX(TH,UH).GT.-1D0) GOTO 250
32896 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
32897 & (1D0-2D0*SQMZ/SH)
32898 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
32899 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
32900 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
32901 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
32902 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
32903 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
32904 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
32906 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
32907 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
32908 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
32909 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
32910 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
32912 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
32914 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
32915 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
32916 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
32917 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
32918 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
32919 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
32920 & (ATWIM+AUWIM+A4IM)**2)
32923 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32924 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
32925 & ABS(A00U-A20U)**2
32927 FACWW=FACWW*WIDS(24,1)
32929 DO 240 I=MMIN1,MMAX1
32930 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
32931 EI=KCHG(IABS(I),1)/3D0
32935 DO 230 J=MMIN2,MMAX2
32936 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
32937 EJ=KCHG(IABS(J),1)/3D0
32945 SIGH(NCHN)=FACWW*AVI*AVJ
32950 ELSEIF(ISUB.EQ.73) THEN
32951 C...Z0 + W+/- -> Z0 + W+/-
32952 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
32954 IF(MSTP(46).LE.2) THEN
32955 C...Exact scattering ME:s for on-mass-shell gauge bosons
32956 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
32957 EP1=1D0-(SQMZ-SQMW)/SH
32958 EP2=1D0+(SQMZ-SQMW)/SH
32959 TH=-0.5D0*SH*BE2*(1D0-CTH)
32960 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
32961 IF(MAX(TH,UH).GT.-1D0) GOTO 280
32962 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
32963 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
32964 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
32965 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
32966 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
32967 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
32968 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
32970 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
32971 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
32972 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
32973 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
32974 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
32975 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
32976 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
32977 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
32978 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
32979 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
32980 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
32981 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
32983 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
32984 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
32986 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
32987 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
32988 IF(MSTP(46).LE.0) FACZW=0D0
32989 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
32990 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
32991 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
32992 & (ASWIM+AUWIM+A4IM)**2)
32995 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32996 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
32997 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
32999 FACZW=FACZW*WIDS(23,2)
33001 DO 270 I=MMIN1,MMAX1
33002 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
33003 EI=KCHG(IABS(I),1)/3D0
33007 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
33008 DO 260 J=MMIN2,MMAX2
33009 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
33010 EJ=KCHG(IABS(J),1)/3D0
33014 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
33019 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
33024 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
33029 ELSEIF(ISUB.EQ.75) THEN
33030 C...W+ + W- -> gamma + gamma
33032 ELSEIF(ISUB.EQ.76) THEN
33033 C...W+ + W- -> Z0 + Z0
33034 IF(SH.LE.4.01D0*SQMZ) GOTO 310
33036 IF(MSTP(46).LE.2) THEN
33037 C...Exact scattering ME:s for on-mass-shell gauge bosons
33038 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33040 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33041 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33042 IF(MAX(TH,UH).GT.-1D0) GOTO 310
33043 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33044 & (1D0-2D0*SQMZ/SH)
33045 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33046 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33047 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33048 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33049 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33050 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33051 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33053 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33054 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33055 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33056 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33057 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33059 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33061 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33063 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33064 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33065 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33066 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
33067 & (ATWIM+AUWIM+A4IM)**2)
33070 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33071 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33072 & ABS(A00U-A20U)**2
33074 FACZZ=FACZZ*WIDS(23,1)
33076 DO 300 I=MMIN1,MMAX1
33077 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
33078 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33079 DO 290 J=MMIN2,MMAX2
33080 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
33081 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33082 IF(EI*EJ.GT.0D0) GOTO 290
33087 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
33092 ELSEIF(ISUB.EQ.77) THEN
33093 C...W+/- + W+/- -> W+/- + W+/-
33094 IF(SH.LE.4.01D0*SQMW) GOTO 340
33096 IF(MSTP(46).LE.2) THEN
33097 C...Exact scattering ME:s for on-mass-shell gauge bosons
33098 BE2=1D0-4D0*SQMW/SH
33102 TH=-0.5D0*SH*BE2*(1D0-CTH)
33103 UH=-0.5D0*SH*BE2*(1D0+CTH)
33104 IF(MAX(TH,UH).GT.-1D0) GOTO 340
33106 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33107 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33109 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33110 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33112 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33113 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33114 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
33117 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
33119 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
33120 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
33121 ATGRE=0.5D0*XW*SH/TH*TGZANG
33123 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
33125 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
33126 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
33127 AUGRE=0.5D0*XW*SH/UH*UGZANG
33129 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
33131 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
33133 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
33135 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33137 IF(MSTP(46).LE.0) THEN
33142 ELSEIF(MSTP(46).EQ.1) THEN
33143 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33144 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33145 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33146 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33148 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33149 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33150 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33151 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33153 AWWA2=AWWARE**2+AWWAIM**2
33154 AWWS2=AWWSRE**2+AWWSIM**2
33157 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33158 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33159 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
33160 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
33163 DO 330 I=MMIN1,MMAX1
33164 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
33165 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33166 DO 320 J=MMIN2,MMAX2
33167 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
33168 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33169 IF(EI*EJ.LT.0D0) THEN
33171 IF(MSTP(45).EQ.1) GOTO 320
33172 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
33173 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
33176 IF(MSTP(45).EQ.2) GOTO 320
33177 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
33178 IF(MSTP(46).GE.3) FACWW=FWWS
33179 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
33180 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
33186 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
33187 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
33193 ELSEIF(ISUB.LE.120) THEN
33194 IF(ISUB.EQ.102) THEN
33195 C...g + g -> h0 (or H0, or A0)
33196 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33198 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33199 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33200 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33202 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33203 & '(PYSGHG:) did not find Higgs -> g g channel')
33205 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33206 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33207 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33210 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
33215 SIGH(NCHN)=HI*FACBW*HF
33218 ELSEIF(ISUB.EQ.103) THEN
33219 C...gamma + gamma -> h0 (or H0, or A0)
33220 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33222 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33223 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
33224 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
33226 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
33227 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
33229 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33230 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33231 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33234 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
33239 SIGH(NCHN)=HI*FACBW*HF
33242 ELSEIF(ISUB.EQ.110) THEN
33243 C...f + fbar -> gamma + h0
33244 THUH=MAX(TH*UH,SH*CKIN(3)**2)
33245 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
33246 FACHG=FACHG*WIDS(KFHIGG,2)
33247 C...Calculate loop contributions for intermediate gamma* and Z0
33248 CIGTOT=DCMPLX(0D0,0D0)
33249 CIZTOT=DCMPLX(0D0,0D0)
33252 IF(J.LE.2*MSTP(1)) THEN
33255 AJ=SIGN(1D0,EJ+0.1D0)
33257 BALP=SQM4/(2D0*PMAS(J,1))**2
33258 BBET=SH/(2D0*PMAS(J,1))**2
33259 ELSEIF(J.LE.3*MSTP(1)) THEN
33261 JL=2*(J-2*MSTP(1))-1
33262 EJ=KCHG(10+JL,1)/3D0
33263 AJ=SIGN(1D0,EJ+0.1D0)
33265 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
33266 BBET=SH/(2D0*PMAS(10+JL,1))**2
33268 BALP=SQM4/(2D0*PMAS(24,1))**2
33269 BBET=SH/(2D0*PMAS(24,1))**2
33271 BABI=1D0/(BALP-BBET)
33272 IF(BALP.LT.1D0) THEN
33273 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
33276 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
33277 & -DBLE(0.5D0*PARU(1)))
33280 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
33281 IF(BBET.LT.1D0) THEN
33282 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
33285 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
33286 & -DBLE(0.5D0*PARU(1)))
33289 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
33290 IF(J.LE.3*MSTP(1)) THEN
33291 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
33292 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
33293 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
33294 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
33297 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
33298 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
33299 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
33300 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
33301 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
33302 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
33306 CIGTOT=CIGTOT/DBLE(SH)
33307 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
33308 C...Loop over initial flavours
33309 DO 380 I=MMINA,MMAXA
33310 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
33311 EI=KCHG(IABS(I),1)/3D0
33315 IF(IABS(I).LE.10) FCOI=FACA/3D0
33320 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
33321 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
33324 ELSEIF(ISUB.EQ.111) THEN
33325 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
33326 IF(MSTP(38).NE.0) THEN
33327 C...Simple case: only do gg <-> h exactly.
33328 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33330 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33331 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33332 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33334 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33335 & '(PYSGHG:) did not find Higgs -> g g channel')
33336 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
33337 & (TH**2+UH**2)/(SH*SQM4)
33338 C...Propagators: as simulated in PYOFSH and as desired
33339 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33340 GMMHC=SQRT(SQM4)*WDTP(0)
33341 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
33342 & ((SQM4-SQMH)**2+GMMHC**2)
33343 FACGH=FACGH*HBW4C/HBW4
33345 C...Messy case: do full loop integrals
33348 DO 390 I=1,2*MSTP(1)
33352 CALL PYWAUX(1,EPSS,W1SR,W1SI)
33353 CALL PYWAUX(1,EPSH,W1HR,W1HI)
33354 CALL PYWAUX(2,EPSS,W2SR,W2SI)
33355 CALL PYWAUX(2,EPSH,W2HR,W2HI)
33356 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
33357 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
33358 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
33359 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
33361 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
33362 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
33363 FACGH=FACGH*WIDS(25,2)
33365 DO 400 I=MMINA,MMAXA
33366 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33367 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
33375 ELSEIF(ISUB.EQ.112) THEN
33376 C...f + g -> f + h0 (q + g -> q + h0 only)
33377 IF(MSTP(38).NE.0) THEN
33378 C...Simple case: only do gg <-> h exactly.
33379 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33381 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33382 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33383 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33385 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33386 & '(PYSGHG:) did not find Higgs -> g g channel')
33387 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
33388 & (SH**2+UH**2)/(-TH*SQM4)
33389 C...Propagators: as simulated in PYOFSH and as desired
33390 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33391 GMMHC=SQRT(SQM4)*WDTP(0)
33392 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
33393 & ((SQM4-SQMH)**2+GMMHC**2)
33394 FACQH=FACQH*HBW4C/HBW4
33396 C...Messy case: do full loop integrals
33399 DO 410 I=1,2*MSTP(1)
33403 CALL PYWAUX(1,EPST,W1TR,W1TI)
33404 CALL PYWAUX(1,EPSH,W1HR,W1HI)
33405 CALL PYWAUX(2,EPST,W2TR,W2TI)
33406 CALL PYWAUX(2,EPSH,W2HR,W2HI)
33407 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
33408 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
33409 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
33410 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
33412 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
33413 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
33414 FACQH=FACQH*WIDS(25,2)
33416 DO 430 I=MMINA,MMAXA
33417 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
33419 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
33420 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
33423 ISIG(NCHN,3-ISDE)=21
33429 ELSEIF(ISUB.EQ.113) THEN
33430 C...g + g -> g + h0
33431 IF(MSTP(38).NE.0) THEN
33432 C...Simple case: only do gg <-> h exactly.
33433 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33435 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33436 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33437 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33439 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33440 & '(PYSGHG:) did not find Higgs -> g g channel')
33441 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
33442 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
33443 C...Propagators: as simulated in PYOFSH and as desired
33444 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33445 GMMHC=SQRT(SQM4)*WDTP(0)
33446 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
33447 & ((SQM4-SQMH)**2+GMMHC**2)
33448 FACGH=FACGH*HBW4C/HBW4
33450 C...Messy case: do full loop integrals
33459 DO 440 I=1,2*MSTP(1)
33465 IF(EPSH.LT.1D-6) GOTO 440
33466 CALL PYWAUX(1,EPSS,W1SR,W1SI)
33467 CALL PYWAUX(1,EPST,W1TR,W1TI)
33468 CALL PYWAUX(1,EPSU,W1UR,W1UI)
33469 CALL PYWAUX(1,EPSH,W1HR,W1HI)
33470 CALL PYWAUX(2,EPSS,W2SR,W2SI)
33471 CALL PYWAUX(2,EPST,W2TR,W2TI)
33472 CALL PYWAUX(2,EPSU,W2UR,W2UI)
33473 CALL PYWAUX(2,EPSH,W2HR,W2HI)
33474 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
33475 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
33476 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
33477 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
33478 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
33479 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
33480 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
33481 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
33482 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
33483 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
33484 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
33485 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
33486 W3STUR=YHSTUR-Y3STUR-Y3UTSR
33487 W3STUI=YHSTUI-Y3STUI-Y3UTSI
33488 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
33489 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
33490 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
33491 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
33492 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
33493 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
33494 W3USTR=YHUSTR-Y3USTR-Y3TSUR
33495 W3USTI=YHUSTI-Y3USTI-Y3TSUI
33496 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
33497 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
33498 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
33499 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
33500 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
33501 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
33502 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
33503 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
33504 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
33505 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
33506 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
33507 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
33508 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
33509 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
33510 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
33511 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
33512 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
33513 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
33514 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
33515 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
33516 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
33517 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
33518 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
33519 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
33520 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
33521 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
33522 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
33523 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
33524 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
33525 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
33526 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
33527 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
33528 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
33529 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
33530 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
33531 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
33532 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
33533 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
33534 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
33535 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
33536 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
33537 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
33538 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
33539 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
33540 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
33541 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
33542 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
33543 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
33544 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
33545 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
33546 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
33547 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
33548 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
33549 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
33550 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
33551 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
33552 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
33553 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
33554 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
33555 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
33556 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
33557 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
33558 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
33559 & (W2SR-W2HR+W3STUR))
33560 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
33561 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
33562 & (W2TR-W2HR+W3TUSR))
33563 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
33564 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
33565 & (W2UR-W2HR+W3USTR))
33566 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
33567 A2STUR=A2STUR+B2STUR+B2SUTR
33568 A2STUI=A2STUI+B2STUI+B2SUTI
33569 A2USTR=A2USTR+B2USTR+B2UTSR
33570 A2USTI=A2USTI+B2USTI+B2UTSI
33571 A2TUSR=A2TUSR+B2TUSR+B2TSUR
33572 A2TUSI=A2TUSI+B2TUSI+B2TSUI
33573 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
33574 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
33576 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
33577 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
33578 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
33579 FACGH=FACGH*WIDS(25,2)
33581 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
33590 ELSEIF(ISUB.LE.170) THEN
33591 IF(ISUB.EQ.121) THEN
33592 C...g + g -> Q + Qbar + h0
33593 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
33596 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
33597 & (0.5D0*PMF/PMAS(24,1))**2
33599 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
33601 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33603 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33604 IF(IA.GT.10) IKFI=3
33605 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
33606 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33607 FACQQH=FACQQH/(1D0+RMSS(41))**2
33608 IF(IHIGG.NE.3) THEN
33609 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33610 & PARU(151+10*IHIGG))**2
33614 CALL PYQQBH(WTQQBH)
33615 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33617 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33618 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33619 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33625 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
33628 ELSEIF(ISUB.EQ.122) THEN
33629 C...q + qbar -> Q + Qbar + h0
33632 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
33633 & (0.5D0*PMF/PMAS(24,1))**2
33635 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
33637 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33639 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33640 IF(IA.GT.10) IKFI=3
33641 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
33642 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33643 FACQQH=FACQQH/(1D0+RMSS(41))**2
33644 IF(IHIGG.NE.3) THEN
33645 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33646 & PARU(151+10*IHIGG))**2
33650 CALL PYQQBH(WTQQBH)
33651 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33653 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33654 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33655 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33657 DO 470 I=MMINA,MMAXA
33658 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33659 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
33664 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
33667 ELSEIF(ISUB.EQ.123) THEN
33668 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
33670 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
33671 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
33672 & PARU(154+10*IHIGG)**2
33673 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
33674 & (VINT(216)-VINT(209)**2))**2
33675 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
33676 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
33677 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33679 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33680 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33681 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33683 DO 490 I=MMIN1,MMAX1
33684 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
33686 DO 480 J=MMIN2,MMAX2
33687 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
33689 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
33690 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
33692 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
33693 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
33695 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
33696 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
33701 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
33705 ELSEIF(ISUB.EQ.124) THEN
33706 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
33708 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
33709 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
33710 & PARU(155+10*IHIGG)**2
33711 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
33712 & (VINT(216)-VINT(209)**2))**2
33713 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
33714 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33716 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33717 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33718 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33720 DO 510 I=MMIN1,MMAX1
33721 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
33722 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33723 DO 500 J=MMIN2,MMAX2
33724 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
33725 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33726 IF(EI*EJ.GT.0D0) GOTO 500
33727 FACLR=VINT(180+I)*VINT(180+J)
33732 SIGH(NCHN)=FACLR*FACWW*FACBW
33736 ELSEIF(ISUB.EQ.143) THEN
33737 C...f + fbar' -> H+/-
33738 SQMHC=PMAS(37,1)**2
33739 CALL PYWIDT(37,SH,WDTP,WDTE)
33741 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
33742 HP=AEM/(8D0*XW)*SH/SQMW*SH
33743 DO 530 I=MMIN1,MMAX1
33744 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
33746 IM=(MOD(IA,10)+1)/2
33747 DO 520 J=MMIN2,MMAX2
33748 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
33750 JM=(MOD(JA,10)+1)/2
33751 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
33752 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33754 IF(MOD(IA,2).EQ.0) THEN
33761 RML=PYMRUN(IL,SH)**2/SH
33762 RMU=PYMRUN(IU,SH)**2/SH
33763 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
33764 IF(IA.LE.10) HI=HI*FACA/3D0
33765 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33766 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
33771 SIGH(NCHN)=HI*FACBW*HF
33775 ELSEIF(ISUB.EQ.161) THEN
33776 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
33777 C...(choice of only b and t to avoid kinematics problems)
33778 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
33779 C...H propagator: as simulated in PYOFSH and as desired
33780 SQMHC=PMAS(37,1)**2
33781 GMMHC=PMAS(37,1)*PMAS(37,2)
33782 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
33783 CALL PYWIDT(37,SQM4,WDTP,WDTE)
33784 GMMHCC=SQRT(SQM4)*WDTP(0)
33785 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
33786 FHCQ=FHCQ*HBW4C/HBW4
33788 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
33789 DO 550 I=MMINA,MMAXA
33791 IF(IA.NE.5) GOTO 550
33792 SQML=PYMRUN(IA,Q2RM)**2
33794 SQMQ=PYMRUN(IUA,Q2RM)**2
33795 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
33796 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
33797 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
33798 & (SQMHC-SQMQ-SH)/SH)
33799 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33801 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
33802 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
33805 ISIG(NCHN,3-ISDE)=21
33807 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
33808 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
33813 ELSEIF(ISUB.LE.402) THEN
33814 IF(ISUB.EQ.401) THEN
33815 C... g + g -> t + bbar + H-
33816 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
33819 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33821 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
33822 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33828 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
33829 c Since we don't know yet if H+ or H-, assume H+
33830 c when calculating suppression due to closed channels.
33831 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
33832 IF(ABS(WIDS(37,2)-WIDS(37,3))
33833 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
33834 & ABS(WIDS(6,2)-WIDS(6,3))
33835 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
33836 WRITE(*,*)'Error: Process 401 cannot handle different'
33837 WRITE(*,*)'decays for H+ and H- or t and tbar.'
33838 WRITE(*,*)'Execution stopped.'
33843 ELSEIF(ISUB.EQ.402) THEN
33844 C... q + qbar -> t + bbar + H-
33847 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33849 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
33850 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33852 DO 570 I=MMINA,MMAXA
33853 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33854 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
33859 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
33860 c Since we don't know yet if H+ or H-, assume H+
33861 c when calculating suppression due to closed channels.
33862 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
33863 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
33865 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
33867 WRITE(*,*)'Error: Process 402 cannot handle different'
33868 WRITE(*,*)'decays for H+ and H- or t and tbar.'
33869 WRITE(*,*)'Execution stopped.'
33879 C*********************************************************************
33882 C...Subprocess cross sections for SUSY processes,
33883 C...including Higgs pair production.
33884 C...Auxiliary to PYSIGH.
33886 SUBROUTINE PYSGSU(NCHN,SIGS)
33888 C...Double precision and integer declarations
33889 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33890 IMPLICIT INTEGER(I-N)
33891 INTEGER PYK,PYCHGE,PYCOMP
33892 C...Parameter statement to help give large particle numbers.
33893 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33894 &KEXCIT=4000000,KDIMEN=5000000)
33896 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33897 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33898 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33899 COMMON/PYINT1/MINT(400),VINT(400)
33900 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33901 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33902 COMMON/PYINT4/MWID(500),WIDS(500,5)
33903 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33904 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33905 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33906 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33907 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33908 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33909 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33910 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
33911 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
33912 C...Local arrays and complex variables
33913 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
33914 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
33915 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
33916 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
33919 C...Z and W width, combinations of weak mixing angle
33923 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
33925 C...Convert almost equivalent SUSY processes into each other
33926 C...Extract differences in flavours and couplings
33928 C...Sleptons and sneutrinos
33929 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
33930 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33933 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
33934 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33937 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
33938 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33940 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
33941 IF(ISUB.EQ.210) THEN
33943 ELSEIF(ISUB.EQ.211) THEN
33945 ELSEIF(ISUB.EQ.212) THEN
33949 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
33950 IF(ISUB.EQ.213) THEN
33951 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33953 ELSEIF(ISUB.EQ.214) THEN
33960 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
33961 IF(ISUB.EQ.216) THEN
33964 ELSEIF(ISUB.EQ.217) THEN
33967 ELSEIF(ISUB.EQ.218) THEN
33970 ELSEIF(ISUB.EQ.219) THEN
33973 ELSEIF(ISUB.EQ.220) THEN
33976 ELSEIF(ISUB.EQ.221) THEN
33979 ELSEIF(ISUB.EQ.222) THEN
33982 ELSEIF(ISUB.EQ.223) THEN
33985 ELSEIF(ISUB.EQ.224) THEN
33988 ELSEIF(ISUB.EQ.225) THEN
33995 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
33996 IF(ISUB.EQ.226) THEN
33999 ELSEIF(ISUB.EQ.227) THEN
34002 ELSEIF(ISUB.EQ.228) THEN
34008 C...Neutralino + chargino
34009 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
34010 IF(ISUB.EQ.229) THEN
34013 ELSEIF(ISUB.EQ.230) THEN
34016 ELSEIF(ISUB.EQ.231) THEN
34019 ELSEIF(ISUB.EQ.232) THEN
34022 ELSEIF(ISUB.EQ.233) THEN
34025 ELSEIF(ISUB.EQ.234) THEN
34028 ELSEIF(ISUB.EQ.235) THEN
34031 ELSEIF(ISUB.EQ.236) THEN
34037 C...Gluino + neutralino
34038 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
34039 IF(ISUB.EQ.237) THEN
34041 ELSEIF(ISUB.EQ.238) THEN
34043 ELSEIF(ISUB.EQ.239) THEN
34045 ELSEIF(ISUB.EQ.240) THEN
34050 C...Gluino + chargino
34051 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
34052 IF(ISUB.EQ.241) THEN
34054 ELSEIF(ISUB.EQ.242) THEN
34059 C...Squark + neutralino
34060 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
34062 IF(MOD(ISUB,2).NE.0) ILR=1
34063 IF(ISUB.LE.247) THEN
34065 ELSEIF(ISUB.LE.249) THEN
34067 ELSEIF(ISUB.LE.251) THEN
34069 ELSEIF(ISUB.LE.253) THEN
34075 C...Squark + chargino
34076 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
34077 IF(ISUB.LE.255) THEN
34079 ELSEIF(ISUB.LE.257) THEN
34082 IF(MOD(ISUB,2).EQ.0) THEN
34090 C...Squark + gluino
34091 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
34096 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
34098 IF(ISUB.EQ.262) ILR=1
34100 ELSEIF(ISUB.EQ.265) THEN
34104 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
34106 IF(ISUB.LE.273) THEN
34107 IF(ISUB.EQ.273) ILR=1
34110 ELSEIF(ISUB.LE.276) THEN
34111 IF(ISUB.EQ.276) ILR=1
34114 ELSEIF(ISUB.LE.278) THEN
34115 IF(ISUB.EQ.278) ILR=1
34119 IF(ISUB.EQ.280) ILR=1
34124 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
34126 IF(ISUB.LE.283) THEN
34127 IF(ISUB.EQ.283) ILR=1
34130 ELSEIF(ISUB.LE.286) THEN
34131 IF(ISUB.EQ.286) ILR=1
34134 ELSEIF(ISUB.LE.288) THEN
34135 IF(ISUB.EQ.288) ILR=1
34138 ELSEIF(ISUB.LE.290) THEN
34139 IF(ISUB.EQ.290) ILR=1
34142 ELSEIF(ISUB.LE.293) THEN
34143 IF(ISUB.EQ.293) ILR=1
34146 ELSEIF(ISUB.EQ.296) THEN
34150 C...Squark + gluino
34151 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
34156 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
34157 IF(ISUB.EQ.297) THEN
34158 RKF=.5D0*PARU(195)**2
34159 ELSEIF(ISUB.EQ.298) THEN
34160 RKF=.5D0*(1D0-PARU(195)**2)
34164 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
34165 IF(ISUB.EQ.299) THEN
34168 ELSEIF(ISUB.EQ.300) THEN
34174 ELSEIF(ISUB.EQ.301) THEN
34180 C...Supersymmetric processes - all of type 2 -> 2 :
34181 C...correct final-state Breit-Wigners from fixed to running width.
34182 IF(MSTP(42).GT.0) THEN
34184 KFLW=KFPR(ISUBSV,I)
34186 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
34187 IF(I.EQ.1) SQMI=SQM3
34188 IF(I.EQ.2) SQMI=SQM4
34189 SQMS=PMAS(KCW,1)**2
34190 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
34191 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
34192 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
34193 GMMI=SQRT(SQMI)*WDTP(0)
34194 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
34195 COMFAC=COMFAC*(HBWI/HBWS)
34199 C...Differential cross section expressions.
34201 IF(ISUB.LE.210) THEN
34202 IF(ISUB.EQ.201) THEN
34203 C...f + fbar -> e_L + e_Lbar
34204 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34205 DO 130 I=MMIN1,MMAX1
34207 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
34209 TT3I=SIGN(1D0,EI+1D-6)/2D0
34213 C...Color factor for e+ e-
34214 IF(IA.GE.11) FCOL=3D0
34215 IF(ISUBSV.EQ.301) THEN
34218 ELSEIF(ILR.EQ.1) THEN
34219 A1=SFMIX(KFID,3)**2
34220 A2=SFMIX(KFID,4)**2
34221 ELSEIF(ILR.EQ.0) THEN
34222 A1=SFMIX(KFID,1)**2
34223 A2=SFMIX(KFID,2)**2
34225 XLQ=(TT3J-EJ*XW)*A1
34229 TAA=(EI*EJ)**2*(POLL+POLR)
34230 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
34231 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
34232 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
34233 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
34237 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
34243 DK=1D0/(TH-SMZ(II)**2)
34244 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
34246 FREK=FAC2*TANW*EI*ZMIX(II,1)
34247 TNN1=TNN1+FLEK**2*DK
34248 TNN2=TNN2+FREK**2*DK
34250 DL=1D0/(TH-SMZ(JJ)**2)
34251 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
34253 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
34254 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
34257 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
34258 & A2**2*TNN2**2*POLR)
34259 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
34260 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
34261 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
34262 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
34263 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
34266 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
34269 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
34270 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
34271 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
34276 SIGH(NCHN)=FACQQ1+FACQQ2
34279 ELSEIF(ISUB.EQ.203) THEN
34280 C...f + fbar -> e_L + e_Rbar
34281 DO 160 I=MMIN1,MMAX1
34283 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
34284 EI=KCHG(IABS(I),1)/3D0
34285 TT3I=SIGN(1D0,EI)/2D0
34289 C...Color factor for e+ e-
34290 IF(IA.GE.11) FCOL=3D0
34291 A1=SFMIX(KFID,1)**2
34292 A2=SFMIX(KFID,2)**2
34297 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
34298 & /XW**2/XW1**2*A1*A2
34299 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34304 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
34310 DK=1D0/(TH-SMZ(II)**2)
34311 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
34313 FREK=FAC2*TANW*EI*ZMIX(II,1)
34314 TNN1=TNN1+FLEK**2*DK
34315 TNN2=TNN2+FREK**2*DK
34317 DL=1D0/(TH-SMZ(JJ)**2)
34318 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
34320 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
34321 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
34324 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
34325 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
34326 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
34327 TZN=(UH*TH-SQM3*SQM4)*A1*A2
34328 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
34329 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
34332 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
34333 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
34334 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
34340 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34341 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34346 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34347 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34350 ELSEIF(ISUB.EQ.210) THEN
34351 C...q + qbar' -> W*- > ~l_L + ~nu_L
34352 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
34353 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
34354 DO 180 I=MMIN1,MMAX1
34356 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
34357 DO 170 J=MMIN2,MMAX2
34359 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
34360 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
34362 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34363 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
34365 IF(KCHSUM.LT.0) KCHW=3
34370 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
34371 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
34372 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34374 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
34375 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
34377 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
34382 ELSEIF(ISUB.LE.220) THEN
34383 IF(ISUB.EQ.213) THEN
34384 C...f + fbar -> ~nu_L + ~nu_Lbar
34385 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
34386 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34387 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34389 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34392 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
34395 DO 190 I=MMIN1,MMAX1
34397 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
34400 C...Color factor for e+ e-
34401 IF(IA.GE.11) FCOL=3D0
34402 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
34406 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
34407 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
34410 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
34412 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
34418 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
34419 & *AEM**2*FCOL/3D0/XW**2
34422 ELSEIF(ISUB.EQ.216) THEN
34423 C...q + qbar -> ~chi0_1 + ~chi0_1
34424 IF(IZID1.EQ.IZID2) THEN
34425 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34427 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34428 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34430 FACXX=COMFAC*AEM**2/3D0/XW**2
34431 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
34434 WU2 = (UH-ZM12)*(UH-ZM22)
34435 WT2 = (TH-ZM12)*(TH-ZM22)
34436 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
34437 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
34438 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
34440 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
34441 IF(IZID2.NE.IZID1) THEN
34442 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
34445 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
34446 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
34448 DO 210 I=MMINA,MMAXA
34449 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
34450 EI=KCHG(IABS(I),1)/3D0
34451 T3I=SIGN(1D0,EI+1D-6)/2D0
34452 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
34453 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
34454 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
34455 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
34456 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
34457 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
34458 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
34460 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
34461 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
34462 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
34464 IF(IABS(I).GE.11) FCOL=3D0
34465 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
34466 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
34467 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
34468 & QRL*DCONJG(QRR)*POLR)*WS2
34473 SIGH(NCHN)=FACXX*FACGG1*FCOL
34477 ELSEIF(ISUB.LE.230) THEN
34478 IF(ISUB.EQ.226) THEN
34479 C...f + fbar -> ~chi+_1 + ~chi-_1
34480 FACXX=COMFAC*AEM**2/3D0
34483 WU2 = (UH-ZM12)*(UH-ZM22)
34484 WT2 = (TH-ZM12)*(TH-ZM22)
34485 WS2 = SMW(IZID1)*SMW(IZID2)*SH
34486 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
34487 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
34489 IF(IZID1.EQ.IZID2) DIFF=1D0
34491 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
34492 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
34493 IF(IZID2.NE.IZID1) THEN
34494 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
34495 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
34498 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
34499 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
34500 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
34501 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
34502 DO 230 I=MMINA,MMAXA
34503 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
34504 EI=KCHG(IABS(I),1)/3D0
34505 T3I=SIGN(1D0,EI+1D-6)/2D0
34506 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
34507 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
34508 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
34509 IF(MOD(I,2).EQ.0) THEN
34510 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
34511 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
34512 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
34513 & DCMPLX(T3I/XW/(TH-XML2))
34515 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
34516 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
34517 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
34518 & DCMPLX(T3I/XW/(TH-XML2))
34521 IF(IABS(I).GE.11) FCOL=3D0
34522 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
34523 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
34524 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
34525 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
34530 IF(IZID1.EQ.IZID2) THEN
34531 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34533 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34534 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34539 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34540 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34544 ELSEIF(ISUB.EQ.229) THEN
34545 C...q + qbar' -> ~chi0_1 + ~chi+-_1
34546 FACXX=COMFAC*AEM**2/6D0/XW**2
34549 WU2 = (UH-ZM12)*(UH-ZM22)
34550 WT2 = (TH-ZM12)*(TH-ZM22)
34551 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
34552 RT2I = 1D0/SQRT(2D0)
34553 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
34554 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
34556 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
34557 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
34560 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
34562 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
34563 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
34564 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
34565 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
34567 DO 270 I=MMIN1,MMAX1
34569 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
34571 T3I=SIGN(1D0,EI+1D-6)/2D0
34572 DO 260 J=MMIN2,MMAX2
34574 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
34575 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
34577 T3J=SIGN(1D0,EJ+1D-6)/2D0
34579 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34580 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
34582 IF(KCHSUM.LT.0) KCHW=3
34583 IF(MOD(IA,2).EQ.0) THEN
34584 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
34585 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
34586 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
34587 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
34588 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
34589 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
34592 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
34593 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
34594 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
34595 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
34596 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
34597 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
34600 ZINTR=DBLE(QLR*DCONJG(QLL))
34601 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
34607 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34608 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
34613 ELSEIF(ISUB.LE.240) THEN
34614 IF(ISUB.EQ.237) THEN
34615 C...q + qbar -> gluino + ~chi0_1
34616 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34617 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34619 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
34622 DO 280 I=MMINA,MMAXA
34623 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
34624 EI=KCHG(IABS(I),1)/3D0
34626 XLQC = -TANW*EI*ZMIX(IZID,1)
34627 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
34628 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
34631 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
34632 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
34633 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
34634 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
34635 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
34636 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
34637 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
34638 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
34639 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
34640 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
34645 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
34649 ELSEIF(ISUB.LE.250) THEN
34650 IF(ISUB.EQ.241) THEN
34651 C...q + qbar' -> ~chi+-_1 + gluino
34652 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
34655 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
34656 FAC0=UMIX(IZID,1)**2
34657 FAC1=VMIX(IZID,1)**2
34658 DO 300 I=MMIN1,MMAX1
34660 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
34661 DO 290 J=MMIN2,MMAX2
34663 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
34664 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
34666 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34667 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
34669 IF(KCHSUM.LT.0) KCHW=3
34670 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
34671 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
34672 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
34673 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
34674 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
34675 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
34676 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
34677 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
34678 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
34679 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
34680 & SH/(TH-XMU2)/(UH-XMD2))/2D0
34685 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
34686 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34687 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
34691 ELSEIF(ISUB.EQ.243) THEN
34692 C...q + qbar -> gluino + gluino
34693 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34696 DO 310 I=MMINA,MMAXA
34697 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34698 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
34700 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
34701 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
34702 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
34703 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
34704 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
34705 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
34706 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
34707 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
34708 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
34709 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
34710 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
34711 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
34715 C...1/2 for identical particles
34716 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
34719 ELSEIF(ISUB.EQ.244) THEN
34720 C...g + g -> gluino + gluino
34721 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34724 FACQQ1=COMFAC*AS**2*9D0/4D0*(
34725 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
34726 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
34727 FACQQ2=COMFAC*AS**2*9D0/4D0*(
34728 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
34729 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
34730 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
34731 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
34732 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
34737 SIGH(NCHN)=FACQQ1/2D0
34742 SIGH(NCHN)=FACQQ2/2D0
34747 SIGH(NCHN)=FACQQ3/2D0
34750 ELSEIF(ISUB.EQ.246) THEN
34751 C...g + q_j -> ~chi0_1 + ~q_j
34752 FAC0=COMFAC*AS*AEM/6D0/XW
34755 FACZQ0=FAC0*( (ZM2-TH)/SH +
34756 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
34757 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
34758 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34759 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
34760 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
34761 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
34762 EI=KCHG(IABS(I),1)/3D0
34764 XRQZ = -TANW*EI*ZMIX(IZID,1)
34765 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
34766 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
34768 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
34770 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
34776 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
34777 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
34780 ISIG(NCHN,3-ISDE)=21
34782 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34783 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34788 ELSEIF(ISUB.LE.260) THEN
34789 IF(ISUB.EQ.254) THEN
34790 C...g + q_j -> ~chi1_1 + ~q_i
34791 FAC0=COMFAC*AS*AEM/12D0/XW
34796 FACZQ0=FAC0*( (ZM2-TH)/SH +
34797 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
34798 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
34799 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
34800 IF(MOD(KFNSQ1,2).EQ.0) THEN
34807 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
34808 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
34809 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
34811 IF(MOD(IA,2).EQ.0) THEN
34816 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
34820 IF(I.LT.0) KCHWQ=5-KCHW
34822 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
34823 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
34826 ISIG(NCHN,3-ISDE)=21
34828 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34829 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
34833 ELSEIF(ISUB.EQ.258) THEN
34834 C...g + q_j -> gluino + ~q_i
34841 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
34842 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
34843 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
34844 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
34845 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
34847 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
34848 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
34849 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
34851 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
34852 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
34853 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34854 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
34855 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
34856 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
34859 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34860 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34862 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
34863 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
34866 ISIG(NCHN,3-ISDE)=21
34868 SIGH(NCHN)=FACQG1*FACSEL
34871 ISIG(NCHN,3-ISDE)=21
34873 SIGH(NCHN)=FACQG2*FACSEL
34878 ELSEIF(ISUB.LE.270) THEN
34879 IF(ISUB.EQ.261) THEN
34880 C...q_i + q_ibar -> ~t_1 + ~t_1bar
34881 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
34882 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34883 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34885 DO 390 I=MMIN1,MMAX1
34887 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
34888 IF(IA.GE.11.AND.IA.LE.18) THEN
34890 EJ=KCHG(KFNSQ,1)/3D0
34891 T3I=SIGN(1D0,EI)/2D0
34892 T3J=SIGN(1D0,EJ)/2D0
34893 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
34894 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
34895 XLF=2D0*(T3I-EI*XW)
34897 TAA=0.5D0*(EI*EJ)**2
34898 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
34899 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34900 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
34901 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
34902 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
34908 SIGH(NCHN)=FACQQ1*FAC0
34911 ELSEIF(ISUB.EQ.263) THEN
34912 C...f + fbar -> ~t1 + ~t2bar
34913 DO 400 I=MMIN1,MMAX1
34915 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34916 EI=KCHG(IABS(I),1)/3D0
34917 TT3I=SIGN(1D0,EI)/2D0
34921 C...Color factor for e+ e-
34922 IF(IA.GE.11) FCOL=3D0
34923 XLQ=2D0*(TT3J-EJ*XW)
34925 XLF=2D0*(TT3I-EI*XW)
34927 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
34928 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
34929 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34930 C...Factor of 2 for t1 t2bar + t2 t1bar
34931 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
34932 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
34937 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34938 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34943 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34944 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34947 ELSEIF(ISUB.EQ.264) THEN
34948 C...g + g -> ~t_1 + ~t_1bar
34951 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
34952 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34953 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
34954 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
34955 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
34969 ELSEIF(ISUB.LE.280) THEN
34970 IF(ISUB.EQ.271) THEN
34971 C...q + q' -> ~q + ~q' (~g exchange)
34972 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
34981 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
34982 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
34985 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
34986 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
34987 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
34990 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
34991 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
34992 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
34993 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
34995 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
34998 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
34999 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
35001 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
35002 IF(I*J.LT.0) GOTO 420
35007 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35008 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35011 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
35012 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35014 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
35015 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35016 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35023 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
35024 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35026 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
35027 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35028 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35034 ELSEIF(ISUB.EQ.274) THEN
35035 C...q + qbar' -> ~q + ~qbar'
35036 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35040 C...Mrenna...Normalization.and.1/XMT
35041 FACQQ1=COMFAC*AS**2*2D0/9D0*(
35042 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
35043 FACQQB=COMFAC*AS**2*4D0/9D0*(
35044 & (UH*TH-SQM3*SQM4)/SH2 )
35045 FACQQI=-COMFAC*AS**2*4D0/27D0*(
35046 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
35047 FACQQB=FACQQB+FACQQ1+FACQQI
35049 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
35052 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35053 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35054 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
35055 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
35057 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
35060 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35061 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
35063 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
35064 IF(I*J.GT.0) GOTO 440
35069 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35070 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
35071 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
35072 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35076 ELSEIF(ISUB.EQ.277) THEN
35077 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
35078 C...if i .eq. j covered in 274
35079 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
35080 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35082 DO 460 I=MMIN1,MMAX1
35084 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
35085 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
35086 IF(IA.EQ.KFNSQ) GOTO 460
35087 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
35089 EJ=KCHG(KFNSQ,1)/3D0
35091 T3I=SIGN(1D0,EI)/2D0
35093 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
35094 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
35096 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
35097 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
35099 XLF=2D0*(T3I-EI*XW)
35106 TAA=0.5D0*(EI*EJ)**2
35107 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35108 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35109 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35110 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35111 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35112 ELSEIF(IA.LE.6) THEN
35113 FAC0=AS**2*8D0/9D0/2D0
35119 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35122 ELSEIF(ISUB.EQ.279) THEN
35123 C...g + g -> ~q_j + ~q_jbar
35126 C...5=RKF because ~t ~tbar treated separately
35127 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
35128 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
35129 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
35130 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
35135 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35140 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35150 C*********************************************************************
35153 C...Subprocess cross sections for Technicolor processes.
35154 C...Auxiliary to PYSIGH.
35156 SUBROUTINE PYSGTC(NCHN,SIGS)
35158 C...Double precision and integer declarations
35159 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35160 IMPLICIT INTEGER(I-N)
35161 INTEGER PYK,PYCHGE,PYCOMP
35162 C...Parameter statement to help give large particle numbers.
35163 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35164 &KEXCIT=4000000,KDIMEN=5000000)
35166 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35167 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35168 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
35169 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
35170 COMMON/PYINT1/MINT(400),VINT(400)
35171 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
35172 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
35173 COMMON/PYINT4/MWID(500),WIDS(500,5)
35174 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
35175 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
35176 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
35177 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
35178 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
35179 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
35180 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
35181 C...Local arrays and complex variables
35182 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
35183 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
35184 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
35185 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
35186 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
35187 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
35188 COMPLEX*16 DVVS,DVVT,DVVU
35191 C...Combinations of weak mixing angle.
35193 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
35195 C...Convert almost equivalent technicolor processes into
35196 C...a few basic processes, and set distinguishing parameters.
35197 IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
35200 SN2W=2D0*SQRT(XW*XW1)
35203 CSXI=COS(ASIN(RTCM(3)))
35204 CSXIP=COS(ASIN(RTCM(4)))
35205 QUPD=2D0*RTCM(2)-1D0
35206 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
35217 C... rho_tc0, etc. -> W_L W_L, W_L W_T
35218 IF(ISUB.EQ.361) THEN
35222 AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
35223 ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
35224 VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
35225 C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
35226 AXGP = SQRT(2D0)*AXGP
35227 ARGP = SQRT(2D0)*ARGP
35228 VOGP = SQRT(2D0)*VOGP
35229 C... rho_tc0 -> W_L pi_tc-
35230 ELSEIF(ISUB.EQ.362) THEN
35234 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
35236 ELSEIF(ISUB.EQ.363) THEN
35240 CAB2=(1D0-RTCM(3)**2)**2
35241 C... rho_tc0/omega_tc -> gamma pi_tc
35242 ELSEIF(ISUB.EQ.364) THEN
35249 VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
35251 ELSEIF(ISUB.EQ.365) THEN
35255 VRGP=CSXIP/RTCM(12)
35257 VAGP=2D0*Q2UD*CSXIP
35258 VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
35260 ELSEIF(ISUB.EQ.366) THEN
35264 VOGP=CSXI*CT2W/RTCM(12)
35265 VRGP=-QUPD*CSXI*TANW/RTCM(12)
35266 VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
35267 VZGP=-QUPD*CSXI*CS2W/XW1
35269 ELSEIF(ISUB.EQ.367) THEN
35273 C...RTCM(48) is the M_V for the techni-a
35274 VXGP=-CSXIP/SN2W/RTCM(48)
35275 VRGP=CSXIP*CT2W/RTCM(12)
35276 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
35277 VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
35278 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
35280 ELSEIF(ISUB.EQ.368) THEN
35284 C...RTCM(49) is the M_A for the techni-a
35285 AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
35286 VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
35287 ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
35288 VAGP=QUPD*CSXI/(2D0*SQRT(XW))
35289 VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
35290 C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
35291 ELSEIF(ISUB.EQ.370) THEN
35295 ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
35296 AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
35298 ELSEIF(ISUB.EQ.371) THEN
35302 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
35304 ELSEIF(ISUB.EQ.372) THEN
35308 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
35310 ELSEIF(ISUB.EQ.373) THEN
35314 CAB2=(1D0-RTCM(3)**2)**2
35316 ELSEIF(ISUB.EQ.374) THEN
35320 VRGP=QUPD*CSXI/RTCM(12)
35321 VWGP=QUPD*CSXI/(2D0*SQRT(XW))
35322 AXGP=-CSXI/RTCM(49)
35324 ELSEIF(ISUB.EQ.375) THEN
35328 VRGP=-QUPD*CSXI*TANW/RTCM(12)
35329 ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
35330 VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
35331 AXGP=-CSXI*CT2W/RTCM(49)
35333 ELSEIF(ISUB.EQ.376) THEN
35338 ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
35339 AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
35341 ELSEIF(ISUB.EQ.377) THEN
35345 VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
35346 VWGP=CSXIP/(2D0*XW)
35347 VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
35349 ELSEIF(ISUB.EQ.378) THEN
35353 VRGP=QUPD*RTCM(3)/RTCM(12)
35354 AXGP=-RTCM(3)/RTCM(49)
35356 ELSEIF(ISUB.EQ.379) THEN
35360 VOGP=RTCM(3)/RTCM(12)
35361 VRGP=QUPD*RTCM(3)/RTCM(12)
35362 ELSEIF(ISUB.EQ.380) THEN
35366 VOGP=RTCM(3)*CT2W/RTCM(12)
35367 VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
35371 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
35372 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
35373 IF(ITCM(5).LE.4) THEN
35391 ELSEIF(ITCM(5).EQ.5) THEN
35393 IF(ITCM(2).EQ.0) THEN
35398 ALPRHT=2.16D0*(3D0/ITCM(1))
35399 SIN2T=2D0*TANT3/(TANT3**2+1D0)
35400 SINT3=TANT3/SQRT(TANT3**2+1D0)
35401 XIG=SQRT(PYALPS(SH)/ALPRHT)
35402 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
35403 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
35404 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
35405 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
35406 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
35407 & SINT3**2)*2D0/SIN2T
35408 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
35409 & SINT3**2)*2D0/SIN2T
35411 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
35412 SM1112=X12*RTCM(28)**2*SIN2T
35413 SM1121=-X21*RTCM(28)**2*SIN2T
35416 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
35417 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
35420 ZTC(1,1)=DCMPLX(SH,0D0)
35421 CALL PYWIDT(3100021,SH,WDTP,WDTE)
35422 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
35423 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
35424 CALL PYWIDT(3100113,SH,WDTP,WDTE)
35425 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
35426 CALL PYWIDT(3400113,SH,WDTP,WDTE)
35427 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
35428 CALL PYWIDT(3200113,SH,WDTP,WDTE)
35429 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
35430 CALL PYWIDT(3300113,SH,WDTP,WDTE)
35431 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
35433 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
35437 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
35438 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
35439 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
35440 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
35453 CALL PYLDCM(ZTC,6,6,INDX,D)
35457 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
35462 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
35468 XIG=SQRT(PYALPS(-TH)/ALPRHT)
35470 ZTC(1,1)=DCMPLX(TH)
35471 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
35472 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
35473 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
35474 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
35475 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
35477 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
35481 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
35482 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
35483 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
35484 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
35496 CALL PYLDCM(ZTC,6,6,INDX,D)
35500 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
35504 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
35510 XIG=SQRT(PYALPS(-UH)/ALPRHT)
35512 ZTC(1,1)=DCMPLX(UH,0D0)
35513 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
35514 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
35515 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
35516 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
35517 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
35519 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
35523 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
35524 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
35525 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
35526 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
35538 CALL PYLDCM(ZTC,6,6,INDX,D)
35542 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
35546 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
35553 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
35554 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
35555 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
35556 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
35557 DQGS=DGGS-DGVS*DCMPLX(TANT3)
35558 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
35560 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
35561 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
35562 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
35563 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
35564 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
35565 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
35568 SQDQTS=ABS(DQTS)**2
35569 SQDQQS=ABS(DQQS)**2
35570 SQDQQT=ABS(DQQT)**2
35571 SQDQQU=ABS(DQQU)**2
35572 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
35574 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
35576 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
35578 SQDGGS=ABS(DGGS)**2
35579 SQDGGT=ABS(DGGT)**2
35580 SQDGGU=ABS(DGGU)**2
35584 REDGTU=DBLE(DGGU*DCONJG(DGGT))
35585 REDGSU=DBLE(DGGU*DCONJG(DGGS))
35586 REDGST=DBLE(DGGS*DCONJG(DGGT))
35587 REDQST=DBLE(DQQS*DCONJG(DQQT))
35588 REDQTU=DBLE(DQQT*DCONJG(DQQU))
35593 C...Differential cross section expressions.
35595 IF(ISUB.LE.190) THEN
35596 IF(ISUB.EQ.149) THEN
35597 C...g + g -> eta_tc
35598 KCTC=PYCOMP(KTECHN+331)
35599 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
35601 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
35602 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35604 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
35606 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35611 SIGH(NCHN)=HI*FACBW*HF
35614 ELSEIF(ISUB.EQ.165) THEN
35615 C...q + qbar -> l+ + l- (including contact term for compositeness)
35616 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
35617 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
35618 KFF=IABS(KFPR(ISUB,1))
35620 AF=SIGN(1D0,EF+0.1D0)
35625 IF(KFF.LE.10) FCOF=3D0
35627 IF(KFF.EQ.6) WID2=WIDS(6,1)
35628 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
35629 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
35630 DO 260 I=MMINA,MMAXA
35631 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
35632 EI=KCHG(IABS(I),1)/3D0
35633 AI=SIGN(1D0,EI+0.1D0)
35638 IF(IABS(I).LE.10) FCOI=FACA/3D0
35639 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
35640 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
35641 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
35642 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
35644 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
35645 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
35647 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
35648 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
35649 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
35650 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
35651 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
35656 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
35659 ELSEIF(ISUB.EQ.166) THEN
35660 C...q + q'bar -> l + nu_l (including contact term for compositeness)
35661 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
35662 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
35663 KFF=IABS(KFPR(ISUB,1))
35665 IF(KFF.LE.10) FCOF=3D0
35666 DO 280 I=MMIN1,MMAX1
35667 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
35669 DO 270 J=MMIN2,MMAX2
35670 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
35672 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
35673 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35676 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
35678 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
35679 & MOD(J,2).EQ.0)) THEN
35680 IF(KFF.EQ.5) WID2=WIDS(6,2)
35681 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
35682 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
35684 IF(KFF.EQ.5) WID2=WIDS(6,3)
35685 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
35686 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
35692 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
35693 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
35694 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
35699 ELSEIF(ISUB.LE.200) THEN
35700 IF(ISUB.EQ.191) THEN
35701 C...q + qbar -> rho_tc0.
35702 KCTC=PYCOMP(KTECHN+113)
35703 SQMRHT=PMAS(KCTC,1)**2
35704 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35706 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
35707 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35708 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35709 ALPRHT=2.16D0*(3D0/ITCM(1))
35710 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
35711 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
35712 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
35713 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
35714 DO 290 I=MMINA,MMAXA
35715 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
35717 EI=KCHG(IABS(I),1)/3D0
35718 AI=SIGN(1D0,EI+0.1D0)
35722 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
35723 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
35724 IF(IA.LE.10) HI=HI*FACA/3D0
35729 SIGH(NCHN)=HI*FACBW*HF
35732 ELSEIF(ISUB.EQ.192) THEN
35733 C...q + qbar' -> rho_tc+/-.
35734 KCTC=PYCOMP(KTECHN+213)
35735 SQMRHT=PMAS(KCTC,1)**2
35736 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
35738 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
35739 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35740 ALPRHT=2.16D0*(3D0/ITCM(1))
35741 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
35742 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
35743 DO 310 I=MMIN1,MMAX1
35744 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
35746 DO 300 J=MMIN2,MMAX2
35747 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
35749 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
35750 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35752 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35753 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
35755 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
35760 SIGH(NCHN)=HI*FACBW*HF
35764 ELSEIF(ISUB.EQ.193) THEN
35765 C...q + qbar -> omega_tc0.
35766 KCTC=PYCOMP(KTECHN+223)
35767 SQMOMT=PMAS(KCTC,1)**2
35768 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35770 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
35771 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35772 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35773 ALPRHT=2.16D0*(3D0/ITCM(1))
35774 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
35775 & (2D0*RTCM(2)-1D0)**2
35776 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
35777 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
35778 DO 320 I=MMINA,MMAXA
35779 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
35781 EI=KCHG(IABS(I),1)/3D0
35782 AI=SIGN(1D0,EI+0.1D0)
35786 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
35787 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
35788 IF(IA.LE.10) HI=HI*FACA/3D0
35793 SIGH(NCHN)=HI*FACBW*HF
35796 ELSEIF(ISUB.EQ.194) THEN
35797 C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
35798 C...Default final state is e+e-
35800 ALPRHT=2.16D0*(3D0/ITCM(1))
35803 SN2W=2D0*SQRT(XW*XW1)
35804 C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
35805 C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
35807 QUPD=2D0*RTCM(2)-1D0
35808 FAR=SQRT(AEM/ALPRHT)
35812 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
35813 FZX=-FAR/SN2W*RTCM(47)
35819 CALL PYWIDT(23,SH,WDTP,WDTE)
35820 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
35821 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35822 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
35823 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35824 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
35825 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
35826 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
35827 C...Propagator including a_T^0
35828 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
35829 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
35830 C...Add in techni-a contribution
35831 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
35832 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
35833 $ SFZX*SSMR*SSMO)/DETD/SH
35834 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
35835 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
35837 XWRHT=1D0/(4D0*XW*(1D0-XW))
35838 KFF=IABS(KFPR(ISUB,1))
35840 AF=SIGN(1D0,EF+0.1D0)
35845 IF(KFF.LE.10) FCOF=3D0
35848 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
35849 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
35850 DZZ=DZZ*DCMPLX(XWRHT,0D0)
35851 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
35853 DO 330 I=MMINA,MMAXA
35854 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
35855 EI=KCHG(IABS(I),1)/3D0
35856 AI=SIGN(1D0,EI+0.1D0)
35861 IF(IABS(I).LE.10) FCOI=FCOI/3D0
35862 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
35863 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
35864 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
35865 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
35866 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
35867 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
35872 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
35875 ELSEIF(ISUB.EQ.195) THEN
35876 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
35879 ALPRHT=2.16D0*(3D0/ITCM(1))
35880 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
35882 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
35883 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
35885 C...Propagator including a_T^+
35887 CALL PYWIDT(24,SH,WDTP,WDTE)
35888 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
35889 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
35890 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
35891 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
35892 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
35893 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
35894 & DCMPLX(FWX**2,0D0)*SSMR
35895 DWW=SSMR*SSMX/DETD/SH
35897 IF(KFA.LE.8) FCOF=3D0
35898 HP=FACTC*ABS(DWW)**2*FCOF
35900 DO 350 I=MMIN1,MMAX1
35901 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
35903 DO 340 J=MMIN2,MMAX2
35904 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
35906 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
35907 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35909 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35911 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
35916 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
35921 ELSEIF(ISUB.LE.380) THEN
35922 ALPRHT=2.16D0*(3D0/ITCM(1))
35923 IF(ISUB.EQ.361) THEN
35924 FAR=SQRT(AEM/ALPRHT)
35928 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
35929 FZX=-FAR/SN2W*RTCM(47)
35935 CALL PYWIDT(23,SH,WDTP,WDTE)
35936 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
35937 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35938 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
35939 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35940 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
35941 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
35942 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
35943 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
35944 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
35945 C...Add in techni-a contribution
35946 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
35947 DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
35948 $ SFZX*FAR*SSMO)/DETD/SH
35949 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
35950 DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
35951 $ SFZX*FAO*SSMR)/DETD/SH
35952 DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
35953 DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
35954 DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
35955 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
35956 $ SFZX*SSMR*SSMO)/DETD/SH
35957 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
35958 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
35960 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
35961 C...W+W-, W pi_tc, pi_T pi_T, etc.
35962 FACA=(SH**2*BE34**2-(TH-UH)**2)
35963 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
35964 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
35965 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
35966 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
35967 DO 370 I=MMINA,MMAXA
35968 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
35970 EI=KCHG(IABS(I),1)/3D0
35971 AI=SIGN(1D0,EI+0.1D0)
35973 VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
35974 VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
35975 C...........Eqs. (5) and (6) in LSTC-rates.pdf
35976 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
35977 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
35978 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
35979 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
35980 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
35981 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
35982 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
35983 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
35984 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
35985 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
35986 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
35987 C...........Eqs. (5) and (7) in LSTC-rates.pdf
35988 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
35989 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
35990 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
35991 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
35992 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
35993 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
35994 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
35996 C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
35998 c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
35999 c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36000 c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36001 c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36002 F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36003 F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36004 HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
36006 IF(IA.LE.10) HI=HI/3D0
36011 IF(KFA.EQ.KFB) THEN
36012 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
36013 ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
36014 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
36019 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
36021 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
36025 ELSEIF(ISUB.EQ.370) THEN
36026 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
36027 C...f + fbar' -> gamma pi_tc, etc.
36028 FACA=(SH**2*BE34**2-(TH-UH)**2)
36029 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36030 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36031 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36032 ALPRHT=2.16D0*(3D0/ITCM(1))
36033 FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
36034 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36035 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36037 CALL PYWIDT(24,SH,WDTP,WDTE)
36038 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36039 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36040 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36041 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36042 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36043 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36044 & DCMPLX(FWX**2,0D0)*SSMR
36045 DWW=SSMR*SSMX/DETD/SH
36046 DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
36047 DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
36048 HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
36049 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
36051 C...........Eq. (25) in PRD67-115011 with DWW term dropped.
36053 c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
36054 HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
36055 C...Add in W_L Z_T axial and vector contributions.
36056 IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
36057 $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
36058 $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
36059 $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
36060 DO 410 I=MMIN1,MMAX1
36061 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
36063 DO 400 J=MMIN2,MMAX2
36064 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
36066 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
36067 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36069 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36071 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36076 IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
36077 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
36079 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
36080 & WIDS(PYCOMP(KFB),2)
36086 ELSEIF(ISUB.LE.390) THEN
36087 IF(ISUB.EQ.381) THEN
36088 C...f + f' -> f + f' (g exchange)
36089 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
36090 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
36091 & MSTP(34)*2D0/3D0*UH2*REDQST)
36092 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
36093 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
36094 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
36095 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
36096 C...Modifications from contact interactions (compositeness)
36097 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
36098 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36099 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
36100 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36101 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
36102 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
36103 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
36104 ELSEIF(ITCM(5).EQ.5) THEN
36109 CSM.......Check this change from
36113 DO 430 I=MMIN1,MMAX1
36115 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36116 DO 420 J=MMIN2,MMAX2
36118 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
36123 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
36126 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
36129 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
36130 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
36137 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
36138 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
36139 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
36141 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
36142 SIGH(NCHN)=0.5D0*FACCI2*RATCII
36148 ELSEIF(ISUB.EQ.382) THEN
36149 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
36150 CALL PYWIDT(21,SH,WDTP,WDTE)
36151 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
36152 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36153 IF(ITCM(5).EQ.1) THEN
36154 C...Modifications from contact interactions (compositeness)
36157 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
36158 & WDTE(I,2)+WDTE(I,4))
36160 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
36161 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
36162 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36163 ELSEIF(ITCM(5).EQ.5) THEN
36164 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
36165 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
36166 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
36168 DO 450 I=MMINA,MMAXA
36169 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36170 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
36175 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
36177 ELSEIF(ITCM(5).EQ.5) THEN
36189 ELSEIF(ISUB.EQ.383) THEN
36190 C...f + fbar -> g + g (q + qbar -> g + g only)
36191 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
36192 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
36193 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
36194 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
36195 IF(ITCM(5).EQ.5) THEN
36196 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
36197 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
36198 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
36199 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
36201 DO 460 I=MMINA,MMAXA
36202 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36203 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
36208 SIGH(NCHN)=0.5D0*FACGG1
36209 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
36214 SIGH(NCHN)=0.5D0*FACGG2
36215 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
36218 ELSEIF(ISUB.EQ.384) THEN
36219 C...f + g -> f + g (q + g -> q + g only)
36220 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
36221 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
36222 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
36223 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
36224 DO 480 I=MMINA,MMAXA
36225 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
36227 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
36228 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
36231 ISIG(NCHN,3-ISDE)=21
36236 ISIG(NCHN,3-ISDE)=21
36242 ELSEIF(ISUB.EQ.385) THEN
36243 C...g + g -> f + fbar (g + g -> q + qbar only)
36244 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
36246 C...Begin by d, u, s flavours.
36248 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
36249 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
36250 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
36251 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
36252 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
36253 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
36254 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
36255 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
36256 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
36257 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
36268 C...Next c and b flavours: modified that and uhat for fixed
36269 C...cos(theta-hat).
36271 SQMAVG=PMAS(IFL,1)**2
36272 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
36273 BE34=SQRT(1D0-4D0*SQMAVG/SH)
36274 THQ=-0.5D0*SH*(1D0-BE34*CTH)
36275 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
36276 THUHQ=THQ*UHQ-SQMAVG*SH
36277 IF(MSTP(34).EQ.0) THEN
36278 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
36279 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
36281 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36282 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
36283 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36284 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
36286 IF(ITCM(5).GE.5) THEN
36288 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
36289 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36290 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
36291 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36293 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
36294 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36295 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
36296 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36299 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
36300 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
36304 ISIG(NCHN,3)=1+2*(IFL-3)
36309 ISIG(NCHN,3)=2+2*(IFL-3)
36315 ELSEIF(ISUB.EQ.386) THEN
36317 IF(ITCM(5).LE.4) THEN
36318 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
36319 & 2D0*TH/SH+TH2/SH2)*FACA
36320 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
36321 & 2D0*SH/UH+SH2/UH2)*FACA
36322 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
36323 & 2D0*UH/TH+UH2/TH2)
36325 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
36326 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
36327 & 4D0*REDGST*(SH + 2D0*TH)*
36328 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
36329 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
36330 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
36331 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
36332 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
36333 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
36334 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
36335 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
36336 & 4D0*REDGSU*(SH + 2D0*UH)*
36337 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
36338 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
36339 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
36340 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
36341 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
36342 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
36343 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
36344 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
36345 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
36346 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
36347 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
36348 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
36349 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
36350 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
36351 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
36352 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
36353 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
36354 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
36355 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
36356 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
36357 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
36358 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
36360 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
36365 SIGH(NCHN)=0.5D0*FACGG1
36370 SIGH(NCHN)=0.5D0*FACGG2
36375 SIGH(NCHN)=0.5D0*FACGG3
36378 ELSEIF(ISUB.EQ.387) THEN
36379 C...q + qbar -> Q + Qbar
36380 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
36381 THQ=-0.5D0*SH*(1D0-BE34*CTH)
36382 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
36383 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
36385 IF(ITCM(5).GE.5) THEN
36386 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
36387 FACQQB=FACQQB*SH2*SQDQTS
36389 FACQQB=FACQQB*SH2*SQDQQS
36392 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
36394 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
36395 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
36397 DO 520 I=MMINA,MMAXA
36398 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36399 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
36407 ELSEIF(ISUB.EQ.388) THEN
36408 C...g + g -> Q + Qbar
36409 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
36410 THQ=-0.5D0*SH*(1D0-BE34*CTH)
36411 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
36412 THUHQ=THQ*UHQ-SQMAVG*SH
36413 IF(MSTP(34).EQ.0) THEN
36414 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
36415 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
36417 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36418 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
36419 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36420 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
36422 IF(ITCM(5).GE.5) THEN
36423 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
36424 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
36425 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36426 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
36427 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36429 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
36430 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36431 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
36432 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36435 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
36436 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
36437 IF(MSTP(35).GE.1) THEN
36438 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
36439 FACQQ1=FACQQ1*FATRE
36440 FACQQ2=FACQQ2*FATRE
36443 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
36444 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
36447 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
36467 C*********************************************************************
36470 C...Subprocess cross sections for assorted exotic processes,
36471 C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
36472 C...Auxiliary to PYSIGH.
36474 SUBROUTINE PYSGEX(NCHN,SIGS)
36476 C...Double precision and integer declarations
36477 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36478 IMPLICIT INTEGER(I-N)
36479 INTEGER PYK,PYCHGE,PYCOMP
36480 C...Parameter statement to help give large particle numbers.
36481 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36482 &KEXCIT=4000000,KDIMEN=5000000)
36484 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36485 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36486 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36487 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36488 COMMON/PYINT1/MINT(400),VINT(400)
36489 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36490 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36491 COMMON/PYINT4/MWID(500),WIDS(500,5)
36492 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36493 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36494 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36495 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36496 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36497 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36498 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36500 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36502 C...Differential cross section expressions.
36504 IF(ISUB.LE.160) THEN
36505 IF(ISUB.EQ.141) THEN
36506 C...f + fbar -> gamma*/Z0/Z'0
36507 SQMZP=PMAS(32,1)**2
36509 CALL PYWIDT(32,SH,WDTP,WDTE)
36515 FACZP=4D0*COMFAC*3D0
36516 DO 100 I=MMINA,MMAXA
36517 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
36518 EI=KCHG(IABS(I),1)/3D0
36524 VPI=PARU(123-2*MOD(IABS(I),2))
36525 API=PARU(124-2*MOD(IABS(I),2))
36526 ELSEIF(IA.LE.4) THEN
36527 VPI=PARJ(182-2*MOD(IABS(I),2))
36528 API=PARJ(183-2*MOD(IABS(I),2))
36530 VPI=PARJ(190-2*MOD(IABS(I),2))
36531 API=PARJ(191-2*MOD(IABS(I),2))
36535 VPI=PARU(127-2*MOD(IABS(I),2))
36536 API=PARU(128-2*MOD(IABS(I),2))
36537 ELSEIF(IA.LE.14) THEN
36538 VPI=PARJ(186-2*MOD(IABS(I),2))
36539 API=PARJ(187-2*MOD(IABS(I),2))
36541 VPI=PARJ(194-2*MOD(IABS(I),2))
36542 API=PARJ(195-2*MOD(IABS(I),2))
36546 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
36548 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
36550 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
36555 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
36556 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
36557 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
36558 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
36559 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
36560 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
36561 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
36562 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
36565 ELSEIF(ISUB.EQ.142) THEN
36566 C...f + fbar' -> W'+/-
36567 SQMWP=PMAS(34,1)**2
36568 CALL PYWIDT(34,SH,WDTP,WDTE)
36570 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
36571 HP=AEM/(24D0*XW)*SH
36572 DO 120 I=MMIN1,MMAX1
36573 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
36575 DO 110 J=MMIN2,MMAX2
36576 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
36578 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
36579 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36581 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36582 HI=HP*(PARU(133)**2+PARU(134)**2)
36583 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
36584 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36589 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
36590 SIGH(NCHN)=HI*FACBW*HF
36594 ELSEIF(ISUB.EQ.144) THEN
36597 CALL PYWIDT(41,SH,WDTP,WDTE)
36599 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
36600 HP=AEM/(12D0*XW)*SH
36601 DO 140 I=MMIN1,MMAX1
36602 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
36604 DO 130 J=MMIN2,MMAX2
36605 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
36607 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
36609 IF(IA.LE.10) HI=HI*FACA/3D0
36610 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
36615 SIGH(NCHN)=HI*FACBW*HF
36619 ELSEIF(ISUB.EQ.145) THEN
36620 C...q + l -> LQ (leptoquark)
36621 SQMLQ=PMAS(42,1)**2
36622 CALL PYWIDT(42,SH,WDTP,WDTE)
36624 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
36625 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
36627 KFLQQ=KFDP(MDCY(42,2),1)
36628 KFLQL=KFDP(MDCY(42,2),2)
36629 DO 160 I=MMIN1,MMAX1
36630 IF(KFAC(1,I).EQ.0) GOTO 160
36632 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
36633 DO 150 J=MMIN2,MMAX2
36634 IF(KFAC(2,J).EQ.0) GOTO 150
36636 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
36637 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
36638 IF(JA.EQ.IA) GOTO 150
36639 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
36640 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
36642 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
36647 SIGH(NCHN)=HI*FACBW*HF
36651 ELSEIF(ISUB.EQ.146) THEN
36652 C...e + gamma* -> e* (excited lepton)
36653 KFQSTR=KFPR(ISUB,1)
36654 KCQSTR=PYCOMP(KFQSTR)
36655 KFQEXC=MOD(KFQSTR,KEXCIT)
36656 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
36658 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
36659 QF=-RTCM(43)/2D0-RTCM(44)/2D0
36660 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
36661 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
36664 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
36666 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
36667 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
36669 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36670 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
36673 ISIG(NCHN,3-ISDE)=22
36675 SIGH(NCHN)=HI*FACBW*HF
36679 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
36680 C...d + g -> d* and u + g -> u* (excited quarks)
36681 KFQSTR=KFPR(ISUB,1)
36682 KCQSTR=PYCOMP(KFQSTR)
36683 KFQEXC=MOD(KFQSTR,KEXCIT)
36684 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
36686 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
36687 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
36688 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
36691 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
36693 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
36694 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
36696 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36697 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
36700 ISIG(NCHN,3-ISDE)=21
36702 SIGH(NCHN)=HI*FACBW*HF
36707 ELSEIF(ISUB.LE.190) THEN
36708 IF(ISUB.EQ.162) THEN
36709 C...q + g -> LQ + lbar; LQ=leptoquark
36710 SQMLQ=PMAS(42,1)**2
36711 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
36712 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
36713 KFLQQ=KFDP(MDCY(42,2),1)
36714 DO 220 I=MMINA,MMAXA
36715 IF(IABS(I).NE.KFLQQ) GOTO 220
36718 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
36719 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
36722 ISIG(NCHN,3-ISDE)=21
36724 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
36728 ELSEIF(ISUB.EQ.163) THEN
36729 C...g + g -> LQ + LQbar; LQ=leptoquark
36730 SQMLQ=PMAS(42,1)**2
36731 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
36732 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
36733 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
36734 & ((TH-SQMLQ)*(UH-SQMLQ)))
36735 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
36739 C...Since don't know proper colour flow, randomize between alternatives
36740 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
36744 ELSEIF(ISUB.EQ.164) THEN
36745 C...q + qbar -> LQ + LQbar; LQ=leptoquark
36746 DELTA=0.25D0*(SQM3-SQM4)**2/SH
36747 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
36750 C SQMLQ=PMAS(42,1)**2
36751 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
36752 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
36753 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
36754 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
36755 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
36756 KFLQQ=KFDP(MDCY(42,2),1)
36757 DO 240 I=MMINA,MMAXA
36758 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36759 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
36765 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
36768 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
36769 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
36770 KFQSTR=KFPR(ISUB,2)
36771 KCQSTR=PYCOMP(KFQSTR)
36772 KFQEXC=MOD(KFQSTR,KEXCIT)
36773 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
36774 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
36775 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
36776 C...Propagators: as simulated in PYOFSH and as desired
36777 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
36778 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
36779 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
36780 GMMQC=SQRT(SQM4)*WDTP(0)
36781 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
36782 FACQSA=FACQSA*HBW4C/HBW4
36783 FACQSB=FACQSB*HBW4C/HBW4
36784 C...Branching ratios.
36785 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
36786 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
36787 DO 260 I=MMIN1,MMAX1
36789 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
36790 DO 250 J=MMIN2,MMAX2
36792 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
36793 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
36798 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
36799 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
36804 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
36805 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
36806 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
36811 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
36812 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
36813 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
36814 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
36819 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
36820 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
36825 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
36826 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
36827 ELSEIF(I.EQ.-J) THEN
36832 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36833 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36838 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36839 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36840 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
36845 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
36846 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
36847 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
36852 ELSEIF(ISUB.EQ.169) THEN
36853 C...q + qbar -> e + e* (excited lepton)
36854 KFQSTR=KFPR(ISUB,2)
36855 KCQSTR=PYCOMP(KFQSTR)
36856 KFQEXC=MOD(KFQSTR,KEXCIT)
36857 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
36858 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
36859 C...Propagators: as simulated in PYOFSH and as desired
36860 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
36861 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
36862 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
36863 GMMQC=SQRT(SQM4)*WDTP(0)
36864 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
36865 FACQSB=FACQSB*HBW4C/HBW4
36866 C...Branching ratios.
36867 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
36868 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
36869 DO 270 I=MMIN1,MMAX1
36871 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
36874 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
36879 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36880 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36885 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36886 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36890 ELSEIF(ISUB.LE.360) THEN
36891 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
36892 C...l + l -> H_L++/-- or H_R++/--.
36894 KFREC=PYCOMP(KFRES)
36895 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
36897 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
36898 DO 290 I=MMIN1,MMAX1
36900 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
36902 DO 280 J=MMIN2,MMAX2
36904 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
36906 IF(I*J.LT.0) GOTO 280
36907 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36912 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
36913 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
36914 SIGH(NCHN)=HI*FACBW*HF
36918 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
36919 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
36921 KFREC=PYCOMP(KFRES)
36922 C...Propagators: as simulated in PYOFSH and as desired
36923 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
36924 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
36925 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
36926 GMMC=SQRT(SQM3)*WDTP(0)
36927 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
36928 FHCC=COMFAC*AEM*HBW3C/HBW3
36929 DO 310 I=MMINA,MMAXA
36931 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
36933 J=ISIGN(KFPR(ISUB,2),-I)
36934 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
36935 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
36936 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
36938 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
36939 & (TH-SQM4)*SH)/(TH-SQM4)**2
36940 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
36942 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
36943 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
36944 & ((UH-SQM3)*(TH-SQM4))
36945 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
36946 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
36947 & ((UH-SQM3)*(SH-SQML))
36948 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
36949 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
36950 & ((SH-SQML)*(TH-SQM4))
36951 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
36952 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
36954 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
36955 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
36958 ISIG(NCHN,3-ISDE)=22
36960 SIGH(NCHN)=FHCC*SMM*WIDSC
36964 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
36965 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
36967 KFREC=PYCOMP(KFRES)
36968 SQMH=PMAS(KFREC,1)**2
36969 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
36970 C...Propagators: H++/-- as simulated in PYOFSH and as desired
36971 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
36972 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
36973 GMMH3=SQRT(SQM3)*WDTP(0)
36974 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
36975 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
36976 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
36977 GMMH4=SQRT(SQM4)*WDTP(0)
36978 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
36979 C...Kinematical and coupling functions
36980 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
36981 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
36982 C...Loop over allowed flavours
36983 DO 320 I=MMINA,MMAXA
36984 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
36985 EI=KCHG(IABS(I),1)/3D0
36986 AI=SIGN(1D0,EI+0.1D0)
36989 IF(IABS(I).LE.10) FCOI=FACA/3D0
36990 IF(ISUB.EQ.349) THEN
36991 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
36992 IF(IABS(I).LT.10) THEN
36993 DSIGHH=8D0*AEM**2*(EI**2/SH2+
36994 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
36995 & (VI**2+AI**2)*XWHH**2*HBWZ)
36997 IAOFF=181+3*((IABS(I)-11)/2)
36998 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37000 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37001 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37002 & (VI**2+AI**2)*XWHH**2*HBWZ)+
37003 & 8D0*AEM*(EI*HSUM/(SH*TH)+
37004 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
37008 IF(IABS(I).LT.10) THEN
37009 DSIGHH=8D0*AEM**2*EI**2/SH2
37011 IAOFF=181+3*((IABS(I)-11)/2)
37012 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37014 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
37022 SIGH(NCHN)=FACHH*FCOI*DSIGHH
37025 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
37026 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
37028 KFREC=PYCOMP(KFRES)
37029 SQMH=PMAS(KFREC,1)**2
37030 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
37031 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
37032 & PMAS(PYCOMP(9900024),1)**2
37033 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
37034 FACPRT=1D0/((VINT(204)**2-VINT(215))*
37035 & (VINT(209)**2-VINT(216)))
37036 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
37037 & (VINT(209)**2+2D0*VINT(218)))
37038 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37040 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
37041 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
37043 DO 340 I=MMIN1,MMAX1
37044 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
37045 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
37046 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
37047 DO 330 J=MMIN2,MMAX2
37048 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
37049 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
37050 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
37052 IF(IABS(KCHH).NE.2) GOTO 330
37053 FACLR=VINT(180+I)*VINT(180+J)
37054 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37055 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
37056 FACPRP=0.5D0*(FACPRT+FACPRU)**2
37064 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
37068 ELSEIF(ISUB.EQ.353) THEN
37069 C...f + fbar -> Z_R0
37070 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37071 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37073 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
37074 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37075 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
37076 DO 350 I=MMINA,MMAXA
37077 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
37078 IF(IABS(I).LE.8) THEN
37079 EI=KCHG(IABS(I),1)/3D0
37080 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
37081 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
37086 HI=HP*(VI**2+AI**2)
37087 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37092 SIGH(NCHN)=HI*FACBW*HF
37095 ELSEIF(ISUB.EQ.354) THEN
37096 C...f + fbar' -> W_R+/-
37097 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37098 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37100 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
37101 HP=AEM/(24D0*XW)*SH
37102 DO 370 I=MMIN1,MMAX1
37103 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
37105 DO 360 J=MMIN2,MMAX2
37106 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
37108 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
37109 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37111 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37113 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37118 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
37119 SIGH(NCHN)=HI*FACBW*HF
37124 ELSEIF(ISUB.LE.400) THEN
37125 IF(ISUB.EQ.391) THEN
37126 C...f + fbar -> G*.
37127 KFGSTR=KFPR(ISUB,1)
37128 KCGSTR=PYCOMP(KFGSTR)
37129 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
37131 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37132 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
37133 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
37134 C...Modify cross section in wings of peak.
37135 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
37136 DO 380 I=MMINA,MMAXA
37137 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
37139 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37147 ELSEIF(ISUB.EQ.392) THEN
37149 KFGSTR=KFPR(ISUB,1)
37150 KCGSTR=PYCOMP(KFGSTR)
37151 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
37153 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37154 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
37155 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
37156 C...Modify cross section in wings of peak.
37157 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
37158 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
37166 ELSEIF(ISUB.EQ.393) THEN
37167 C...q + qbar -> g + G*.
37168 KFGSTR=KFPR(ISUB,2)
37169 KCGSTR=PYCOMP(KFGSTR)
37170 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
37171 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
37172 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
37174 C...Propagators: as simulated in PYOFSH and as desired
37175 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
37176 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
37177 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
37178 HS=SQRT(SQM4)*WDTP(0)
37179 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37180 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
37181 FACG=FACG*HBW4C/HBW4
37182 DO 400 I=MMINA,MMAXA
37183 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37184 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
37192 ELSEIF(ISUB.EQ.394) THEN
37193 C...q + g -> q + G*.
37194 KFGSTR=KFPR(ISUB,2)
37195 KCGSTR=PYCOMP(KFGSTR)
37196 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
37197 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
37198 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
37199 & 2D0*TH2*TH/(UH*SH2))
37200 C...Propagators: as simulated in PYOFSH and as desired
37201 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
37202 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
37203 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
37204 HS=SQRT(SQM4)*WDTP(0)
37205 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37206 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
37207 FACG=FACG*HBW4C/HBW4
37208 DO 420 I=MMINA,MMAXA
37209 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
37211 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
37212 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
37215 ISIG(NCHN,3-ISDE)=21
37221 ELSEIF(ISUB.EQ.395) THEN
37222 C...g + g -> g + G*.
37223 KFGSTR=KFPR(ISUB,2)
37224 KCGSTR=PYCOMP(KFGSTR)
37225 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
37226 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
37227 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
37228 C...Propagators: as simulated in PYOFSH and as desired
37229 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
37230 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
37231 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
37232 HS=SQRT(SQM4)*WDTP(0)
37233 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37234 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
37235 FACG=FACG*HBW4C/HBW4
37236 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
37249 C*********************************************************************
37252 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
37253 C...parton distributions according to a few different parametrizations.
37254 C...Note that what is coded is x times the probability distribution,
37255 C...i.e. xq(x,Q2) etc.
37257 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
37259 C...Double precision and integer declarations.
37260 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37261 IMPLICIT INTEGER(I-N)
37262 INTEGER PYK,PYCHGE,PYCOMP
37264 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37265 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37266 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37267 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37268 COMMON/PYINT1/MINT(400),VINT(400)
37269 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
37271 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
37272 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
37273 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
37274 & XMI(2,240),PT2MI(240),IMISEP(0:240)
37275 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
37278 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
37279 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
37282 C...Interface to PDFLIB.
37283 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
37285 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
37286 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
37287 CHARACTER*20 PARM(20)
37288 DATA VALUE/20*0D0/,PARM/20*' '/
37290 C...Data related to Schuler-Sjostrand photon distributions.
37291 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
37293 C...Valence PDF momentum integral parametrizations PER PARTON!
37294 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
37295 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
37296 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
37297 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
37299 C...Reset parton distributions.
37308 C...Check x and particle species.
37309 IF(X.LE.0D0.OR.X.GE.1D0) THEN
37310 WRITE(MSTU(11),5000) X
37314 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
37315 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
37316 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
37317 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
37318 &KFA.NE.310.AND.KFA.NE.130) THEN
37319 WRITE(MSTU(11),5100) KF
37323 C...Electron (or muon or tau) parton distribution call.
37324 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
37325 CALL PYPDEL(KFA,X,Q2,XPEL)
37330 C...Photon parton distribution call (VDM+anomalous).
37331 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
37332 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
37333 CALL PYPDGA(X,Q2,XPGA)
37337 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
37340 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
37341 XPVAL(4)=MIN(XPQ(4),XPVU)
37342 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
37348 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
37351 IF(MSTP(55).GE.7) P2MX=4.0D0
37352 IF(MSTP(57).EQ.0) Q2MX=P2MX
37354 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37355 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37358 XPVAL(KFL)=VXPDGM(KFL)
37361 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
37364 IF(MSTP(55).GE.11) P2MX=4.0D0
37365 IF(MSTP(57).EQ.0) Q2MX=P2MX
37367 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37368 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37370 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
37371 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
37374 ELSEIF(MSTP(56).EQ.2) THEN
37375 C...Call PDFLIB parton distributions.
37379 VALUE(2)=MSTP(55)/1000
37381 VALUE(3)=MOD(MSTP(55),1000)
37382 IF(MINT(93).NE.3000000+MSTP(55)) THEN
37383 CALL PDFSET_ALICE(PARM,VALUE)
37384 MINT(93)=3000000+MSTP(55)
37387 QQ2=MAX(0D0,Q2MIN,Q2)
37388 IF(MSTP(57).EQ.0) QQ2=Q2MIN
37390 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37392 IF(MSTP(55).EQ.5004) THEN
37393 IF(5D0*P2.LT.QQ2.AND.
37394 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
37395 & P2.GE.0D0.AND.P2.LT.10D0.AND.
37396 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
37397 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
37412 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
37440 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
37443 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
37444 XPVAL(4)=MIN(XPQ(4),XPVU)
37445 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
37452 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
37455 C...Pion/gammaVDM parton distribution call.
37456 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
37457 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
37458 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
37459 & MSTP(55).LE.12) THEN
37460 ISET=1+MOD(MSTP(55)-1,4)
37463 IF(ISET.GE.3) P2MX=4.0D0
37464 IF(MSTP(57).EQ.0) Q2MX=P2MX
37466 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37467 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37469 XPQ(KFL)=XPVMD(KFL)
37470 XPVAL(KFL)=VXPVMD(KFL)
37473 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
37474 CALL PYPDPI(X,Q2,XPPI)
37478 XPVAL(2)=XPQ(2)-XPQ(-2)
37479 XPVAL(-1)=XPQ(-1)-XPQ(1)
37480 ELSEIF(MSTP(54).EQ.2) THEN
37481 C...Call PDFLIB parton distributions.
37485 VALUE(2)=MSTP(53)/1000
37487 VALUE(3)=MOD(MSTP(53),1000)
37488 IF(MINT(93).NE.2000000+MSTP(53)) THEN
37489 CALL PDFSET_ALICE(PARM,VALUE)
37490 MINT(93)=2000000+MSTP(53)
37493 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
37494 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
37495 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
37513 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
37516 C...Anomalous photon parton distribution call.
37517 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
37520 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
37521 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
37522 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
37523 IF(MSTP(57).EQ.0) Q2MX=P2MX
37525 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37526 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
37528 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
37529 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
37532 ELSEIF(MSTP(56).EQ.1) THEN
37533 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
37534 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
37535 IF(MSTP(57).EQ.0) Q2MX=P2MX
37537 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37538 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
37540 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
37541 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
37544 ELSEIF(MSTP(56).EQ.2) THEN
37545 IF(MSTP(57).EQ.0) Q2MX=P2MX
37546 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
37549 XPVAL(KFL)=VXPGA(KFL)
37552 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
37553 IF(MSTP(57).EQ.0) Q2MX=P2MX
37554 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
37557 XPVAL(KFL)=VXPGA(KFL)
37561 220 RKF=11D0*PYR(0)
37563 IF(RKF.GT.1D0) KFR=2
37564 IF(RKF.GT.5D0) KFR=3
37565 IF(RKF.GT.6D0) KFR=4
37566 IF(RKF.GT.10D0) KFR=5
37567 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
37568 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
37569 IF(MSTP(57).EQ.0) Q2MX=P2MX
37570 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
37573 XPVAL(KFL)=VXPGA(KFL)
37578 C...Proton parton distribution call.
37580 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
37581 CALL PYPDPR(X,Q2,XPPR)
37585 XPVAL(1)=XPQ(1)-XPQ(-1)
37586 XPVAL(2)=XPQ(2)-XPQ(-2)
37587 ELSEIF(MSTP(52).EQ.2) THEN
37588 C...Call PDFLIB parton distributions.
37592 VALUE(2)=MSTP(51)/1000
37594 VALUE(3)=MOD(MSTP(51),1000)
37595 IF(MINT(93).NE.1000000+MSTP(51)) THEN
37596 CALL PDFSET_ALICE(PARM,VALUE)
37597 MINT(93)=1000000+MSTP(51)
37600 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
37601 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
37603 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
37621 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
37625 C...Isospin average for pi0/gammaVDM.
37626 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
37627 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
37632 XPS=0.5D0*(XPQ(1)+XPQ(-2))
37633 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
37637 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
37638 & XPVAL(3)+XPVAL(4)+XPVAL(5)
37642 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
37643 XPQ(1)=XPQ(1)+0.2D0*XPV
37644 XPQ(2)=XPQ(2)+0.8D0*XPV
37645 XPVAL(1)=0.2D0*XPVL
37646 XPVAL(2)=0.8D0*XPVL
37647 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
37650 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
37653 IF(MSTP(55).GE.9) THEN
37659 XPQ(1)=XPQ(1)+0.5D0*XPV
37660 XPQ(2)=XPQ(2)+0.5D0*XPV
37661 XPVAL(1)=0.5D0*XPVL
37662 XPVAL(2)=0.5D0*XPVL
37666 XPVAL(-KFL)=XPVAL(KFL)
37669 C...Rescale for gammaVDM by effective gamma -> rho coupling.
37670 C+++Do not rescale?
37671 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
37672 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
37674 XPQ(KFL)=VINT(281)*XPQ(KFL)
37675 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
37677 VINT(232)=VINT(281)*XPV
37680 C...Simple recipes for kaons.
37681 ELSEIF(KFA.EQ.321) THEN
37682 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
37684 XPVAL(-3)=XPVAL(-1)
37686 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
37687 XPS=0.5D0*(XPQ(1)+XPQ(-2))
37688 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
37691 XPQ(1)=XPQ(1)+0.5D0*XPV
37692 XPQ(-1)=XPQ(-1)+0.5D0*XPV
37693 XPQ(3)=XPQ(3)+0.5D0*XPV
37694 XPQ(-3)=XPQ(-3)+0.5D0*XPV
37695 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
37699 XPVAL(-1)=0.5D0*XPV
37701 XPVAL(-3)=0.5D0*XPV
37703 C...Isospin conjugation for neutron.
37704 ELSEIF(KFA.EQ.2112) THEN
37715 C...Simple recipes for hyperon (average valence parton distribution).
37716 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
37717 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
37718 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
37719 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
37724 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
37725 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
37726 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
37727 XPV=(XPVAL(1)+XPVAL(2))/3D0
37730 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
37731 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
37732 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
37735 C...Charge conjugation for antiparticle.
37738 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
37745 XPVAL(KFL)=XPVAL(-KFL)
37750 C...MULTIPLE INTERACTIONS - PDF RESHAPING.
37753 C...Only reshape PDFs for the non-first interactions;
37754 C...But need valence/sea separation already from first interaction.
37755 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
37756 KFVSEL=KFIVAL(JS,1)
37757 C...If valence quark kicked out of pi0 or gamma then that decides
37758 C...whether we should consider state as d dbar, u ubar, s sbar, etc.
37759 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
37762 XPVL=XPVL+XPVAL(KFL)
37763 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
37766 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
37767 XPVAL(IABS(KFVSEL))=XPVL
37770 XPVAL(-KFL)=XPVAL(KFL)
37773 C...If valence quark kicked out of K0S or K0S then that decides whether
37774 C...we should consider state as d sbar or s dbar.
37775 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
37777 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
37778 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
37779 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
37780 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
37783 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
37784 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
37785 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
37789 C...XPQ distributions are nominal for a (signed) beam particle
37790 C...of KF type, with 1-Sum(x_prev) rescaled to 1.
37798 IF(IFL.EQ.0) GOTO 350
37800 C...Count up number of original IFL valence quarks.
37802 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
37803 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
37804 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
37805 C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
37806 C...bookkeep as if d dbar (for total momentum sum in valence sector).
37807 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
37808 C...Count down number of remaining IFL valence quarks. Skip current
37809 C...interaction initiator.
37811 DO 330 I1=1,NMI(JS)
37812 IF (I1.EQ.MINT(36)) GOTO 330
37813 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
37817 C...Separate out original VALENCE and SEA content.
37819 SEA=MAX(0D0,XPQ(IFL)-VAL)
37823 C...Rescale valence content if changed.
37824 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
37825 & (VAL*IVREM)/IVORG
37827 C...Momentum integrals of original and removed valence quarks.
37828 IF(IVORG.NE.0) THEN
37829 C...For p/n/pbar/nbar beams can split into d_val and u_val.
37830 C...Isospin conjugation for neutrons
37831 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
37833 IF (KFA.EQ.2112) IAFLP=3-IAFLP
37834 VPAVG=PAVG(IAFLP,Q2)
37835 C...For other baryons average d_val and u_val, like for PDFs.
37836 ELSEIF(KFA.GT.1000) THEN
37837 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
37838 C...For mesons and photon average d_val and u_val and scale by 3/2.
37839 C...Very crude, especially for photon.
37841 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
37843 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
37844 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
37847 C...Now add companions (at X with partner having been at Z=XASSOC).
37848 C...NOTE: due to the assumed simple x scaling, the partner was at what
37849 C...corresponds to a higher Z than XASSOC, if there were intermediate
37850 C...scatterings. Nothing done about that for the moment.
37851 DO 340 IVC=1,NVC(JS,IFL)
37852 C...Skip companions that have been kicked out
37853 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
37857 C...Momentum fraction of the partner quark.
37858 C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
37859 XS=XASSOC(JS,IFL,IVC)
37862 C...Momentum fraction of the companion quark.
37863 C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
37865 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
37866 C...Add to momentum sum, with rescaling compensation factor.
37867 XCFAC=(XREM+XS)/XREM*CMPFAC
37868 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
37873 C...Wait until all flavours treated, then rescale seas and gluon.
37876 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
37877 IF (RSFAC.LE.0D0) THEN
37878 C...First calculate factor needed to exactly restore pz cons.
37879 IF (NRESC.EQ.1) CMPFAC =
37880 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
37881 C...Add a bit of headroom
37883 C...Try a few times if more headroom is needed, then print error message.
37884 IF (NRESC.LE.10) GOTO 345
37886 & '(PYPDFU:) Negative reshaping factor persists!')
37887 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
37891 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
37892 C...Also store resulting distributions in XPQ
37894 DO 360 ISVC=-1,NVC(JS,IFL)
37895 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
37898 C...Save companion reweighting factor for PYPTIS.
37903 C...Allow gluon also in position 21.
37906 C...Check positivity and reset above maximum allowed flavour.
37908 XPQ(KFL)=MAX(0D0,XPQ(KFL))
37909 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
37912 C...Formats for error printouts.
37913 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
37914 5100 FORMAT(' Error: illegal particle code for parton distribution;',
37916 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
37918 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
37919 & ' Removed valence momentum fraction : ',F6.3/
37920 & ' Added companion momentum fraction : ',F6.3/
37921 & ' Resulting rescale factor : ',F6.3)
37923 C...Reset side pointer and return
37929 C*********************************************************************
37932 C...Gives proton parton distribution at small x and/or Q^2 according to
37933 C...correct limiting behaviour.
37935 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
37937 C...Double precision and integer declarations.
37938 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37939 IMPLICIT INTEGER(I-N)
37940 INTEGER PYK,PYCHGE,PYCOMP
37942 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37943 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37944 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37945 COMMON/PYINT1/MINT(400),VINT(400)
37946 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
37948 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
37949 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
37951 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
37955 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
37956 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
37957 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
37959 CALL PYPDFU(KF,X,Q2,XPQ)
37963 C...Reset. Check x.
37967 IF(X.LE.0D0.OR.X.GE.1D0) THEN
37968 WRITE(MSTU(11),5000) X
37972 C...Define valence content.
37976 IF(KF.EQ.2212) THEN
37979 ELSEIF(KF.EQ.-2212) THEN
37982 ELSEIF(KF.EQ.2112) THEN
37985 ELSEIF(KF.EQ.-2112) THEN
37988 ELSEIF(KF.EQ.211) THEN
37992 ELSEIF(KF.EQ.-211) THEN
37996 ELSEIF(MINT(105).LE.223) THEN
38001 ELSEIF(MINT(105).EQ.333) THEN
38006 ELSEIF(MINT(105).EQ.443) THEN
38013 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
38015 CALL PYPDFU(KFC,X,Q2,XPA)
38016 Q2MN=MAX(3D0,VINT(231))
38017 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
38018 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
38020 C...Large Q2 and large x: naive call is enough.
38021 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
38027 C...Small Q2 and large x: dampen boundary value.
38028 ELSEIF(X.GT.XMN) THEN
38030 C...Evaluate at boundary and define dampening factors.
38032 CALL PYPDFU(KFC,X,Q2MN,XPA)
38033 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
38034 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
38036 C...Separate valence and sea parts of parton distribution.
38038 XFV1=XPA(KFV1)-XPA(-KFV1)
38039 XPA(KFV1)=XPA(-KFV1)
38040 XFV2=XPA(KFV2)-XPA(-KFV2)
38041 XPA(KFV2)=XPA(-KFV2)
38043 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38044 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38045 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38046 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38049 C...Dampen valence and sea separately. Put back together.
38051 XPQ(KFL)=FS*XPA(KFL)
38054 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
38055 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
38057 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
38058 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
38059 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
38060 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
38064 C...Large Q2 and small x: interpolate behaviour.
38065 ELSEIF(Q2.GT.Q2MN) THEN
38067 C...Evaluate at extremes and define coefficients for interpolation.
38069 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38072 CALL PYPDFU(KFC,X,Q2B,XPB)
38074 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
38075 FVA=(X/XMN)**0.45D0*FLA
38076 FSA=(X/XMN)**(-0.08D0)*FLA
38079 C...Separate valence and sea parts of parton distribution.
38081 XFVA1=XPA(KFV1)-XPA(-KFV1)
38082 XPA(KFV1)=XPA(-KFV1)
38083 XFVA2=XPA(KFV2)-XPA(-KFV2)
38084 XPA(KFV2)=XPA(-KFV2)
38085 XFVB1=XPB(KFV1)-XPB(-KFV1)
38086 XPB(KFV1)=XPB(-KFV1)
38087 XFVB2=XPB(KFV2)-XPB(-KFV2)
38088 XPB(KFV2)=XPB(-KFV2)
38090 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
38091 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
38092 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
38093 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
38094 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
38095 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
38096 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
38097 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
38100 C...Interpolate for valence and sea. Put back together.
38102 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
38105 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
38106 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
38108 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
38109 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
38110 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
38111 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
38115 C...Small Q2 and small x: dampen boundary value and add term.
38118 C...Evaluate at boundary and define dampening factors.
38120 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38121 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
38123 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
38124 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
38125 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
38126 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
38127 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
38128 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
38130 C...Separate valence and sea parts of parton distribution.
38132 XFV1=XPA(KFV1)-XPA(-KFV1)
38133 XPA(KFV1)=XPA(-KFV1)
38134 XFV2=XPA(KFV2)-XPA(-KFV2)
38135 XPA(KFV2)=XPA(-KFV2)
38137 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38138 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38139 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38140 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38143 C...Dampen valence and sea separately. Add constant terms.
38144 C...Put back together.
38146 XPQ(KFL)=FSA*XPA(KFL)
38150 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
38152 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
38153 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
38156 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
38158 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
38159 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
38160 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
38161 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
38167 C...Format for error printout.
38168 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
38173 C*********************************************************************
38176 C...Gives electron (or muon, or tau) parton distribution.
38178 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
38180 C...Double precision and integer declarations.
38181 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38182 IMPLICIT INTEGER(I-N)
38183 INTEGER PYK,PYCHGE,PYCOMP
38185 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38186 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38187 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38188 COMMON/PYINT1/MINT(400),VINT(400)
38189 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
38191 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
38193 C...Interface to PDFLIB.
38194 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
38196 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38197 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38198 CHARACTER*20 PARM(20)
38199 DATA VALUE/20*0D0/,PARM/20*' '/
38201 C...Some common constants.
38207 IF(KFA.EQ.13) PME=PMAS(13,1)
38208 IF(KFA.EQ.15) PME=PMAS(15,1)
38209 XL=LOG(MAX(1D-10,X))
38210 X1L=LOG(MAX(1D-10,1D0-X))
38211 HLE=LOG(MAX(3D0,Q2/PME**2))
38212 HBE2=(AEM/PARU(1))*(HLE-1D0)
38214 C...Electron inside electron, see R. Kleiss et al., in Z physics at
38215 C...LEP 1, CERN 89-08, p. 34
38216 IF(MSTP(59).LE.1) THEN
38217 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
38218 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
38219 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
38220 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
38221 & 4D0*XL/(1D0-X)-5D0-X)
38223 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
38224 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
38225 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
38227 C...Zero distribution for very large x and rescale it for intermediate.
38228 IF(X.GT.1D0-1D-10) THEN
38230 ELSEIF(X.GT.1D0-1D-7) THEN
38231 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
38235 C...Photon and (transverse) W- inside electron.
38236 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
38237 IF(MSTP(13).LE.1) THEN
38240 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
38242 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
38243 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
38244 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
38246 C...Electron or positron inside photon inside electron.
38247 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
38248 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
38249 & 2D0*X*(1D0+X)*XL)
38250 XPEL(11)=XPEL(11)+XFSEA
38253 C...Initialize PDFLIB photon parton distributions.
38254 IF(MSTP(56).EQ.2) THEN
38258 VALUE(2)=MSTP(55)/1000
38260 VALUE(3)=MOD(MSTP(55),1000)
38261 IF(MINT(93).NE.3000000+MSTP(55)) THEN
38262 CALL PDFSET_ALICE(PARM,VALUE)
38263 MINT(93)=3000000+MSTP(55)
38267 C...Quarks and gluons inside photon inside electron:
38268 C...numerical convolution required.
38277 IF(ITER.EQ.0) NSTP=2
38279 SXP(KFL)=0.5D0*SXP(KFL)
38282 IF(ITER.EQ.0) WTSTP=0.5D0
38283 C...Pick grid of x_{gamma} values logarithmically even.
38288 XLE=XL*(ISTP-0.5D0)/NSTP
38290 XE=MIN(1D0-1D-10,EXP(XLE))
38291 XG=MIN(1D0-1D-10,X/XE)
38292 C...Evaluate photon inside electron parton distribution for convolution.
38293 XPGP=1D0+(1D0-XE)**2
38294 IF(MSTP(13).LE.1) THEN
38297 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
38299 C...Evaluate photon parton distributions for convolution.
38300 IF(MSTP(56).EQ.1) THEN
38301 IF(MSTP(55).EQ.1) THEN
38302 CALL PYPDGA(XG,Q2,XPGA)
38303 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
38306 IF(MSTP(55).GE.7) P2MX=4.0D0
38307 IF(MSTP(57).EQ.0) Q2MX=P2MX
38309 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38310 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38312 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
38315 IF(MSTP(55).GE.11) P2MX=4.0D0
38316 IF(MSTP(57).EQ.0) Q2MX=P2MX
38318 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38319 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38323 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
38325 ELSEIF(MSTP(56).EQ.2) THEN
38326 C...Call PDFLIB parton distributions.
38328 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38329 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38330 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38331 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
38332 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
38333 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
38334 SXP(3)=SXP(3)+WTSTP*XPGP*STR
38335 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
38336 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
38337 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
38340 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
38341 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
38342 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
38344 C...Put convolution into output arrays.
38346 XPEL(0)=FCONV*SXP(0)
38348 XPEL(KFL)=FCONV*SXP(KFL)
38349 XPEL(-KFL)=XPEL(KFL)
38356 C*********************************************************************
38359 C...Gives photon parton distribution.
38361 SUBROUTINE PYPDGA(X,Q2,XPGA)
38363 C...Double precision and integer declarations.
38364 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38365 IMPLICIT INTEGER(I-N)
38366 INTEGER PYK,PYCHGE,PYCOMP
38368 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38369 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38370 COMMON/PYINT1/MINT(400),VINT(400)
38371 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
38373 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
38374 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
38375 &DGCS(4,3),DGDS(4,3),DGES(4,3)
38377 C...The following data lines are coefficients needed in the
38378 C...Drees and Grassie photon parton distribution parametrization.
38379 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
38380 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
38381 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
38382 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
38383 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
38384 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
38385 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
38386 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
38387 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
38388 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
38389 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
38390 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
38391 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
38392 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
38393 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
38394 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
38395 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
38396 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
38397 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
38398 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
38399 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
38400 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
38401 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
38402 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
38403 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
38404 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
38406 C...Photon parton distribution from Drees and Grassie.
38407 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
38412 IF(MSTP(57).LE.0) THEN
38415 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
38419 IF(Q2.GT.25D0) NF=4
38420 IF(Q2.GT.300D0) NF=5
38424 C...Evaluate gluon content.
38425 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
38426 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
38427 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
38428 XPGL=DGA*X**DGB*X1**DGC
38430 C...Evaluate up- and down-type quark content.
38431 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
38432 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
38433 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
38434 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
38435 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
38436 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
38437 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
38438 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
38439 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
38440 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
38441 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
38443 IF(NF.EQ.4) DGF=10D0
38444 IF(NF.EQ.5) DGF=55D0/6D0
38445 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
38447 XPQU=(XPQS+9D0*XPQN)/6D0
38448 XPQD=(XPQS-4.5D0*XPQN)/6D0
38449 ELSEIF(NF.EQ.4) THEN
38450 XPQU=(XPQS+6D0*XPQN)/8D0
38451 XPQD=(XPQS-6D0*XPQN)/8D0
38453 XPQU=(XPQS+7.5D0*XPQN)/10D0
38454 XPQD=(XPQS-5D0*XPQN)/10D0
38457 C...Put into output arrays.
38462 IF(NF.GE.4) XPGA(4)=AEM*XPQU
38463 IF(NF.GE.5) XPGA(5)=AEM*XPQD
38465 XPGA(-KFL)=XPGA(KFL)
38471 C*********************************************************************
38474 C...Constructs the F2 and parton distributions of the photon
38475 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
38476 C...For F2, c and b are included by the Bethe-Heitler formula;
38477 C...in the 'MSbar' scheme additionally a Cgamma term is added.
38478 C...Contains the SaS sets 1D, 1M, 2D and 2M.
38479 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38481 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
38483 C...Double precision and integer declarations.
38484 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38485 IMPLICIT INTEGER(I-N)
38486 INTEGER PYK,PYCHGE,PYCOMP
38488 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38490 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38491 SAVE /PYINT8/,/PYINT9/
38493 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
38494 C...Charm and bottom masses (low to compensate for J/psi etc.).
38495 DATA PMC/1.3D0/, PMB/4.6D0/
38496 C...alpha_em and alpha_em/(2*pi).
38497 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
38498 C...Lambda value for 4 flavours.
38500 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
38502 C...VMD couplings f_V**2/(4*pi).
38503 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
38504 C...Masses for rho (=omega) and phi.
38505 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
38506 C...Number of points in integration for IP2=1.
38524 C...Set Q0 cut-off parameter as function of set used.
38532 C...Scale choice for off-shell photon; common factors.
38537 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
38538 FACNOR=LOG(Q2/Q02)/NSTEP
38539 ELSEIF(IP2.EQ.2) THEN
38541 ELSEIF(IP2.EQ.3) THEN
38543 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
38544 ELSEIF(IP2.EQ.4) THEN
38545 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38546 & ((Q2+P2)*(Q02+P2)))
38547 ELSEIF(IP2.EQ.5) THEN
38548 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38549 & ((Q2+P2)*(Q02+P2)))
38550 P2MX=Q0*SQRT(P2MXA)
38551 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
38552 ELSEIF(IP2.EQ.6) THEN
38553 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38554 & ((Q2+P2)*(Q02+P2)))
38555 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
38557 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38558 & ((Q2+P2)*(Q02+P2)))
38559 P2MX=Q0*SQRT(P2MXA)
38561 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
38562 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
38563 IF(ABS(Q2-Q02).GT.1D-6) THEN
38564 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
38565 ELSEIF(P2.LT.Q02) THEN
38566 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
38572 C...Call VMD parametrization for d quark and use to give rho, omega,
38573 C...phi. Note dipole dampening for off-shell photon.
38574 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38578 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
38579 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
38581 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
38583 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
38584 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
38585 XPVMD(3)=XPVMD(3)+FACS*XFVAL
38586 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
38587 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
38588 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
38589 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
38590 VXPVMD(2)=FRACU*FACUD*XFVAL
38591 VXPVMD(3)=FACS*XFVAL
38592 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
38593 VXPVMD(-2)=FRACU*FACUD*XFVAL
38594 VXPVMD(-3)=FACS*XFVAL
38597 C...Anomalous parametrizations for different strategies
38598 C...for off-shell photons; except full integration.
38600 C...Call anomalous parametrization for d + u + s.
38601 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38603 XPANL(KFL)=FACNOR*XPGA(KFL)
38604 VXPANL(KFL)=FACNOR*VXPGA(KFL)
38607 C...Call anomalous parametrization for c and b.
38608 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38610 XPANH(KFL)=FACNOR*XPGA(KFL)
38611 VXPANH(KFL)=FACNOR*VXPGA(KFL)
38613 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38615 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
38616 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
38620 C...Special option: loop over flavours and integrate over k2.
38622 DO 160 ISTEP=1,NSTEP
38623 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
38624 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
38625 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
38626 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
38627 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
38628 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
38629 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
38631 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
38632 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
38633 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
38634 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
38640 C...Call Bethe-Heitler term expression for charm and bottom.
38641 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
38644 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
38648 C...For MSbar subtraction call C^gamma term expression for d, u, s.
38649 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
38650 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
38652 XPDIR(KFL)=XPGA(KFL)
38656 C...Store result in output array.
38659 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
38660 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38661 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
38662 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
38663 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
38669 C*********************************************************************
38672 C...Evaluates the VMD parton distributions of a photon,
38673 C...evolved homogeneously from an initial scale P2 to Q2.
38674 C...Does not include dipole suppression factor.
38675 C...ISET is parton distribution set, see above;
38676 C...additionally ISET=0 is used for the evolution of an anomalous photon
38677 C...which branched at a scale P2 and then evolved homogeneously to Q2.
38678 C...ALAM is the 4-flavour Lambda, which is automatically converted
38679 C...to 3- and 5-flavour equivalents as needed.
38680 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38682 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
38684 C...Double precision and integer declarations.
38685 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38686 IMPLICIT INTEGER(I-N)
38687 INTEGER PYK,PYCHGE,PYCOMP
38688 C...Local arrays and data.
38689 DIMENSION XPGA(-6:6), VXPGA(-6:6)
38690 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
38699 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
38700 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
38701 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
38702 P2EFF=MAX(P2,1.2D0*ALAM3**2)
38703 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
38704 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
38705 Q2EFF=MAX(Q2,P2EFF)
38707 C...Find number of flavours at lower and upper scale.
38709 IF(P2EFF.LT.PMC**2) NFP=3
38710 IF(P2EFF.GT.PMB**2) NFP=5
38712 IF(Q2EFF.LT.PMC**2) NFQ=3
38713 IF(Q2EFF.GT.PMB**2) NFQ=5
38715 C...Find s as sum of 3-, 4- and 5-flavour parts.
38719 IF(NFQ.EQ.3) Q2DIV=Q2EFF
38720 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
38722 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
38724 IF(NFP.EQ.3) P2DIV=PMC**2
38726 IF(NFQ.EQ.5) Q2DIV=PMB**2
38727 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
38731 IF(NFP.EQ.5) P2DIV=P2EFF
38732 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
38735 C...Calculate frequent combinations of x and s.
38742 C...Evaluate homogeneous anomalous parton distributions below or
38743 C...above threshold.
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 = X * 1.5D0 * (X**2+X1**2)
38751 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
38752 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
38753 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
38754 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
38755 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
38756 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
38757 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
38758 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
38759 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
38760 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
38761 & (2D0*X-1D0)*X*XL**2)
38764 C...Evaluate set 1D parton distributions below or above threshold.
38765 ELSEIF(ISET.EQ.1) THEN
38766 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38767 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38768 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
38769 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
38770 XSEA = 0.100D0 * X1**3.76D0
38772 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
38773 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
38774 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
38775 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
38776 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
38777 & X**0.40D0 * X1**(1.76D0+3D0*S)
38778 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
38779 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
38780 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
38781 XSEA0 = 0.100D0 * X1**3.76D0
38784 C...Evaluate set 1M parton distributions below or above threshold.
38785 ELSEIF(ISET.EQ.2) THEN
38786 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38787 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38788 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
38789 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
38792 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
38793 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
38794 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
38795 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
38796 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
38797 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
38798 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
38799 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
38804 C...Evaluate set 2D parton distributions below or above threshold.
38805 ELSEIF(ISET.EQ.3) THEN
38806 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38807 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38808 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
38809 XGLU = 1.925D0 * X1**2
38810 XSEA = 0.242D0 * X1**4
38812 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
38813 & X**(0.46D0+0.25D0*S) *
38814 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
38815 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
38816 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
38817 & EXP(-18.67D0*S) *
38818 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
38819 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
38820 & XL**(9.3D0*S/(1D0+1.7D0*S))
38821 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
38822 & (1D0-0.607D0*S+21.95D0*S2) *
38823 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
38824 XSEA0 = 0.242D0 * X1**4
38827 C...Evaluate set 2M parton distributions below or above threshold.
38828 ELSEIF(ISET.EQ.4) THEN
38829 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38830 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38831 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
38832 XGLU = 1.808D0 * X1**2
38833 XSEA = 0.209D0 * X1**4
38835 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
38836 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
38837 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
38838 & XL**(5.15D0*S/(1D0+2D0*S)) +
38839 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
38840 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
38841 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
38842 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
38843 & XL**(10.9D0*S/(1D0+2.5D0*S))
38844 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
38845 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
38846 & X1**(4D0+S) * XL**(0.45D0*S)
38847 XSEA0 = 0.209D0 * X1**4
38851 C...Threshold factors for c and b sea.
38852 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
38854 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
38855 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
38857 XCHM=XSEA*(1D0-(SCH/SLL)**2)
38859 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
38863 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
38864 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
38866 XBOT=XSEA*(1D0-(SBT/SLL)**2)
38868 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
38872 C...Fill parton distributions.
38879 XPGA(KFA)=XPGA(KFA)+XVAL
38881 XPGA(-KFL)=XPGA(KFL)
38889 C*********************************************************************
38892 C...Evaluates the parton distributions of the anomalous photon,
38893 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
38894 C...KF=0 gives the sum over (up to) 5 flavours,
38895 C...KF<0 limits to flavours up to abs(KF),
38896 C...KF>0 is for flavour KF only.
38897 C...ALAM is the 4-flavour Lambda, which is automatically converted
38898 C...to 3- and 5-flavour equivalents as needed.
38899 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38901 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
38903 C...Double precision and integer declarations.
38904 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38905 IMPLICIT INTEGER(I-N)
38906 INTEGER PYK,PYCHGE,PYCOMP
38907 C...Local arrays and data.
38908 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
38909 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
38916 IF(Q2.LE.P2) RETURN
38919 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
38920 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
38922 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
38923 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
38924 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
38925 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
38926 Q2EFF=MAX(Q2,P2EFF)
38929 C...Find number of flavours at lower and upper scale.
38931 IF(P2EFF.LT.PMC**2) NFP=3
38932 IF(P2EFF.GT.PMB**2) NFP=5
38934 IF(Q2EFF.LT.PMC**2) NFQ=3
38935 IF(Q2EFF.GT.PMB**2) NFQ=5
38937 C...Define range of flavour loop.
38941 ELSEIF(KF.LT.0) THEN
38949 C...Loop over flavours the photon can branch into.
38950 DO 110 KFL=KFLMN,KFLMX
38952 C...Light flavours: calculate t range and (approximate) s range.
38953 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
38954 TDIFF=LOG(Q2EFF/P2EFF)
38955 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38956 & LOG(P2EFF/ALAMSQ(NFQ)))
38957 IF(NFQ.GT.NFP) THEN
38959 IF(NFQ.EQ.4) Q2DIV=PMC**2
38960 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
38961 & LOG(P2EFF/ALAMSQ(NFQ)))
38962 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
38963 & LOG(P2EFF/ALAMSQ(NFQ-1)))
38964 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
38966 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
38968 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
38969 & LOG(P2EFF/ALAMSQ(4)))
38970 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
38971 & LOG(P2EFF/ALAMSQ(3)))
38972 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
38975 C...u and s quark do not need a separate treatment when d has been done.
38976 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
38978 C...Charm: as above, but only include range above c threshold.
38979 ELSEIF(KFL.EQ.4) THEN
38980 IF(Q2.LE.PMC**2) GOTO 110
38981 P2EFF=MAX(P2EFF,PMC**2)
38982 Q2EFF=MAX(Q2EFF,P2EFF)
38983 TDIFF=LOG(Q2EFF/P2EFF)
38984 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38985 & LOG(P2EFF/ALAMSQ(NFQ)))
38986 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
38988 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
38989 & LOG(P2EFF/ALAMSQ(NFQ)))
38990 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
38991 & LOG(P2EFF/ALAMSQ(NFQ-1)))
38992 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
38995 C...Bottom: as above, but only include range above b threshold.
38996 ELSEIF(KFL.EQ.5) THEN
38997 IF(Q2.LE.PMB**2) GOTO 110
38998 P2EFF=MAX(P2EFF,PMB**2)
38999 Q2EFF=MAX(Q2,P2EFF)
39000 TDIFF=LOG(Q2EFF/P2EFF)
39001 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39002 & LOG(P2EFF/ALAMSQ(NFQ)))
39005 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
39007 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
39008 FAC=AEM2PI*2D0*CHSQ*TDIFF
39010 C...Evaluate parton distributions (normalized to unit momentum sum).
39011 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
39012 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
39013 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
39014 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
39015 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
39016 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
39017 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
39018 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
39019 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
39020 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
39021 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
39022 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
39024 C...Threshold factors for c and b sea.
39025 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39027 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39028 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39029 XCHM=XSEA*(1D0-(SCH/SLL)**3)
39032 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39033 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39034 XBOT=XSEA*(1D0-(SBT/SLL)**3)
39038 C...Add contribution of each valence flavour.
39039 XPGA(0)=XPGA(0)+FAC*XGLU
39040 XPGA(1)=XPGA(1)+FAC*XSEA
39041 XPGA(2)=XPGA(2)+FAC*XSEA
39042 XPGA(3)=XPGA(3)+FAC*XSEA
39043 XPGA(4)=XPGA(4)+FAC*XCHM
39044 XPGA(5)=XPGA(5)+FAC*XBOT
39045 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
39046 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
39049 XPGA(-KFL)=XPGA(KFL)
39050 VXPGA(-KFL)=VXPGA(KFL)
39057 C*********************************************************************
39060 C...Evaluates the Bethe-Heitler cross section for heavy flavour
39062 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39064 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
39066 C...Double precision and integer declarations.
39067 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39068 IMPLICIT INTEGER(I-N)
39069 INTEGER PYK,PYCHGE,PYCOMP
39072 DATA AEM2PI/0.0011614D0/
39078 C...Check kinematics limits.
39079 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
39081 BETA2=1D0-4D0*PM2/W2
39082 IF(BETA2.LT.1D-10) RETURN
39086 C...Simple case: P2 = 0.
39087 IF(P2.LT.1D-4) THEN
39088 IF(BETA.LT.0.99D0) THEN
39089 XBL=LOG((1D0+BETA)/(1D0-BETA))
39091 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
39093 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
39094 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
39096 C...Complicated case: P2 > 0, based on approximation of
39097 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
39099 RPQ=1D0-4D0*X**2*P2/Q2
39100 IF(RPQ.GT.1D-10) THEN
39101 RPBE=SQRT(RPQ*BETA2)
39102 IF(RPBE.LT.0.99D0) THEN
39103 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
39104 XBI=2D0*RPBE/(1D0-RPBE**2)
39106 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
39107 XBL=LOG((1D0+RPBE)**2/RPBESN)
39108 XBI=2D0*RPBE/RPBESN
39110 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
39111 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
39112 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
39116 C...Multiply by charge-squared etc. to get parton distribution.
39118 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
39119 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
39124 C*********************************************************************
39127 C...Evaluates the direct contribution, i.e. the C^gamma term,
39128 C...as needed in MSbar parametrizations.
39129 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39131 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
39133 C...Double precision and integer declarations.
39134 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39135 IMPLICIT INTEGER(I-N)
39136 INTEGER PYK,PYCHGE,PYCOMP
39137 C...Local array and data.
39138 DIMENSION XPGA(-6:6)
39139 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
39146 C...Evaluate common x-dependent expression.
39147 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
39148 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
39150 C...d, u, s part by simple charge factor.
39151 XPGA(1)=(1D0/9D0)*CGAM
39152 XPGA(2)=(4D0/9D0)*CGAM
39153 XPGA(3)=(1D0/9D0)*CGAM
39155 C...Also fill for antiquarks.
39163 C*********************************************************************
39166 C...Gives pi+ parton distribution according to two different
39167 C...parametrizations.
39169 SUBROUTINE PYPDPI(X,Q2,XPPI)
39171 C...Double precision and integer declarations.
39172 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39173 IMPLICIT INTEGER(I-N)
39174 INTEGER PYK,PYCHGE,PYCOMP
39176 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39177 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39178 COMMON/PYINT1/MINT(400),VINT(400)
39179 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
39181 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
39183 C...The following data lines are coefficients needed in the
39184 C...Owens pion parton distribution parametrizations, see below.
39185 C...Expansion coefficients for up and down valence quark distributions.
39186 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
39187 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39188 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39189 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
39190 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
39191 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39192 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39193 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
39194 C...Expansion coefficients for gluon distribution.
39195 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
39196 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
39197 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
39198 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
39199 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
39200 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
39201 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
39202 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
39203 C...Expansion coefficients for (up+down+strange) quark sea distribution.
39204 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
39205 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
39206 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
39207 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
39208 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
39209 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
39210 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
39211 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
39212 C...Expansion coefficients for charm quark sea distribution.
39213 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
39214 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
39215 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
39216 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
39217 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
39218 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
39219 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
39220 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
39222 C...Euler's beta function, requires ordinary Gamma function
39223 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
39225 C...Reset output array.
39230 IF(MSTP(53).LE.2) THEN
39231 C...Pion parton distributions from Owens.
39232 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
39234 C...Determine set, Lambda and s expansion variable.
39236 IF(NSET.EQ.1) ALAM=0.2D0
39237 IF(NSET.EQ.2) ALAM=0.4D0
39239 IF(MSTP(57).LE.0) THEN
39242 Q2IN=MIN(2D3,MAX(4D0,Q2))
39243 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
39246 C...Calculate parton distributions.
39249 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
39250 & COW(3,IS,KFL,NSET)*SD**2
39253 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
39255 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
39260 C...Put into output array.
39263 XPPI(2)=XQ(1)+XQ(3)/6D0
39266 XPPI(-1)=XQ(1)+XQ(3)/6D0
39271 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
39272 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
39276 C...Determine s expansion variable and some x expressions.
39278 IF(MSTP(57).LE.0) THEN
39281 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
39282 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
39288 C...Evaluate valence, gluon and sea distributions.
39289 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
39290 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
39291 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
39293 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
39294 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
39296 & (1D0-X)**(0.390D0+1.053D0*SD)
39297 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
39299 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
39301 & XL**(2.538D0-0.763D0*SD)
39302 IF(SD.LE.0.888D0) THEN
39305 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
39307 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
39310 IF(SD.LE.1.351D0) THEN
39313 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
39314 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
39318 C...Put into output array.
39326 XPPI(-KFL)=XPPI(KFL)
39328 XPPI(2)=XPPI(2)+XFVAL
39329 XPPI(-1)=XPPI(-1)+XFVAL
39335 C*********************************************************************
39338 C...Gives proton parton distributions according to a few different
39339 C...parametrizations.
39341 SUBROUTINE PYPDPR(X,Q2,XPPR)
39343 C...Double precision and integer declarations.
39344 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39345 IMPLICIT INTEGER(I-N)
39346 INTEGER PYK,PYCHGE,PYCOMP
39348 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39349 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39350 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39351 COMMON/PYINT1/MINT(400),VINT(400)
39352 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39353 C...Arrays and data.
39354 DIMENSION XPPR(-6:6),Q2MIN(16)
39355 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
39356 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
39358 C...Reset output array.
39363 C...Common preliminaries.
39364 NSET=MAX(1,MIN(16,MSTP(51)))
39365 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
39366 VINT(231)=Q2MIN(NSET)
39367 IF(MSTP(57).EQ.0) THEN
39370 Q2L=MAX(Q2MIN(NSET),Q2)
39373 IF(NSET.GE.1.AND.NSET.LE.3) THEN
39374 C...Interface to the CTEQ 3 parton distributions.
39375 QRT=SQRT(MAX(1D0,Q2L))
39377 C...Loop over flavours.
39380 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
39381 ELSEIF(I.LE.2) THEN
39382 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
39388 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
39389 C...Interface to the GRV 94 distributions.
39391 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39392 ELSEIF(NSET.EQ.5) THEN
39393 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39395 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39398 C...Put into output array.
39400 XPPR(-1)=0.5D0*(UDB+DEL)
39401 XPPR(-2)=0.5D0*(UDB-DEL)
39405 XPPR(1)=DV+XPPR(-1)
39406 XPPR(2)=UV+XPPR(-2)
39411 ELSEIF(NSET.EQ.7) THEN
39412 C...Interface to the CTEQ 5L parton distributions.
39413 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
39414 C...freezing x*f(x,Q2) at borders.
39415 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
39416 XIN=MAX(1D-6,MIN(1D0,X))
39418 C...Loop over flavours (with u <-> d notation mismatch).
39419 SUMUDB=PYCT5L(-1,XIN,QRT)
39420 RATUDB=PYCT5L(-2,XIN,QRT)
39423 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
39424 ELSEIF(I.EQ.2) THEN
39425 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
39426 ELSEIF(I.EQ.-1) THEN
39427 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
39428 ELSEIF(I.EQ.-2) THEN
39429 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
39431 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
39432 IF(I.LT.0) XPPR(-I)=XPPR(I)
39436 ELSEIF(NSET.EQ.8) THEN
39437 C...Interface to the CTEQ 5M1 parton distributions.
39438 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
39439 XIN=MAX(1D-6,MIN(1D0,X))
39441 C...Loop over flavours (with u <-> d notation mismatch).
39442 SUMUDB=PYCT5M(-1,XIN,QRT)
39443 RATUDB=PYCT5M(-2,XIN,QRT)
39446 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
39447 ELSEIF(I.EQ.2) THEN
39448 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
39449 ELSEIF(I.EQ.-1) THEN
39450 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
39451 ELSEIF(I.EQ.-2) THEN
39452 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
39454 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
39455 IF(I.LT.0) XPPR(-I)=XPPR(I)
39459 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
39460 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
39461 C...obsolete but offers backwards compatibility.
39462 CALL PYPDPO(X,Q2L,XPPR)
39464 C...Symmetric choice for debugging only
39465 ELSEIF(NSET.EQ.16) THEN
39483 C*********************************************************************
39486 C...Gives the CTEQ 3 parton distribution function sets in
39487 C...parametrized form, of October 24, 1994.
39488 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
39489 C...J. Qiu, W.K. Tung and H. Weerts.
39491 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
39493 C...Double precision declaration.
39494 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39495 IMPLICIT INTEGER(I-N)
39497 C...Data on Lambda values of fits, minimum Q and quark masses.
39498 DIMENSION ALM(3), QMS(4:6)
39499 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
39500 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
39502 C....Check flavour thresholds. Set up QI for SB.
39505 IF(Q .LE. QMS(IP)) THEN
39514 C...Use "standard lambda" of parametrization program for expansion.
39516 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
39521 C...Expansion for CTEQ3L.
39522 IF(ISET .EQ. 1) THEN
39523 IF(IPRT .EQ. 2) THEN
39524 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
39526 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
39527 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
39528 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
39529 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
39530 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
39531 ELSEIF(IPRT .EQ. 1) THEN
39532 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
39534 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
39535 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
39536 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
39537 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
39538 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
39539 ELSEIF(IPRT .EQ. 0) THEN
39540 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
39542 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
39543 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
39544 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
39545 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
39546 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
39547 ELSEIF(IPRT .EQ. -1) THEN
39548 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
39550 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
39551 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
39552 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
39553 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
39554 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
39555 ELSEIF(IPRT .EQ. -2) THEN
39556 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
39558 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
39559 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
39560 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
39561 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
39562 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
39563 ELSEIF(IPRT .EQ. -3) THEN
39564 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
39566 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
39567 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
39568 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
39569 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
39570 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
39571 ELSEIF(IPRT .EQ. -4) THEN
39572 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
39574 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
39575 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
39576 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
39577 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
39578 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
39579 ELSEIF(IPRT .EQ. -5) THEN
39580 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
39582 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
39583 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
39584 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
39585 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
39586 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
39587 ELSEIF(IPRT .EQ. -6) THEN
39588 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
39590 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
39591 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
39592 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
39593 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
39594 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
39597 C...Expansion for CTEQ3M.
39598 ELSEIF(ISET .EQ. 2) THEN
39599 IF(IPRT .EQ. 2) THEN
39600 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
39602 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
39603 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
39604 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
39605 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
39606 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
39607 ELSEIF(IPRT .EQ. 1) THEN
39608 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
39610 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
39611 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
39612 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
39613 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
39614 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
39615 ELSEIF(IPRT .EQ. 0) THEN
39616 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
39618 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
39619 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
39620 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
39621 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
39622 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
39623 ELSEIF(IPRT .EQ. -1) THEN
39624 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
39626 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
39627 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
39628 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
39629 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
39630 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
39631 ELSEIF(IPRT .EQ. -2) THEN
39632 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
39634 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
39635 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
39636 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
39637 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
39638 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
39639 ELSEIF(IPRT .EQ. -3) THEN
39640 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
39642 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
39643 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
39644 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
39645 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
39646 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
39647 ELSEIF(IPRT .EQ. -4) THEN
39648 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
39650 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
39651 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
39652 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
39653 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
39654 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
39655 ELSEIF(IPRT .EQ. -5) THEN
39656 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
39658 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
39659 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
39660 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
39661 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
39662 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
39663 ELSEIF(IPRT .EQ. -6) THEN
39664 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
39666 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
39667 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
39668 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
39669 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
39670 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
39673 C...Expansion for CTEQ3D.
39674 ELSEIF(ISET .EQ. 3) THEN
39675 IF(IPRT .EQ. 2) THEN
39676 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
39678 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
39679 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
39680 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
39681 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
39682 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
39683 ELSEIF(IPRT .EQ. 1) THEN
39684 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
39686 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
39687 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
39688 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
39689 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
39690 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
39691 ELSEIF(IPRT .EQ. 0) THEN
39692 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
39694 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
39695 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
39696 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
39697 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
39698 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
39699 ELSEIF(IPRT .EQ. -1) THEN
39700 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
39702 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
39703 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
39704 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
39705 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
39706 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
39707 ELSEIF(IPRT .EQ. -2) THEN
39708 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
39710 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
39711 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
39712 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
39713 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
39714 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
39715 ELSEIF(IPRT .EQ. -3) THEN
39716 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
39718 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
39719 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
39720 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
39721 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
39722 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
39723 ELSEIF(IPRT .EQ. -4) THEN
39724 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
39726 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
39727 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
39728 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
39729 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
39730 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
39731 ELSEIF(IPRT .EQ. -5) THEN
39732 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
39734 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
39735 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
39736 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
39737 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
39738 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
39739 ELSEIF(IPRT .EQ. -6) THEN
39740 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
39742 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
39743 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
39744 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
39745 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
39746 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
39750 C...Calculation of x * f(x, Q).
39751 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
39752 & *(LOG(1D0+1D0/X))**A5 )
39757 C*********************************************************************
39760 C...Gives the GRV 94 L (leading order) parton distribution function set
39761 C...in parametrized form.
39762 C...Authors: M. Glueck, E. Reya and A. Vogt.
39764 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39766 C...Double precision declaration.
39767 IMPLICIT DOUBLE PRECISION (A - Z)
39769 C...Common expressions.
39771 LAM2 = 0.2322D0 * 0.2322D0
39772 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39778 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
39779 AKU = 0.590D0 - 0.024D0 * S
39780 BKU = 0.131D0 + 0.063D0 * S
39781 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
39782 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
39783 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
39784 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
39785 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
39788 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
39790 BKD = 0.486D0 + 0.062D0 * S
39791 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
39792 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
39793 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
39794 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
39795 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
39798 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
39799 AKE = 0.409D0 - 0.005D0 * S
39800 BKE = 0.799D0 + 0.071D0 * S
39801 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
39802 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
39804 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
39805 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
39810 AKX = 0.410D0 - 0.232D0 * S
39811 BKX = 0.534D0 - 0.457D0 * S
39812 AGX = 0.890D0 - 0.140D0 * S
39814 CX = 0.320D0 + 0.683D0 * S
39815 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
39816 EX = 4.119D0 + 1.713D0 * S
39817 ESX = 0.682D0 + 2.978D0 * S
39818 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
39825 AKS = 1.798D0 - 0.596D0 * S
39826 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
39827 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
39828 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
39829 EST = 3.981D0 + 1.638D0 * S
39831 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
39839 BC = 4.24D0 - 0.804D0 * S
39840 DCT = 3.46D0 - 1.076D0 * S
39841 ECT = 4.61D0 + 1.49D0 * S
39842 ESC = 2.555D0 + 1.961D0 * S
39843 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
39852 DBT = 2.929D0 + 1.396D0 * S
39853 EBT = 4.71D0 + 1.514D0 * S
39854 ESB = 4.02D0 + 1.239D0 * S
39855 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
39860 AKG = 1.742D0 - 0.930D0 * S
39861 BKG = - 0.399D0 * S2
39862 AG = 7.486D0 - 2.185D0 * S
39863 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
39864 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
39865 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
39866 EG = 0.807D0 + 2.005D0 * S
39867 ESG = 3.841D0 + 0.316D0 * S
39868 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
39874 C*********************************************************************
39877 C...Gives the GRV 94 M (MSbar) parton distribution function set
39878 C...in parametrized form.
39879 C...Authors: M. Glueck, E. Reya and A. Vogt.
39881 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39883 C...Double precision declaration.
39884 IMPLICIT DOUBLE PRECISION (A - Z)
39886 C...Common expressions.
39888 LAM2 = 0.248D0 * 0.248D0
39889 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39895 NU = 1.304D0 + 0.863D0 * S
39896 AKU = 0.558D0 - 0.020D0 * S
39898 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
39899 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
39900 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
39901 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
39902 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
39905 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
39906 AKD = 0.270D0 - 0.019D0 * S
39908 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
39909 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
39910 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
39911 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
39912 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
39915 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
39916 AKE = 0.409D0 - 0.007D0 * S
39917 BKE = 0.782D0 + 0.082D0 * S
39918 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
39919 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
39921 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
39922 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
39930 BGX = 3.210D0 - 1.866D0 * S
39932 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
39933 EX = 3.077D0 + 1.446D0 * S
39934 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
39935 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
39942 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
39943 AS = -4.329D0 + 1.131D0 * S
39944 BS = 9.568D0 - 1.744D0 * S
39945 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
39946 EST = 3.031D0 + 1.639D0 * S
39947 ESS = 5.837D0 + 0.815D0 * S
39948 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
39954 AKC = -0.625D0 - 0.523D0 * S
39956 BC = 1.896D0 + 1.616D0 * S
39957 DCT = 4.12D0 + 0.683D0 * S
39958 ECT = 4.36D0 + 1.328D0 * S
39959 ESC = 0.677D0 + 0.679D0 * S
39960 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
39966 AKB = - 0.193D0 * S
39969 DBT = 3.447D0 + 0.927D0 * S
39970 EBT = 4.68D0 + 1.259D0 * S
39971 ESB = 1.892D0 + 2.199D0 * S
39972 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
39977 AKG = 1.724D0 + 0.157D0 * S
39978 BKG = 0.800D0 + 1.016D0 * S
39979 AG = 7.517D0 - 2.547D0 * S
39980 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
39981 CG = 4.039D0 + 1.491D0 * S
39982 DG = 3.404D0 + 0.830D0 * S
39983 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
39984 ESG = 3.256D0 - 0.436D0 * S
39985 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
39990 C*********************************************************************
39993 C...Gives the GRV 94 D (DIS) parton distribution function set
39994 C...in parametrized form.
39995 C...Authors: M. Glueck, E. Reya and A. Vogt.
39997 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39999 C...Double precision declaration.
40000 IMPLICIT DOUBLE PRECISION (A - Z)
40002 C...Common expressions.
40004 LAM2 = 0.248D0 * 0.248D0
40005 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40011 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
40012 AKU = 0.563D0 - 0.025D0 * S
40013 BKU = 0.054D0 + 0.154D0 * S
40014 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
40015 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
40016 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
40017 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
40018 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40021 ND = 0.156D0 - 0.017D0 * S
40022 AKD = 0.299D0 - 0.022D0 * S
40023 BKD = 0.259D0 - 0.015D0 * S
40024 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
40025 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
40026 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
40027 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
40028 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40031 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
40032 AKE = 0.419D0 - 0.013D0 * S
40033 BKE = 1.064D0 - 0.038D0 * S
40034 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
40035 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
40036 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
40037 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
40038 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40043 AKX = 0.326D0 + 0.150D0 * S
40044 BKX = 0.956D0 + 0.405D0 * S
40046 BGX = 3.794D0 - 2.359D0 * DS
40048 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
40049 EX = 3.049D0 + 1.597D0 * S
40050 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
40051 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40058 AKS = 1.415D0 - 0.641D0 * DS
40059 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
40060 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
40061 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
40062 EST = 4.546D0 + 0.372D0 * S2
40063 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
40064 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40070 AKC = -0.625D0 - 0.523D0 * S
40072 BC = 1.896D0 + 1.616D0 * S
40073 DCT = 4.12D0 + 0.683D0 * S
40074 ECT = 4.36D0 + 1.328D0 * S
40075 ESC = 0.677D0 + 0.679D0 * S
40076 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40082 AKB = - 0.193D0 * S
40085 DBT = 3.447D0 + 0.927D0 * S
40086 EBT = 4.68D0 + 1.259D0 * S
40087 ESB = 1.892D0 + 2.199D0 * S
40088 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40094 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
40095 AG = 25.09D0 - 7.935D0 * S
40096 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
40097 CG = 590.3D0 - 173.8D0 * S
40098 DG = 5.196D0 + 1.857D0 * S
40099 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
40100 ESG = 3.232D0 - 0.542D0 * S
40101 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
40106 C*********************************************************************
40109 C...Auxiliary for the GRV 94 parton distribution functions
40110 C...for u and d valence and d-u sea.
40111 C...Authors: M. Glueck, E. Reya and A. Vogt.
40113 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
40115 C...Double precision declaration.
40116 IMPLICIT DOUBLE PRECISION (A - Z)
40120 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
40126 C*********************************************************************
40129 C...Auxiliary for the GRV 94 parton distribution functions
40130 C...for d+u sea and gluon.
40131 C...Authors: M. Glueck, E. Reya and A. Vogt.
40133 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
40135 C...Double precision declaration.
40136 IMPLICIT DOUBLE PRECISION (A - Z)
40140 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
40141 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
40146 C*********************************************************************
40149 C...Auxiliary for the GRV 94 parton distribution functions
40150 C...for s, c and b sea.
40151 C...Authors: M. Glueck, E. Reya and A. Vogt.
40153 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
40155 C...Double precision declaration.
40156 IMPLICIT DOUBLE PRECISION (A - Z)
40164 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
40165 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
40171 C*********************************************************************
40174 C...Auxiliary function for parametrization of CTEQ5L.
40175 C...Author: J. Pumplin 9/99.
40177 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
40178 C...in Parametrized Form
40179 C... September 15, 1999
40181 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
40182 C... CTEQ5 PPARTON DISTRIBUTIONS"
40185 C...The CTEQ5M1 set given here is an updated version of the original
40186 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
40187 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
40188 C...almost all applications.
40189 C...The improvement is in the QCD evolution which is now more
40190 C...accurate, and which agrees completely with the benchmark work
40191 C...of the HERA 96/97 Workshop.
40192 C...The differences between the parametrized and the corresponding
40193 C...table versions (on which it is based) are of similar order as
40194 C...between the two version.
40196 C...!! Because accurate parametrizations over a wide range of (x,Q)
40197 C...is hard to obtain, only the most widely used sets CTEQ5M and
40198 C...CTEQ5L are available in parametrized form for now.
40200 C...These parametrizations were obtained by Jon Pumplin.
40202 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
40203 C -------------------------------------------------------------------
40204 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
40205 C 3 CTEQ5L Leading Order 0.127 192 146
40206 C -------------------------------------------------------------------
40207 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
40208 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
40211 C...The two Iset value are adopted to agree with the standard table
40214 C...Range of validity:
40215 C...The range of (x, Q) covered by this parametrization of the QCD
40216 C...evolved parton distributions is 1E-6 < x < 1 ;
40217 C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
40218 C...data only in a subset of that region; and the assumed DGLAP
40219 C...evolution is unlikely to be valid for all of it either.
40221 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
40222 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
40223 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
40224 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
40226 FUNCTION PYCT5L(IFL,X,Q)
40228 C...Double precision declaration.
40229 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40230 IMPLICIT INTEGER(I-N)
40232 PARAMETER (NEX=8, NLF=2)
40233 DIMENSION AM(0:NEX,0:NLF,-5:2)
40234 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
40235 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
40236 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
40237 DIMENSION AF(0:NEX)
40239 DATA MEXVEC( 2) / 8 /
40240 DATA MLFVEC( 2) / 2 /
40241 DATA UT1VEC( 2) / 0.4971265E+01 /
40242 DATA UT2VEC( 2) / -0.1105128E+01 /
40243 DATA ALFVEC( 2) / 0.2987216E+00 /
40244 DATA QMAVEC( 2) / 0.0000000E+00 /
40245 DATA (AM( 0,K, 2),K=0, 2)
40246 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
40247 DATA (AM( 1,K, 2),K=0, 2)
40248 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
40249 DATA (AM( 2,K, 2),K=0, 2)
40250 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
40251 DATA (AM( 3,K, 2),K=0, 2)
40252 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
40253 DATA (AM( 4,K, 2),K=0, 2)
40254 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
40255 DATA (AM( 5,K, 2),K=0, 2)
40256 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
40257 DATA (AM( 6,K, 2),K=0, 2)
40258 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
40259 DATA (AM( 7,K, 2),K=0, 2)
40260 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
40261 DATA (AM( 8,K, 2),K=0, 2)
40262 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
40264 DATA MEXVEC( 1) / 8 /
40265 DATA MLFVEC( 1) / 2 /
40266 DATA UT1VEC( 1) / 0.2612618E+01 /
40267 DATA UT2VEC( 1) / -0.1258304E+06 /
40268 DATA ALFVEC( 1) / 0.3407552E+00 /
40269 DATA QMAVEC( 1) / 0.0000000E+00 /
40270 DATA (AM( 0,K, 1),K=0, 2)
40271 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
40272 DATA (AM( 1,K, 1),K=0, 2)
40273 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
40274 DATA (AM( 2,K, 1),K=0, 2)
40275 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
40276 DATA (AM( 3,K, 1),K=0, 2)
40277 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
40278 DATA (AM( 4,K, 1),K=0, 2)
40279 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
40280 DATA (AM( 5,K, 1),K=0, 2)
40281 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
40282 DATA (AM( 6,K, 1),K=0, 2)
40283 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
40284 DATA (AM( 7,K, 1),K=0, 2)
40285 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
40286 DATA (AM( 8,K, 1),K=0, 2)
40287 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
40289 DATA MEXVEC( 0) / 8 /
40290 DATA MLFVEC( 0) / 2 /
40291 DATA UT1VEC( 0) / -0.4656819E+00 /
40292 DATA UT2VEC( 0) / -0.2742390E+03 /
40293 DATA ALFVEC( 0) / 0.4491863E+00 /
40294 DATA QMAVEC( 0) / 0.0000000E+00 /
40295 DATA (AM( 0,K, 0),K=0, 2)
40296 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
40297 DATA (AM( 1,K, 0),K=0, 2)
40298 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
40299 DATA (AM( 2,K, 0),K=0, 2)
40300 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
40301 DATA (AM( 3,K, 0),K=0, 2)
40302 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
40303 DATA (AM( 4,K, 0),K=0, 2)
40304 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
40305 DATA (AM( 5,K, 0),K=0, 2)
40306 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
40307 DATA (AM( 6,K, 0),K=0, 2)
40308 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
40309 DATA (AM( 7,K, 0),K=0, 2)
40310 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
40311 DATA (AM( 8,K, 0),K=0, 2)
40312 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
40314 DATA MEXVEC(-1) / 8 /
40315 DATA MLFVEC(-1) / 2 /
40316 DATA UT1VEC(-1) / 0.3862583E+01 /
40317 DATA UT2VEC(-1) / -0.1265969E+01 /
40318 DATA ALFVEC(-1) / 0.2457668E+00 /
40319 DATA QMAVEC(-1) / 0.0000000E+00 /
40320 DATA (AM( 0,K,-1),K=0, 2)
40321 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
40322 DATA (AM( 1,K,-1),K=0, 2)
40323 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
40324 DATA (AM( 2,K,-1),K=0, 2)
40325 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
40326 DATA (AM( 3,K,-1),K=0, 2)
40327 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
40328 DATA (AM( 4,K,-1),K=0, 2)
40329 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
40330 DATA (AM( 5,K,-1),K=0, 2)
40331 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
40332 DATA (AM( 6,K,-1),K=0, 2)
40333 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
40334 DATA (AM( 7,K,-1),K=0, 2)
40335 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
40336 DATA (AM( 8,K,-1),K=0, 2)
40337 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
40339 DATA MEXVEC(-2) / 7 /
40340 DATA MLFVEC(-2) / 2 /
40341 DATA UT1VEC(-2) / 0.1895615E+00 /
40342 DATA UT2VEC(-2) / -0.3069097E+01 /
40343 DATA ALFVEC(-2) / 0.5293999E+00 /
40344 DATA QMAVEC(-2) / 0.0000000E+00 /
40345 DATA (AM( 0,K,-2),K=0, 2)
40346 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
40347 DATA (AM( 1,K,-2),K=0, 2)
40348 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
40349 DATA (AM( 2,K,-2),K=0, 2)
40350 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
40351 DATA (AM( 3,K,-2),K=0, 2)
40352 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
40353 DATA (AM( 4,K,-2),K=0, 2)
40354 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
40355 DATA (AM( 5,K,-2),K=0, 2)
40356 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
40357 DATA (AM( 6,K,-2),K=0, 2)
40358 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
40359 DATA (AM( 7,K,-2),K=0, 2)
40360 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
40362 DATA MEXVEC(-3) / 7 /
40363 DATA MLFVEC(-3) / 2 /
40364 DATA UT1VEC(-3) / 0.3753257E+01 /
40365 DATA UT2VEC(-3) / -0.1113085E+01 /
40366 DATA ALFVEC(-3) / 0.3713141E+00 /
40367 DATA QMAVEC(-3) / 0.0000000E+00 /
40368 DATA (AM( 0,K,-3),K=0, 2)
40369 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
40370 DATA (AM( 1,K,-3),K=0, 2)
40371 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
40372 DATA (AM( 2,K,-3),K=0, 2)
40373 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
40374 DATA (AM( 3,K,-3),K=0, 2)
40375 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
40376 DATA (AM( 4,K,-3),K=0, 2)
40377 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
40378 DATA (AM( 5,K,-3),K=0, 2)
40379 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
40380 DATA (AM( 6,K,-3),K=0, 2)
40381 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
40382 DATA (AM( 7,K,-3),K=0, 2)
40383 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
40385 DATA MEXVEC(-4) / 7 /
40386 DATA MLFVEC(-4) / 2 /
40387 DATA UT1VEC(-4) / 0.4400772E+01 /
40388 DATA UT2VEC(-4) / -0.1356116E+01 /
40389 DATA ALFVEC(-4) / 0.3712017E-01 /
40390 DATA QMAVEC(-4) / 0.1300000E+01 /
40391 DATA (AM( 0,K,-4),K=0, 2)
40392 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
40393 DATA (AM( 1,K,-4),K=0, 2)
40394 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
40395 DATA (AM( 2,K,-4),K=0, 2)
40396 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
40397 DATA (AM( 3,K,-4),K=0, 2)
40398 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
40399 DATA (AM( 4,K,-4),K=0, 2)
40400 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
40401 DATA (AM( 5,K,-4),K=0, 2)
40402 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
40403 DATA (AM( 6,K,-4),K=0, 2)
40404 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
40405 DATA (AM( 7,K,-4),K=0, 2)
40406 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
40408 DATA MEXVEC(-5) / 6 /
40409 DATA MLFVEC(-5) / 2 /
40410 DATA UT1VEC(-5) / 0.5562568E+01 /
40411 DATA UT2VEC(-5) / -0.1801317E+01 /
40412 DATA ALFVEC(-5) / 0.4952010E-02 /
40413 DATA QMAVEC(-5) / 0.4500000E+01 /
40414 DATA (AM( 0,K,-5),K=0, 2)
40415 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
40416 DATA (AM( 1,K,-5),K=0, 2)
40417 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
40418 DATA (AM( 2,K,-5),K=0, 2)
40419 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
40420 DATA (AM( 3,K,-5),K=0, 2)
40421 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
40422 DATA (AM( 4,K,-5),K=0, 2)
40423 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
40424 DATA (AM( 5,K,-5),K=0, 2)
40425 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
40426 DATA (AM( 6,K,-5),K=0, 2)
40427 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
40429 IF(Q .LE. QMAVEC(IFL)) THEN
40434 IF(X .GE. 1.D0) THEN
40439 TMP = LOG(Q/ALFVEC(IFL))
40440 IF(TMP .LE. 0.D0) THEN
40452 DO 100 K = 0, MLFVEC(IFL)
40453 AF(I) = AF(I) + SBX*AM(I,K,IFL)
40459 U = LOG(X/0.00001D0)
40461 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
40462 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
40463 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
40464 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
40465 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
40467 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
40469 C...Include threshold factor.
40470 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
40475 C*********************************************************************
40478 C...Auxiliary function for parametrization of CTEQ5M1.
40479 C...Author: J. Pumplin 9/99.
40481 FUNCTION PYCT5M(IFL,X,Q)
40483 C...Double precision declaration.
40484 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40485 IMPLICIT INTEGER(I-N)
40487 PARAMETER (NEX=8, NLF=2)
40488 DIMENSION AM(0:NEX,0:NLF,-5:2)
40489 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
40490 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
40491 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
40492 DIMENSION AF(0:NEX)
40494 DATA MEXVEC( 2) / 8 /
40495 DATA MLFVEC( 2) / 2 /
40496 DATA UT1VEC( 2) / 0.5141718E+01 /
40497 DATA UT2VEC( 2) / -0.1346944E+01 /
40498 DATA ALFVEC( 2) / 0.5260555E+00 /
40499 DATA QMAVEC( 2) / 0.0000000E+00 /
40500 DATA (AM( 0,K, 2),K=0, 2)
40501 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
40502 DATA (AM( 1,K, 2),K=0, 2)
40503 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
40504 DATA (AM( 2,K, 2),K=0, 2)
40505 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
40506 DATA (AM( 3,K, 2),K=0, 2)
40507 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
40508 DATA (AM( 4,K, 2),K=0, 2)
40509 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
40510 DATA (AM( 5,K, 2),K=0, 2)
40511 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
40512 DATA (AM( 6,K, 2),K=0, 2)
40513 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
40514 DATA (AM( 7,K, 2),K=0, 2)
40515 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
40516 DATA (AM( 8,K, 2),K=0, 2)
40517 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
40519 DATA MEXVEC( 1) / 8 /
40520 DATA MLFVEC( 1) / 2 /
40521 DATA UT1VEC( 1) / 0.4138426E+01 /
40522 DATA UT2VEC( 1) / -0.3221374E+01 /
40523 DATA ALFVEC( 1) / 0.4960962E+00 /
40524 DATA QMAVEC( 1) / 0.0000000E+00 /
40525 DATA (AM( 0,K, 1),K=0, 2)
40526 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
40527 DATA (AM( 1,K, 1),K=0, 2)
40528 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
40529 DATA (AM( 2,K, 1),K=0, 2)
40530 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
40531 DATA (AM( 3,K, 1),K=0, 2)
40532 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
40533 DATA (AM( 4,K, 1),K=0, 2)
40534 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
40535 DATA (AM( 5,K, 1),K=0, 2)
40536 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
40537 DATA (AM( 6,K, 1),K=0, 2)
40538 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
40539 DATA (AM( 7,K, 1),K=0, 2)
40540 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
40541 DATA (AM( 8,K, 1),K=0, 2)
40542 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
40544 DATA MEXVEC( 0) / 8 /
40545 DATA MLFVEC( 0) / 2 /
40546 DATA UT1VEC( 0) / -0.1026789E+01 /
40547 DATA UT2VEC( 0) / -0.9051707E+01 /
40548 DATA ALFVEC( 0) / 0.9462977E+00 /
40549 DATA QMAVEC( 0) / 0.0000000E+00 /
40550 DATA (AM( 0,K, 0),K=0, 2)
40551 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
40552 DATA (AM( 1,K, 0),K=0, 2)
40553 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
40554 DATA (AM( 2,K, 0),K=0, 2)
40555 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
40556 DATA (AM( 3,K, 0),K=0, 2)
40557 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
40558 DATA (AM( 4,K, 0),K=0, 2)
40559 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
40560 DATA (AM( 5,K, 0),K=0, 2)
40561 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
40562 DATA (AM( 6,K, 0),K=0, 2)
40563 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
40564 DATA (AM( 7,K, 0),K=0, 2)
40565 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
40566 DATA (AM( 8,K, 0),K=0, 2)
40567 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
40569 DATA MEXVEC(-1) / 8 /
40570 DATA MLFVEC(-1) / 2 /
40571 DATA UT1VEC(-1) / 0.5243571E+01 /
40572 DATA UT2VEC(-1) / -0.2870513E+01 /
40573 DATA ALFVEC(-1) / 0.6701448E+00 /
40574 DATA QMAVEC(-1) / 0.0000000E+00 /
40575 DATA (AM( 0,K,-1),K=0, 2)
40576 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
40577 DATA (AM( 1,K,-1),K=0, 2)
40578 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
40579 DATA (AM( 2,K,-1),K=0, 2)
40580 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
40581 DATA (AM( 3,K,-1),K=0, 2)
40582 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
40583 DATA (AM( 4,K,-1),K=0, 2)
40584 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
40585 DATA (AM( 5,K,-1),K=0, 2)
40586 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
40587 DATA (AM( 6,K,-1),K=0, 2)
40588 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
40589 DATA (AM( 7,K,-1),K=0, 2)
40590 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
40591 DATA (AM( 8,K,-1),K=0, 2)
40592 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
40594 DATA MEXVEC(-2) / 7 /
40595 DATA MLFVEC(-2) / 2 /
40596 DATA UT1VEC(-2) / 0.4782210E+01 /
40597 DATA UT2VEC(-2) / -0.1976856E+02 /
40598 DATA ALFVEC(-2) / 0.7558374E+00 /
40599 DATA QMAVEC(-2) / 0.0000000E+00 /
40600 DATA (AM( 0,K,-2),K=0, 2)
40601 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
40602 DATA (AM( 1,K,-2),K=0, 2)
40603 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
40604 DATA (AM( 2,K,-2),K=0, 2)
40605 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
40606 DATA (AM( 3,K,-2),K=0, 2)
40607 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
40608 DATA (AM( 4,K,-2),K=0, 2)
40609 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
40610 DATA (AM( 5,K,-2),K=0, 2)
40611 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
40612 DATA (AM( 6,K,-2),K=0, 2)
40613 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
40614 DATA (AM( 7,K,-2),K=0, 2)
40615 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
40617 DATA MEXVEC(-3) / 7 /
40618 DATA MLFVEC(-3) / 2 /
40619 DATA UT1VEC(-3) / 0.4518239E+01 /
40620 DATA UT2VEC(-3) / -0.2690590E+01 /
40621 DATA ALFVEC(-3) / 0.6124079E+00 /
40622 DATA QMAVEC(-3) / 0.0000000E+00 /
40623 DATA (AM( 0,K,-3),K=0, 2)
40624 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
40625 DATA (AM( 1,K,-3),K=0, 2)
40626 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
40627 DATA (AM( 2,K,-3),K=0, 2)
40628 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
40629 DATA (AM( 3,K,-3),K=0, 2)
40630 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
40631 DATA (AM( 4,K,-3),K=0, 2)
40632 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
40633 DATA (AM( 5,K,-3),K=0, 2)
40634 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
40635 DATA (AM( 6,K,-3),K=0, 2)
40636 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
40637 DATA (AM( 7,K,-3),K=0, 2)
40638 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
40640 DATA MEXVEC(-4) / 7 /
40641 DATA MLFVEC(-4) / 2 /
40642 DATA UT1VEC(-4) / 0.2783230E+01 /
40643 DATA UT2VEC(-4) / -0.1746328E+01 /
40644 DATA ALFVEC(-4) / 0.1115653E+01 /
40645 DATA QMAVEC(-4) / 0.1300000E+01 /
40646 DATA (AM( 0,K,-4),K=0, 2)
40647 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
40648 DATA (AM( 1,K,-4),K=0, 2)
40649 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
40650 DATA (AM( 2,K,-4),K=0, 2)
40651 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
40652 DATA (AM( 3,K,-4),K=0, 2)
40653 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
40654 DATA (AM( 4,K,-4),K=0, 2)
40655 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
40656 DATA (AM( 5,K,-4),K=0, 2)
40657 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
40658 DATA (AM( 6,K,-4),K=0, 2)
40659 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
40660 DATA (AM( 7,K,-4),K=0, 2)
40661 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
40663 DATA MEXVEC(-5) / 6 /
40664 DATA MLFVEC(-5) / 2 /
40665 DATA UT1VEC(-5) / 0.1619654E+02 /
40666 DATA UT2VEC(-5) / -0.3367346E+01 /
40667 DATA ALFVEC(-5) / 0.5109891E-02 /
40668 DATA QMAVEC(-5) / 0.4500000E+01 /
40669 DATA (AM( 0,K,-5),K=0, 2)
40670 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
40671 DATA (AM( 1,K,-5),K=0, 2)
40672 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
40673 DATA (AM( 2,K,-5),K=0, 2)
40674 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
40675 DATA (AM( 3,K,-5),K=0, 2)
40676 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
40677 DATA (AM( 4,K,-5),K=0, 2)
40678 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
40679 DATA (AM( 5,K,-5),K=0, 2)
40680 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
40681 DATA (AM( 6,K,-5),K=0, 2)
40682 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
40684 IF(Q .LE. QMAVEC(IFL)) THEN
40689 IF(X .GE. 1.D0) THEN
40694 TMP = LOG(Q/ALFVEC(IFL))
40695 IF(TMP .LE. 0.D0) THEN
40707 DO 100 K = 0, MLFVEC(IFL)
40708 AF(I) = AF(I) + SBX*AM(I,K,IFL)
40714 U = LOG(X/0.00001D0)
40716 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
40717 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
40718 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
40719 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
40720 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
40722 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
40724 C...Include threshold factor.
40725 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
40730 C*********************************************************************
40733 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
40734 C...a few older parametrizations, now obsolete but convenient for
40735 C...backwards checks.
40737 SUBROUTINE PYPDPO(X,Q2,XPPR)
40739 C...Double precision and integer declarations.
40740 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40741 IMPLICIT INTEGER(I-N)
40742 INTEGER PYK,PYCHGE,PYCOMP
40744 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40745 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40746 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40747 COMMON/PYINT1/MINT(400),VINT(400)
40748 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
40749 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
40750 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
40753 C...The following data lines are coefficients needed in the
40754 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
40755 C...parametrizations, see below.
40756 C...Powers of 1-x in different cases.
40757 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
40758 C...Expansion coefficients for up valence quark distribution.
40759 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
40760 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
40761 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
40762 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
40763 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
40764 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
40765 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
40766 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
40767 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
40768 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
40769 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
40770 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
40771 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
40772 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
40773 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
40774 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
40775 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
40776 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
40777 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
40778 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
40779 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
40780 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
40781 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
40782 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
40783 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
40784 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
40785 C...Expansion coefficients for down valence quark distribution.
40786 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
40787 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
40788 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
40789 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
40790 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
40791 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
40792 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
40793 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
40794 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
40795 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
40796 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
40797 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
40798 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
40799 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
40800 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
40801 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
40802 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
40803 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
40804 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
40805 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
40806 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
40807 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
40808 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
40809 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
40810 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
40811 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
40812 C...Expansion coefficients for up and down sea quark distributions.
40813 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
40814 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
40815 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
40816 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
40817 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
40818 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
40819 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
40820 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
40821 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
40822 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
40823 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
40824 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
40825 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
40826 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
40827 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
40828 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
40829 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
40830 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
40831 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
40832 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
40833 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
40834 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
40835 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
40836 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
40837 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
40838 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
40839 C...Expansion coefficients for gluon distribution.
40840 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
40841 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
40842 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
40843 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
40844 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
40845 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
40846 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
40847 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
40848 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
40849 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
40850 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
40851 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
40852 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
40853 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
40854 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
40855 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
40856 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
40857 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
40858 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
40859 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
40860 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
40861 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
40862 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
40863 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
40864 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
40865 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
40866 C...Expansion coefficients for strange sea quark distribution.
40867 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
40868 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
40869 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
40870 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
40871 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
40872 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
40873 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
40874 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
40875 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
40876 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
40877 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
40878 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
40879 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
40880 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
40881 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
40882 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
40883 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
40884 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
40885 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
40886 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
40887 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
40888 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
40889 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
40890 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
40891 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
40892 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
40893 C...Expansion coefficients for charm sea quark distribution.
40894 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
40895 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
40896 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
40897 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
40898 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
40899 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
40900 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
40901 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
40902 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
40903 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
40904 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
40905 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
40906 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
40907 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
40908 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
40909 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
40910 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
40911 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
40912 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
40913 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
40914 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
40915 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
40916 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
40917 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
40918 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
40919 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
40920 C...Expansion coefficients for bottom sea quark distribution.
40921 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
40922 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
40923 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
40924 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
40925 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
40926 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
40927 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
40928 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
40929 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
40930 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
40931 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
40932 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
40933 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
40934 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
40935 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
40936 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
40937 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
40938 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
40939 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
40940 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
40941 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
40942 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
40943 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
40944 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
40945 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
40946 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
40947 C...Expansion coefficients for top sea quark distribution.
40948 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
40949 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
40950 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
40951 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
40952 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
40953 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
40954 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
40955 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
40956 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
40957 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
40958 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
40959 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
40960 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
40961 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
40962 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
40963 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
40964 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
40965 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
40966 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
40967 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
40968 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
40969 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
40970 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
40971 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
40972 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
40973 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
40975 C...The following data lines are coefficients needed in the
40976 C...Duke, Owens proton structure function parametrizations, see below.
40977 C...Expansion coefficients for (up+down) valence quark distribution.
40978 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
40979 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40980 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40981 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
40982 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
40983 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40984 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40985 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
40986 C...Expansion coefficients for down valence quark distribution.
40987 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
40988 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40989 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
40990 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
40991 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
40992 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40993 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
40994 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
40995 C...Expansion coefficients for (up+down+strange) sea quark distribution.
40996 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
40997 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40998 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
40999 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
41000 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
41001 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41002 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
41003 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
41004 C...Expansion coefficients for charm sea quark distribution.
41005 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
41006 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41007 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
41008 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
41009 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
41010 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41011 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
41012 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
41013 C...Expansion coefficients for gluon distribution.
41014 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
41015 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41016 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
41017 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
41018 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
41019 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41020 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
41021 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
41023 C...Euler's beta function, requires ordinary Gamma function
41024 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
41026 C...Leading order proton parton distributions from Glueck, Reya and
41027 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
41029 IF(MSTP(51).EQ.11) THEN
41031 C...Determine s expansion variable and some x expressions.
41032 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
41033 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
41038 C...Evaluate valence, gluon and sea distributions.
41039 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
41040 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
41041 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
41042 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
41043 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
41044 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
41045 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
41046 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
41047 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
41048 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
41049 & SQRT(4.066D0*SD**1.218D0*XL)))*
41050 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
41051 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
41052 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
41053 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
41054 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
41055 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
41056 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
41057 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
41058 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
41059 IF(SD.LE.0.888D0) THEN
41062 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
41063 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
41064 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
41066 IF(SD.LE.1.351D0) THEN
41069 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
41070 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
41071 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
41074 C...Put into output array.
41076 XPPR(1)=XFVDD+XFSEA
41077 XPPR(2)=XFVUD-XFVDD+XFSEA
41087 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
41088 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
41089 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
41091 C...Determine set, Lambda and x and t expansion variables.
41093 IF(NSET.EQ.1) ALAM=0.2D0
41094 IF(NSET.EQ.2) ALAM=0.29D0
41095 TMIN=LOG(5D0/ALAM**2)
41096 TMAX=LOG(1D8/ALAM**2)
41097 T=LOG(MAX(1D0,Q2/ALAM**2))
41098 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
41100 IF(X.LE.0.1D0) NX=2
41101 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
41102 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
41104 C...Chebyshev polynomials for x and t expansion.
41107 TX(3)=2D0*VX**2-1D0
41108 TX(4)=4D0*VX**3-3D0*VX
41109 TX(5)=8D0*VX**4-8D0*VX**2+1D0
41110 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
41113 TT(3)=2D0*VT**2-1D0
41114 TT(4)=4D0*VT**3-3D0*VT
41115 TT(5)=8D0*VT**4-8D0*VT**2+1D0
41116 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
41118 C...Calculate structure functions.
41123 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
41126 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
41129 C...Put into output array.
41131 XPPR(1)=XQ(2)+XQ(3)
41132 XPPR(2)=XQ(1)+XQ(3)
41140 C...Special expansion for bottom (threshold effects).
41141 IF(MSTP(58).GE.5) THEN
41142 IF(NSET.EQ.1) TMIN=8.1905D0
41143 IF(NSET.EQ.2) TMIN=7.4474D0
41145 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
41148 TT(3)=2D0*VT**2-1D0
41149 TT(4)=4D0*VT**3-3D0*VT
41150 TT(5)=8D0*VT**4-8D0*VT**2+1D0
41151 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
41155 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
41158 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
41163 C...Special expansion for top (threshold effects).
41164 IF(MSTP(58).GE.6) THEN
41165 IF(NSET.EQ.1) TMIN=11.5528D0
41166 IF(NSET.EQ.2) TMIN=10.8097D0
41167 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
41168 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
41170 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
41173 TT(3)=2D0*VT**2-1D0
41174 TT(4)=4D0*VT**3-3D0*VT
41175 TT(5)=8D0*VT**4-8D0*VT**2+1D0
41176 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
41180 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
41183 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
41188 C...Proton parton distributions from Duke, Owens.
41189 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
41190 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
41192 C...Determine set, Lambda and s expansion parameter.
41194 IF(NSET.EQ.1) ALAM=0.2D0
41195 IF(NSET.EQ.2) ALAM=0.4D0
41196 Q2IN=MIN(1D6,MAX(4D0,Q2))
41197 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
41199 C...Calculate structure functions.
41202 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
41203 & CDO(3,IS,KFL,NSET)*SD**2
41206 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
41207 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
41209 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
41210 & TS(5)*X**2+TS(6)*X**3)
41214 C...Put into output arrays.
41216 XPPR(1)=XQ(2)+XQ(3)/6D0
41217 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
41230 C*********************************************************************
41233 C...Gives threshold attractive/repulsive factor for heavy flavour
41236 FUNCTION PYHFTH(SH,SQM,FRATT)
41238 C...Double precision and integer declarations.
41239 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41240 IMPLICIT INTEGER(I-N)
41241 INTEGER PYK,PYCHGE,PYCOMP
41243 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41244 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41245 COMMON/PYINT1/MINT(400),VINT(400)
41246 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
41248 C...Value for alpha_strong.
41249 IF(MSTP(35).LE.1) THEN
41254 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
41260 C...Evaluate attractive and repulsive factors.
41261 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
41262 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
41263 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
41264 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
41265 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
41271 C*********************************************************************
41274 C...Splits a hadron remnant into two (partons or hadron + parton)
41275 C...in case it is more complicated than just a quark or a diquark.
41277 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
41279 C...Double precision and integer declarations.
41280 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41281 IMPLICIT INTEGER(I-N)
41282 INTEGER PYK,PYCHGE,PYCOMP
41283 C...Commonblocks. PYDAT1 temporary
41284 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41285 COMMON/PYINT1/MINT(400),VINT(400)
41286 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41287 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
41291 C...Preliminaries. Parton composition.
41294 KFL(1)=MOD(KFA/1000,10)
41295 KFL(2)=MOD(KFA/100,10)
41296 KFL(3)=MOD(KFA/10,10)
41297 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
41298 KFL(2)=INT(1.5D0+PYR(0))
41299 IF(MINT(105).EQ.333) KFL(2)=3
41300 IF(MINT(105).EQ.443) KFL(2)=4
41302 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
41305 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
41308 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
41309 KFL(2)=MOD(KFA/10,10)
41310 KFL(3)=MOD(KFA/100,10)
41312 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
41319 C...Subdivide lepton.
41320 IF(KFA.GE.11.AND.KFA.LE.18) THEN
41321 IF(KFLR.EQ.KFA) THEN
41323 ELSEIF(KFLR.EQ.22) THEN
41325 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
41327 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
41329 ELSEIF(KFLR.EQ.21) THEN
41337 C...Subdivide photon.
41338 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
41339 IF(KFLR.NE.21) THEN
41344 IF(RAGR.GT.0.125D0) KFLSP=2
41345 IF(RAGR.GT.0.625D0) KFLSP=3
41346 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
41350 C...Subdivide Reggeon or Pomeron.
41351 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
41352 IF(KFLIN.EQ.21) THEN
41358 C...Subdivide meson.
41359 ELSEIF(KFL(1).EQ.0) THEN
41360 KFL(2)=KFL(2)*(-1)**KFL(2)
41361 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
41362 IF(KFLR.EQ.KFL(2)) THEN
41364 ELSEIF(KFLR.EQ.KFL(3)) THEN
41366 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
41369 ELSEIF(KFLR.EQ.21) THEN
41372 ELSEIF(KFLR*KFL(2).GT.0) THEN
41375 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
41376 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41378 ELSEIF(KFLCH.EQ.0) THEN
41379 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41387 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
41388 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41390 ELSEIF(KFLCH.EQ.0) THEN
41391 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41398 C...Special case for extracting photon from baryon without splitting
41399 C...the latter. (Currently only used by external programs.)
41400 ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
41404 C...Subdivide baryon.
41408 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
41411 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
41414 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
41415 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
41418 IAGR=1.00001D0+2.99998D0*PYR(0)
41421 IF(IAGR.EQ.1) ID1=2
41422 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
41425 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
41426 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
41427 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
41428 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
41429 ELSEIF(MOD(KFA,10).EQ.2) THEN
41430 IF(IAGR.EQ.1) KSP=1
41431 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
41433 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
41434 IF(KFLR.EQ.21) THEN
41436 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
41439 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
41440 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41442 ELSEIF(KFLCH.EQ.0) THEN
41443 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41447 ELSEIF(NAGR.EQ.0) THEN
41450 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
41451 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41453 ELSEIF(KFLCH.EQ.0) THEN
41454 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41462 C...Add on correct sign for result.
41469 C*********************************************************************
41472 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
41473 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
41474 C...(Dover, 1965) 6.1.36.
41478 C...Double precision and integer declarations.
41479 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41480 IMPLICIT INTEGER(I-N)
41481 INTEGER PYK,PYCHGE,PYCOMP
41482 C...Local array and data.
41484 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
41485 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
41494 PYGAMM=PYGAMM+B(I)*DXP
41500 PYGAMM=(X-IX)*PYGAMM
41507 C***********************************************************************
41510 C...Calculates real and imaginary parts of the auxiliary functions W1
41511 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
41512 C...der Bij, Nucl. Phys. B297 (1988) 221.
41514 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
41516 C...Double precision and integer declarations.
41517 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41518 IMPLICIT INTEGER(I-N)
41519 INTEGER PYK,PYCHGE,PYCOMP
41521 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41524 ASINH(X)=LOG(X+SQRT(X**2+1D0))
41525 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
41527 IF(EPS.LT.0D0) THEN
41528 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
41529 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
41531 ELSEIF(EPS.LT.1D0) THEN
41532 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
41533 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
41534 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
41535 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
41537 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
41538 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
41545 C***********************************************************************
41548 C...Calculates real and imaginary parts of the auxiliary function I3;
41549 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
41550 C...Nucl. Phys. B297 (1988) 221.
41552 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
41554 C...Double precision and integer declarations.
41555 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41556 IMPLICIT INTEGER(I-N)
41557 INTEGER PYK,PYCHGE,PYCOMP
41559 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41562 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
41563 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
41565 IF(EPS.LT.0D0) THEN
41566 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41567 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
41568 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
41569 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
41570 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
41571 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
41572 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
41573 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
41575 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
41576 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
41577 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
41578 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
41579 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
41580 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
41581 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
41582 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
41583 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41584 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
41585 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
41586 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
41587 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
41588 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
41589 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
41590 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
41592 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
41593 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
41594 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
41595 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
41596 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
41599 ELSEIF(EPS.LT.1D0) THEN
41600 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41601 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
41602 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
41603 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
41604 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
41605 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
41606 & (0.25D0*(RAT+1D0)*EPS))
41607 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
41608 & (0.25D0*(RAT+1D0)*EPS))
41609 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
41610 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
41611 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
41612 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
41613 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
41614 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
41615 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
41616 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
41617 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41618 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
41619 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
41620 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
41621 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
41622 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
41623 & (1D0+0.25D0*RAT*EPS-GA))
41624 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
41625 & (1D0+0.25D0*RAT*EPS-GA))
41627 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
41628 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
41629 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
41630 & LOG((GA+BE-1D0)/(BE-GA))
41631 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
41634 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
41635 RCTHE=RSQ*(1D0-2D0*BE/EPS)
41636 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
41637 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
41638 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
41640 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
41641 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
41642 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
41643 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
41644 & (PHI-THE)*(PHI+THE-PARU(1))
41645 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
41646 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
41649 Y3RE=2D0/(2D0*BE-1D0)*F3RE
41650 Y3IM=2D0/(2D0*BE-1D0)*F3IM
41655 C***********************************************************************
41658 C...Calculates real and imaginary part of Spence function; see
41659 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
41661 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
41663 C...Double precision and integer declarations.
41664 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41665 IMPLICIT INTEGER(I-N)
41666 INTEGER PYK,PYCHGE,PYCOMP
41668 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41670 C...Local array and data.
41673 &1.000000D+00, -5.000000D-01, 1.666667D-01,
41674 &0.000000D+00, -3.333333D-02, 0.000000D+00,
41675 &2.380952D-02, 0.000000D+00, -3.333333D-02,
41676 &0.000000D+00, 7.575757D-02, 0.000000D+00,
41677 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
41681 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
41682 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
41683 IF(IREIM.EQ.2) PYSPEN=0D0
41687 XMOD=SQRT(XRE**2+XIM**2)
41688 IF(XMOD.LT.1D-6) THEN
41689 IF(IREIM.EQ.1) PYSPEN=0D0
41690 IF(IREIM.EQ.2) PYSPEN=0D0
41694 XARG=SIGN(ACOS(XRE/XMOD),XIM)
41698 IF(XMOD.GT.1D0) THEN
41700 ALGXIM=XARG-SIGN(PARU(1),XARG)
41701 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
41702 SP0IM=-ALGXRE*ALGXIM
41709 IF(XRE.GT.0.5D0) THEN
41714 XMOD=SQRT(XRE**2+XIM**2)
41715 XARG=SIGN(ACOS(XRE/XMOD),XIM)
41718 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
41719 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
41725 XMOD=SQRT(XRE**2+XIM**2)
41726 XARG=SIGN(ACOS(XRE/XMOD),XIM)
41735 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
41736 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
41737 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
41740 SPRE=SPRE+B(I)*TERMRE
41741 SPIM=SPIM+B(I)*TERMIM
41744 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
41745 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
41750 C***********************************************************************
41753 C...Calculates the matrix element for the processes
41754 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
41755 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
41756 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
41758 SUBROUTINE PYQQBH(WTQQBH)
41760 C...Double precision and integer declarations.
41761 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41762 IMPLICIT INTEGER(I-N)
41763 INTEGER PYK,PYCHGE,PYCOMP
41765 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41766 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41767 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41768 COMMON/PYINT1/MINT(400),VINT(400)
41769 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
41770 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
41771 C...Local arrays and function.
41772 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
41773 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
41776 C...Mass parameters.
41779 SHPR=SQRT(VINT(26))*VINT(1)
41780 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
41781 PH=SQRT(VINT(21))*VINT(1)
41785 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
41787 PT=SQRT(MAX(0D0,VINT(197+5*I)))
41788 PP(I,1)=PT*COS(VINT(198+5*I))
41789 PP(I,2)=PT*SIN(VINT(198+5*I))
41791 PP(3,1)=-PP(1,1)-PP(2,1)
41792 PP(3,2)=-PP(1,2)-PP(2,2)
41793 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
41794 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
41795 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
41797 PP(3,3)=PMT3*SINH(VINT(211))
41798 PP(3,4)=PMT3*COSH(VINT(211))
41799 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
41800 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
41801 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
41802 PP(2,3)=-PP(1,3)-PP(3,3)
41803 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
41804 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
41806 C...Set up incoming kinematics and derived momentum combinations.
41810 PP(I,3)=-0.5D0*SHPR*(-1)**I
41811 PP(I,4)=-0.5D0*SHPR
41814 PP(6,J)=PP(1,J)+PP(2,J)
41815 PP(7,J)=PP(1,J)+PP(3,J)
41816 PP(8,J)=PP(1,J)+PP(4,J)
41817 PP(9,J)=PP(1,J)+PP(5,J)
41818 PP(10,J)=-PP(2,J)-PP(3,J)
41819 PP(11,J)=-PP(2,J)-PP(4,J)
41820 PP(12,J)=-PP(2,J)-PP(5,J)
41821 PP(13,J)=-PP(4,J)-PP(5,J)
41824 C...Derived kinematics invariants.
41853 C...Define colour coefficients for g + g -> Q + Qbar + H.
41854 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
41858 CLR(I+3,J+3)=16D0/3D0
41859 CLR(I,J+3)=-2D0/3D0
41860 CLR(I+3,J)=-2D0/3D0
41873 CLR(6+K1,6+K2)=12D0
41877 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
41878 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
41879 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
41880 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
41881 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
41882 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
41883 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
41885 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
41886 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
41887 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
41888 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
41889 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
41890 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
41891 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
41892 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
41893 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
41894 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
41895 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
41896 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
41897 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
41898 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
41899 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
41900 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
41901 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
41902 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
41904 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
41905 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
41906 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
41907 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
41908 & +X4*X9*X5+X4*X5**2)
41909 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
41910 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
41911 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
41912 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
41913 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
41914 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
41915 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
41916 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
41917 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
41918 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
41919 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
41920 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
41921 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
41922 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
41923 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
41924 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
41925 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
41926 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
41927 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
41928 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
41930 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
41931 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
41932 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
41933 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
41934 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
41935 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
41936 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
41938 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
41939 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
41940 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
41941 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
41942 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
41943 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
41945 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
41946 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
41947 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
41948 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
41949 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
41950 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
41951 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
41953 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
41954 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
41955 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
41956 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
41957 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
41958 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
41959 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
41960 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
41961 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
41962 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
41963 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
41964 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
41965 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
41966 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
41967 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
41968 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
41969 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
41970 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
41971 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
41972 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
41973 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
41974 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
41975 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
41976 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
41977 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
41978 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
41979 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
41980 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
41981 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
41982 & +X3*X8*X5+X3*X5**2)
41983 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
41984 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
41985 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
41986 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
41987 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
41988 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
41989 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
41991 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
41992 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
41993 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
41994 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
41995 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
41996 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
41997 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
41998 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
41999 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
42000 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
42001 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
42002 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
42003 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
42004 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
42005 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
42006 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
42007 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
42008 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
42009 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
42010 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
42011 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
42012 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
42013 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
42014 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
42015 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
42016 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
42018 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
42019 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
42020 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42021 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
42022 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
42023 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
42024 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
42025 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
42026 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
42027 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
42028 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
42029 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
42030 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
42031 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
42032 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
42033 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
42034 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
42035 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
42036 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
42037 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
42038 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
42039 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
42040 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
42041 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
42042 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
42043 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
42045 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42046 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42047 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
42048 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
42049 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
42050 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
42051 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
42052 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
42053 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
42054 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
42055 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
42056 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42057 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42058 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
42059 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
42060 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
42061 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
42062 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
42063 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
42064 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
42065 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
42066 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
42067 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
42068 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
42069 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
42070 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
42071 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
42072 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
42073 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
42074 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
42075 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
42076 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
42077 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
42078 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
42079 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
42080 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
42081 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
42082 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
42083 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
42084 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
42085 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
42086 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
42087 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
42088 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
42090 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
42091 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
42092 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
42093 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
42094 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
42095 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
42096 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
42097 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
42098 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
42099 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
42100 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
42102 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
42103 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
42104 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
42105 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
42106 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
42107 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
42109 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
42110 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
42111 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
42113 FM(9,10)=0.5D0*(FMXX+FM(9,10))
42114 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
42115 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
42116 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
42118 C...Repackage matrix elements.
42124 RM(7,7)=FM(7,7)-2D0*FM(9,9)
42125 RM(7,8)=FM(7,8)-2D0*FM(9,10)
42126 RM(8,8)=FM(8,8)-2D0*FM(10,10)
42128 C...Produce final result: matrix elements * colours * propagators.
42133 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
42136 WTQQBH=-WTQQBH/256D0
42139 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
42140 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
42141 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
42143 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
42144 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
42145 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
42147 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
42148 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
42151 C...Produce final result: matrix elements * propagators.
42153 A12=A12/(DX(7)*DX(8))
42155 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
42161 C*********************************************************************
42163 C...PYSTBH (and auxiliaries)
42164 C.. Evaluates the matrix elements for t + b + H production.
42166 SUBROUTINE PYSTBH(WTTBH)
42168 C...DOUBLE PRECISION AND INTEGER DECLARATIONS
42169 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42170 IMPLICIT INTEGER(I-N)
42171 INTEGER PYK,PYCHGE,PYCOMP
42174 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42175 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42176 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42177 COMMON/PYINT1/MINT(400),VINT(400)
42178 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42179 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
42180 COMMON/PYINT4/MWID(500),WIDS(500,5)
42181 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
42182 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42183 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
42184 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
42185 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
42186 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
42187 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42188 DOUBLE PRECISION MW2
42189 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
42190 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
42192 C...LOCAL ARRAYS AND COMPLEX VARIABLES
42193 DIMENSION QQ(4,2),PP(4,3)
42198 C...KINEMATIC PARAMETERS.
42199 SHPR=SQRT(VINT(26))*VINT(1)
42200 PH=SQRT(VINT(21))*VINT(1)
42203 C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
42205 PT=SQRT(MAX(0D0,VINT(197+5*I)))
42206 PP(1,I)=PT*COS(VINT(198+5*I))
42207 PP(2,I)=PT*SIN(VINT(198+5*I))
42209 PP(1,3)=-PP(1,1)-PP(1,2)
42210 PP(2,3)=-PP(2,1)-PP(2,2)
42211 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
42212 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
42213 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
42215 PP(3,3)=PMT3*SINH(VINT(211))
42216 PP(4,3)=PMT3*COSH(VINT(211))
42217 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
42218 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
42219 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
42220 PP(3,2)=-PP(3,1)-PP(3,3)
42221 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
42222 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
42224 C...CM SYSTEM, INGOING QUARKS/GLUONS
42225 QQ(3,1) = SHPR/2.D0
42230 C...PARAMETERS FOR AMPLITUDE METHOD
42234 MW2 = PMAS(24,1)**2
42237 RMB=PYMRUN(5,VINT(52))
42241 IF (ISUB.EQ.401) THEN
42242 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
42243 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
42244 ELSE IF (ISUB.EQ.402) THEN
42245 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
42246 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
42251 C------------------------------------------------------------------
42252 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
42253 C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
42254 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42255 IMPLICIT INTEGER(I-N)
42256 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
42257 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42260 C TOP WIDTH CALCULATION
42267 IF (MT .LT. (MHP+MB)) THEN
42269 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
42270 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
42271 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
42274 C T ->BW +T ->B H^+
42275 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
42276 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
42277 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
42279 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
42280 & -4.D0*(MHP*MB/MT**2)**2 )
42281 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
42282 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
42283 GAMT = GAMTBW+GAMTBH
42290 C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
42291 C GG->TBH^+, QQBAR->TBH^+
42292 C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
42293 C (FOR INSTANCE WITH PYTHIA)
42294 C------------------------------------------------------------
42295 C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
42296 C PHYS REV. D 60 (1999) 115011
42297 C (THESE FILES PREPARED BY J.-L. KNEUR)
42298 C------------------------------------------------------------
42300 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
42302 C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
42304 C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
42305 C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
42306 C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
42307 C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
42308 C "PHYSICAL PARAMETERS" INPUT:
42309 C MT,MB TOP AND BOTTOM MASSES;
42310 C MHP CHARGED HIGGS MASS
42311 C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
42313 C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
42314 C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
42315 C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
42316 C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
42317 C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
42318 C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
42319 C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
42321 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42322 IMPLICIT INTEGER(I-N)
42323 DOUBLE PRECISION MW2,MT,MB,MHP,MW
42324 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
42325 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42326 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42327 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42329 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42330 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
42331 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
42332 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
42333 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
42334 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
42335 C (TAN BETA) VALUES
42337 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
42338 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
42343 C COLLECTING THE RELEVANT OVERALL FACTORS:
42344 C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
42345 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
42346 C COUPLING CONSTANT (OVERALL NORMALIZATION)
42347 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
42348 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
42349 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
42350 C ALPHAS IS ALPHA_STRONG;
42351 C SW2 IS SIN(THETA_W)**2.
42354 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
42356 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
42357 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
42358 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
42360 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
42361 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
42363 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
42365 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
42366 S = 2*PYTBHS(Q1,Q2)
42373 C TOP WIDTH CALCULATION
42374 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
42375 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
42376 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
42377 A1INV= S -2*P1Q1 -2*P1Q2
42378 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
42379 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
42380 C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
42382 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
42383 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
42384 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
42385 C NOW COMES THE AMP**2:
42386 C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
42387 C THE EXPRESSIONS BELOW
42390 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
42391 &512*A1*A2*MB*MT/3-
42392 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
42393 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
42394 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
42395 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
42396 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
42397 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
42398 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
42399 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
42400 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
42401 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
42402 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
42403 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
42404 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
42405 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
42406 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
42407 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
42408 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
42409 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
42410 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
42411 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
42412 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
42413 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
42414 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
42415 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
42416 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
42417 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
42418 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
42419 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
42420 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
42421 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
42422 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
42423 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
42424 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
42425 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
42426 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
42427 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
42428 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
42429 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
42430 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
42431 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
42432 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
42433 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
42434 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
42435 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
42436 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
42437 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
42438 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
42439 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
42440 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
42441 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
42442 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
42443 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
42444 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
42445 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
42446 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
42447 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
42448 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
42449 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
42450 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
42451 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
42452 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
42453 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
42454 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
42455 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
42456 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
42457 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
42458 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
42459 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
42460 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
42461 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
42462 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
42463 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
42464 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42465 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
42466 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42467 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
42468 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
42469 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
42470 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
42471 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
42472 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
42473 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
42474 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
42475 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
42476 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
42477 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
42478 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
42479 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
42480 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
42481 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42482 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42483 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42484 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
42485 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
42486 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
42487 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
42488 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
42489 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
42490 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
42491 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
42492 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
42493 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
42494 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
42495 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
42496 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
42497 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
42498 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
42499 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
42500 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
42501 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
42502 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
42503 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
42504 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
42505 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
42506 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
42507 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
42508 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
42509 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
42510 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
42511 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
42512 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
42513 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
42514 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
42515 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
42516 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
42517 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
42518 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
42519 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
42520 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
42521 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
42522 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
42523 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
42524 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
42525 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
42526 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
42527 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
42528 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
42529 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
42530 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
42531 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
42532 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
42533 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
42534 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
42535 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
42536 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
42537 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
42538 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
42539 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42540 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
42541 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42542 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
42543 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
42544 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42545 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42546 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42547 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
42548 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
42549 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
42550 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
42551 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
42552 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
42553 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
42554 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
42555 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
42556 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
42557 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
42558 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
42559 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
42560 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
42561 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
42562 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
42563 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
42564 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
42565 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
42566 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
42567 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
42568 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
42569 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
42570 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
42571 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
42572 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
42573 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
42574 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
42575 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
42576 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42577 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42578 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
42579 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
42580 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
42581 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
42582 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
42583 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
42584 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
42585 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
42586 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
42587 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
42588 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
42589 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
42590 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
42591 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
42592 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
42593 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
42594 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
42595 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
42596 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
42597 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
42598 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
42599 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
42600 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
42601 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
42602 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
42603 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
42604 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
42605 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
42606 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
42607 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
42608 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
42609 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
42610 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
42611 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
42612 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
42613 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
42614 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
42615 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
42616 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
42617 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
42618 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
42619 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
42620 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
42621 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
42622 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
42623 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
42624 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
42625 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
42626 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
42627 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
42628 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
42629 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
42630 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
42631 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
42632 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
42633 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
42634 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
42635 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42636 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42637 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42638 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
42639 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
42640 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
42641 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
42642 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
42643 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
42644 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
42645 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
42646 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
42647 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
42648 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
42649 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
42650 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
42651 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
42652 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
42653 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
42654 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
42655 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
42656 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
42657 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
42658 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
42659 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
42660 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
42661 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
42662 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
42663 &384*A12*MB*MT*P1Q1**2/S**2+
42664 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
42665 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
42666 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
42667 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
42668 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
42669 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
42670 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
42671 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
42672 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
42673 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
42674 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
42675 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
42676 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
42677 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
42678 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
42679 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
42680 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
42681 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
42682 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
42683 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
42684 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
42685 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
42686 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
42687 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
42688 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
42689 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
42690 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
42691 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
42692 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
42693 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
42694 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
42695 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
42696 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
42697 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
42698 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
42699 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
42700 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
42701 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
42702 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
42703 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
42704 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
42705 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
42706 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
42707 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
42708 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
42709 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
42710 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
42711 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
42712 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
42713 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
42714 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
42715 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
42716 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
42717 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
42718 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
42719 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
42720 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
42721 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
42722 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
42723 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
42724 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
42725 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
42726 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
42727 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
42728 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
42729 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
42730 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
42731 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
42732 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
42733 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
42734 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
42735 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
42736 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
42737 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
42738 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
42739 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
42740 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
42741 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
42742 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
42743 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
42744 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
42745 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
42746 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
42747 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
42748 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
42749 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
42750 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
42751 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
42752 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
42753 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
42754 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
42755 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
42756 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
42757 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
42758 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
42759 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
42760 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
42761 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
42762 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
42763 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
42764 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
42765 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
42766 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
42767 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
42768 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
42769 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
42770 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
42771 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
42772 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
42773 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
42774 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
42775 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
42776 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
42777 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
42778 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
42779 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
42780 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
42781 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
42782 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
42783 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
42784 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
42785 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42786 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42787 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42788 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42789 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42790 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42791 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
42792 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
42793 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
42794 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
42795 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
42796 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
42797 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
42798 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
42799 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
42800 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
42801 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
42802 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
42803 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
42804 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
42805 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
42806 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
42807 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
42808 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
42809 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
42810 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
42811 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
42812 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
42813 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
42814 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
42815 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
42816 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
42817 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
42818 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
42819 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
42820 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
42821 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
42822 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
42823 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
42824 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
42825 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
42826 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
42827 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
42828 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
42829 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
42830 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
42831 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
42832 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
42833 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
42834 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
42835 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
42836 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
42837 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
42838 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
42839 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
42842 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42843 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42844 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42845 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42846 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
42847 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
42848 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
42849 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
42850 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
42851 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
42852 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
42853 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
42854 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
42855 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
42856 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
42857 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
42858 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
42859 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
42860 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
42861 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
42862 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
42863 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
42864 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
42865 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
42866 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
42867 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
42868 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
42869 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
42870 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
42871 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
42872 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
42873 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
42874 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
42875 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
42876 &272*A1*A2*P1Q1*S/(3*P1Q2)+
42877 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
42878 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
42879 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
42880 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
42881 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
42882 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
42883 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
42884 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
42885 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
42886 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
42887 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
42888 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
42889 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
42890 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
42891 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
42892 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
42893 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
42894 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
42895 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
42896 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
42897 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
42898 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
42899 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
42900 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
42901 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
42902 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
42903 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
42904 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
42905 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
42906 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
42907 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
42908 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
42909 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
42910 &32*A12*P2Q1*S/(3*P1Q1)-
42911 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
42912 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
42913 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
42914 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
42915 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
42916 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
42917 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
42918 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
42919 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
42920 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
42921 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
42922 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
42923 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
42924 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
42925 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
42926 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
42927 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
42928 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
42929 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
42930 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
42931 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
42932 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
42933 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
42934 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
42935 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
42936 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
42937 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
42938 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
42939 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42940 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
42941 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42942 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
42943 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
42944 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
42945 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
42946 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
42947 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
42948 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
42949 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42950 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
42951 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42952 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42953 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42954 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42955 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42956 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42957 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42958 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42959 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
42960 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
42961 &272*A1*A2*P2Q1*S/(3*P2Q2)-
42962 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
42963 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
42964 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
42965 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
42966 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
42967 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
42968 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
42969 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
42970 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
42971 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
42972 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
42973 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
42974 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
42975 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
42976 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
42977 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
42978 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
42979 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
42980 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
42981 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
42982 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
42983 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
42984 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42987 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
42988 &512*A1*A2*MB*MT/3+
42989 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
42990 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
42991 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
42992 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
42993 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
42994 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
42995 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
42996 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
42997 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
42998 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
42999 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
43000 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
43001 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43002 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43003 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
43004 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
43005 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
43006 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
43007 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43008 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
43009 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
43010 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43011 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43012 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43013 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
43014 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43015 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43016 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43017 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43018 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43019 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
43020 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43021 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43022 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
43023 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
43024 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43025 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
43026 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43027 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43028 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
43029 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
43030 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43031 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
43032 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43033 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43034 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43035 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43036 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
43037 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
43038 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43039 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
43040 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43041 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43042 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43043 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43044 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43045 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
43046 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
43047 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
43048 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43049 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43050 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43051 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
43052 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43053 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
43054 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43055 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43056 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43057 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
43058 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43059 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
43060 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43061 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43062 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43063 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43064 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43065 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43066 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
43067 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43068 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43069 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
43070 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43071 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43072 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43073 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
43074 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43075 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43076 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
43077 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43078 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43079 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
43080 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43081 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43082 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43083 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
43084 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43085 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43086 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43087 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
43088 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43089 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43090 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43091 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43092 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
43093 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
43094 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
43095 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
43096 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
43097 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
43098 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
43099 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
43100 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
43101 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
43102 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
43103 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
43104 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
43105 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
43106 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
43107 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
43108 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
43109 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
43110 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
43111 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
43112 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
43113 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
43114 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
43115 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
43116 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
43117 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
43118 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
43119 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
43120 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
43121 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
43122 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
43123 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
43124 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
43125 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
43126 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
43127 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
43128 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
43129 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
43130 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
43131 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
43132 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
43133 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
43134 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
43135 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
43136 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43137 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43138 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43139 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
43140 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
43141 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43142 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
43143 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43144 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
43145 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
43146 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
43147 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43148 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
43149 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
43150 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
43151 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
43152 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
43153 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43154 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
43155 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
43156 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
43157 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
43158 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
43159 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
43160 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
43161 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
43162 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
43163 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
43164 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43165 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43166 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43167 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43168 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
43169 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43170 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43171 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43172 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43173 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43174 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43175 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
43176 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
43177 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
43178 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
43179 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
43180 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
43181 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
43182 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
43183 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
43184 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
43185 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
43186 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
43187 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
43188 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
43189 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
43190 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
43191 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43192 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43193 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
43194 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
43195 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
43196 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
43197 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
43198 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43199 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
43200 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
43201 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43202 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43203 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
43204 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
43205 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
43206 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
43207 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
43208 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
43209 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
43210 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
43211 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
43212 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
43213 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
43214 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
43215 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
43216 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
43217 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
43218 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
43219 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
43220 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
43221 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
43222 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
43223 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
43224 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
43225 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
43226 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
43227 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
43228 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
43229 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
43230 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
43231 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
43232 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
43233 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43234 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43235 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
43236 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
43237 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
43238 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
43239 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
43240 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
43241 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
43242 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
43243 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
43244 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
43245 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
43246 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43247 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
43248 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
43249 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43250 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43251 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
43252 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
43253 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
43254 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
43255 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
43256 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
43257 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
43258 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
43259 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
43260 &384*A12*MB*MT*P1Q1**2/S**2+
43261 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
43262 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
43263 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
43264 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
43265 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
43266 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
43267 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
43268 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
43269 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
43270 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
43271 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
43272 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
43273 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
43274 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
43275 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
43276 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
43277 &384*A2**2*MB*MT*P2Q2**2/S**2+
43278 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
43279 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
43280 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
43281 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
43282 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
43283 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
43284 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
43285 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
43286 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
43287 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
43288 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
43289 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
43290 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
43291 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
43292 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
43293 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
43294 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
43295 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
43296 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
43297 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
43298 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
43299 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
43300 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
43301 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
43302 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
43303 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
43304 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
43305 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
43306 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
43307 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
43308 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
43309 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
43310 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
43311 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
43312 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
43313 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
43314 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
43315 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
43316 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43317 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
43318 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43319 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
43320 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
43321 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
43322 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
43323 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
43324 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
43325 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
43326 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
43327 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
43328 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
43329 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
43330 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
43331 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
43332 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
43333 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
43334 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
43335 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
43336 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43337 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43338 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
43339 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
43340 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
43341 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
43342 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
43343 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
43344 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
43345 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
43346 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
43347 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
43348 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
43349 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
43350 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
43351 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
43352 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
43353 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
43354 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
43355 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
43356 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
43357 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
43358 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
43359 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43360 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
43361 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
43362 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
43363 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
43364 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
43365 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
43366 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
43367 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
43368 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
43369 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
43370 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43371 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43372 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
43373 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43374 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
43375 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
43376 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
43377 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
43378 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
43379 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
43380 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
43381 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43382 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43383 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43384 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43385 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43386 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43387 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
43388 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
43389 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
43390 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
43391 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
43392 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
43393 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43394 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
43395 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
43396 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
43397 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
43398 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
43399 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
43400 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
43401 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
43402 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
43403 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
43404 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
43405 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
43406 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
43407 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
43408 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
43409 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
43410 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
43411 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
43412 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
43413 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
43414 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
43415 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
43416 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
43417 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43418 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43419 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
43420 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
43421 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
43422 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
43423 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
43424 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
43425 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43426 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
43427 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
43428 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
43429 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
43430 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43431 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43432 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
43433 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43434 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43435 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43436 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43437 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43438 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43439 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
43440 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43441 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
43442 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
43443 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
43444 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
43445 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
43446 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
43447 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
43448 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
43449 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
43450 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
43451 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
43452 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
43453 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43454 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43455 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
43456 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
43457 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
43458 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
43459 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
43460 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
43461 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
43462 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
43463 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
43464 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
43465 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
43466 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
43467 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
43468 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
43469 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
43470 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
43473 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
43474 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
43475 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
43476 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
43477 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
43478 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
43479 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
43480 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
43481 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
43482 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
43483 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
43484 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
43485 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
43486 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
43487 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
43488 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
43489 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
43491 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
43492 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
43493 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
43494 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
43495 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
43496 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
43497 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43498 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43499 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
43500 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
43501 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
43502 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
43503 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
43504 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
43505 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
43506 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
43507 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
43508 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
43509 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
43510 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
43511 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
43512 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
43513 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
43514 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
43515 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
43516 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
43517 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
43518 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
43519 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
43520 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
43521 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
43522 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
43523 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
43524 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
43525 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
43526 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
43527 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
43528 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
43529 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
43530 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
43531 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
43532 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43533 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43534 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43535 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
43536 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
43537 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
43538 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
43539 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
43540 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
43541 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
43542 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43543 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43544 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
43545 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43546 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43547 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43548 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43549 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43550 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43551 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43552 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
43553 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
43554 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
43555 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
43556 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
43557 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
43558 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
43559 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
43560 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
43561 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
43562 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
43563 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
43564 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
43565 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
43566 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
43567 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
43568 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
43569 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
43570 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
43571 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
43572 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
43573 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
43574 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
43575 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
43576 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43580 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
43581 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
43582 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
43583 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
43584 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
43585 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
43586 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
43587 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
43588 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
43589 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
43590 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
43591 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
43592 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
43593 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
43594 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
43595 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
43596 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
43597 V910=V910+96*A1*A2*P1P2*P2Q1/S-
43598 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
43599 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
43600 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
43601 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
43602 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
43604 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
43605 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
43606 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
43607 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
43608 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
43609 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
43610 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
43611 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
43612 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
43613 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
43614 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
43615 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
43616 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
43617 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
43618 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
43619 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
43620 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
43621 A910=A910+96*A1*A2*P1P2*P2Q1/S-
43622 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
43623 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
43624 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
43625 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
43626 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
43630 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
43633 C---------------------------------------------------------
43634 C 2) Q QBAR ->TBH^+
43635 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43637 C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
43638 C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
43639 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43640 IMPLICIT INTEGER(I-N)
43641 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43642 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43643 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43644 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43645 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43646 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43647 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
43648 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43649 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43650 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43651 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
43653 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43654 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43661 C COLLECTING THE RELEVANT OVERALL FACTORS:
43662 C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
43663 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
43664 C COUPLING CONSTANT (OVERALL NORMALIZATION)
43665 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
43666 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
43667 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
43668 C ALPHAS IS ALPHA_STRONG;
43669 C SW2 IS SIN(THETA_W)**2.
43672 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
43674 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
43675 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
43676 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
43678 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
43679 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
43681 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
43683 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
43684 S = 2*PYTBHS(Q1,Q2)
43691 C TOP WIDTH CALCULATION
43692 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
43693 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
43694 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
43695 A1INV= S -2*P1Q1 -2*P1Q2
43696 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
43697 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
43698 C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
43699 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
43700 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
43701 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
43702 C NOW COMES THE AMP**2:
43703 C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
43704 C THE EXPRESSIONS BELOW
43705 YY(1, 1) = -16*A**2*A2**2*MB*MT+
43706 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
43707 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
43708 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
43709 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
43710 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
43711 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
43712 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
43713 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
43714 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
43715 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
43716 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
43717 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
43718 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
43719 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
43720 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
43721 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
43722 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
43723 &32*A2**2*MB**2*P1P2*V**2/S+
43724 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
43725 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
43726 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
43727 YY(1, 1)=2*YY(1, 1)
43729 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
43730 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
43731 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
43732 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
43733 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
43734 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
43735 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
43736 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
43737 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
43738 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
43739 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
43740 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
43741 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
43742 &64*A**2*A1*A2*MB*MT*P1P2/S+
43743 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
43744 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
43745 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
43746 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
43747 &64*A**2*A1*A2*P1Q1*P2Q1/S-
43748 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
43749 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
43750 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
43751 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
43752 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
43753 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
43754 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
43755 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
43756 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
43757 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
43758 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
43759 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
43760 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
43761 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
43762 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
43763 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
43764 &32*A1*A2*P1P2*P1Q1*V**2/S+
43765 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
43766 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
43767 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
43768 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
43771 YY(2, 2) =-16*A**2*A12*MB*MT+
43772 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
43773 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
43774 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
43775 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
43776 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
43777 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
43778 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
43779 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
43780 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
43781 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
43782 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
43783 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
43784 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
43785 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
43786 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
43787 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
43788 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
43789 &32*A12*MT**2*P2Q2*V**2/S-
43790 &32*A12*P1Q2*P2Q2*V**2/S
43791 YY(2, 2)=2*YY(2, 2)
43793 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
43794 AMP2= FACT*PS*VTB**2*RES
43797 C=====================================================================
43798 C ************* FUNCTION SCALAR PRODUCTS *************************
43799 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
43800 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43801 IMPLICIT INTEGER(I-N)
43802 DIMENSION A(4),B(4)
43805 DUM=DUM-A(ID)*B(ID)
43811 C*********************************************************************
43814 C...Initializes supersymmetry: finds sparticle masses and
43815 C...branching ratios and stores this information.
43816 C...AUTHOR: STEPHEN MRENNA
43817 C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
43821 C...Double precision and integer declarations.
43822 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43823 IMPLICIT INTEGER(I-N)
43824 INTEGER PYK,PYCHGE,PYCOMP
43825 C...Parameter statement to help give large particle numbers.
43826 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
43827 &KEXCIT=4000000,KDIMEN=5000000)
43829 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43830 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43831 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43832 COMMON/PYDAT4/CHAF(500,2)
43834 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43835 COMMON/PYINT4/MWID(500),WIDS(500,5)
43836 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43837 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
43838 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
43839 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
43840 COMMON/PYHTRI/HHH(7)
43841 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
43842 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
43843 &/PYMSSM/,/PYMSRV/,/PYSSMT/
43845 C...Local variables.
43846 DOUBLE PRECISION ALFA,BETA
43847 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
43848 INTEGER I,J,J1,I1,K1
43849 INTEGER KC,LKNT,IDLAM(400,3)
43850 DOUBLE PRECISION XLAM(0:400)
43851 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
43852 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
43853 DOUBLE PRECISION DELM,XMDIF
43854 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
43855 DOUBLE PRECISION ARG,SGNMU,R
43858 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
43861 &1000001,2000001,1000002,2000002,1000003,2000003,
43862 &1000004,2000004,1000005,2000005,1000006,2000006,
43863 &1000011,2000011,1000012,2000012,1000013,2000013,
43864 &1000014,2000014,1000015,2000015,1000016,2000016,
43865 &1000021,1000022,1000023,1000025,1000035,1000024,
43866 &1000037,1000039, 25, 35, 36, 37,
43867 & 6, 24, 45, 46,1000045, 9*0/
43870 C...Automatically read QNUMBERS, MASS, and DECAY tables
43871 IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
43873 CALL PYSLHA(0,0,IFAIL)
43874 CALL PYSLHA(5,0,IFAIL)
43876 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
43878 C...Do nothing further if SUSY not requested
43880 IF(IMSSM.EQ.0) RETURN
43882 C...Save copy of MWID(KC) and MDCY(KC,1) values before
43883 C...they are set to zero for the LSP.
43890 MDCYSU(I)=MDCY(KC,1)
43894 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
43898 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
43900 MDCY(KC,1)=MDCYSU(I)
43904 C...First part of routine: set masses and couplings.
43906 C...Reset mixing values in sfermion sector to pure left/right.
43914 C...Add NMSSM states if NMSSM switched on, and change old names.
43915 IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
43916 C... Switch on NMSSM
43917 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
43947 DO 123 KCT=100,MSTU(6)
43948 IF(KCHG(KCT,4).GT.100) KCN=KCT
43954 C... Set stable for now
43960 CHAF(KCN,1)='~chi_50'
43964 C...Read spectrum from SLHA file.
43965 IF (IMSSM.EQ.11) THEN
43966 CALL PYSLHA(1,0,IFAIL)
43969 C...Common couplings.
43974 COS2B=COS(2D0*BETA)
43980 C...Define sparticle masses for a general MSSM simulation.
43981 IF(IMSSM.EQ.1) THEN
43982 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
43984 KC=PYCOMP(KSUSY1+I)
43985 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
43986 KC=PYCOMP(KSUSY2+I)
43987 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
43988 KC=PYCOMP(KSUSY1+I+1)
43989 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
43990 KC=PYCOMP(KSUSY2+I+1)
43991 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
43993 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
43994 IF(XARG.LT.0D0) THEN
43995 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
43996 & ' FROM THE SUM RULE. '
43997 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
44003 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
44004 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
44005 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
44006 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
44008 IF(IMSS(8).EQ.1) THEN
44013 C...Alternatively derive masses from SUGRA relations.
44014 ELSEIF(IMSSM.EQ.2) THEN
44018 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
44027 C...Add in extra D-term contributions.
44028 IF(IMSS(7).EQ.1) THEN
44033 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44034 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
44035 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
44036 WRITE(MSTU(11),*) 'C DX = ',DX
44037 WRITE(MSTU(11),*) 'C DY = ',DY
44038 WRITE(MSTU(11),*) 'C DS = ',DS
44039 WRITE(MSTU(11),*) 'C '
44040 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
44041 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
44042 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44043 DQ2=DY/6D0-DX/3D0-DS/3D0
44044 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
44045 DD2=DY/3D0+DX-2D0*DS/3D0
44046 DL2=-DY/2D0+DX-2D0*DS/3D0
44047 DE2=DY-DX/3D0-DS/3D0
44048 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
44049 DHD2=-DY/2D0-2D0*DX/3D0+DS
44050 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
44052 DMA2 = 2D0*DMU2+DHU2+DHD2
44054 KC=PYCOMP(KSUSY1+I)
44055 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44056 KC=PYCOMP(KSUSY2+I)
44057 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
44058 KC=PYCOMP(KSUSY1+I+1)
44059 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44060 KC=PYCOMP(KSUSY2+I+1)
44061 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
44064 KC=PYCOMP(KSUSY1+I)
44065 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44066 KC=PYCOMP(KSUSY2+I)
44067 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
44068 KC=PYCOMP(KSUSY1+I+1)
44069 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44071 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
44072 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
44075 SGNMU=SIGN(1D0,RMSS(4))
44076 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
44077 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
44078 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
44079 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
44080 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
44081 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
44082 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
44083 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
44084 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
44085 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
44086 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
44087 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
44088 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
44091 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
44092 RMSS(6)=SQRT(RMSS(6)**2+DL2)
44093 RMSS(7)=SQRT(RMSS(7)**2+DE2)
44094 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
44095 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
44096 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
44097 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
44098 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
44101 C...Fix the third generation sfermions.
44104 C...Fix the neutralino--chargino--gluino sector.
44107 C...Fix the Higgs sector.
44110 C...Choose the Gunion-Haber convention.
44114 C...Print information on mass parameters.
44115 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
44116 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44117 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
44118 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
44119 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
44120 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
44121 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
44122 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
44123 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
44124 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
44125 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44127 IF(IMSS(20).EQ.1) THEN
44128 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44129 WRITE(MSTU(11),*) ' DEBUG MODE '
44130 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
44131 & UMIX(2,1),UMIX(2,2)
44132 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
44133 & UMIXI(2,1),UMIXI(2,2)
44134 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
44135 & VMIX(2,1),VMIX(2,2)
44136 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
44137 & VMIXI(2,1),VMIXI(2,2)
44138 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
44139 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
44140 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
44141 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
44142 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
44143 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
44144 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
44145 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
44146 WRITE(MSTU(11),*) ' ALFA = ',ALFA
44147 WRITE(MSTU(11),*) ' BETA = ',BETA
44148 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
44149 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
44150 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44153 C...Set up the Higgs couplings - needed here since initialization
44154 C...in PYINRE did not yet occur when PYWIDT is called below.
44166 C2B=COSB**2-SINB**2
44167 C...tanb (used for H+)
44171 C...Coupling to d-type quarks
44172 PARU(161)=SINA/COSB
44173 C...Coupling to u-type quarks
44174 PARU(162)=-COSA/SINB
44175 C...Coupling to leptons
44176 PARU(163)=PARU(161)
44180 PARU(165)=PARU(164)
44183 C...Coupling to d-type quarks
44184 PARU(171)=-COSA/COSB
44185 C...Coupling to u-type quarks
44186 PARU(172)=-SINA/SINB
44187 C...Coupling to leptons
44188 PARU(173)=PARU(171)
44192 PARU(175)=PARU(174)
44194 IF(IMSS(4).GE.2) THEN
44195 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
44197 HHH(3)=HHH(3)+HHH(4)+HHH(5)
44198 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
44199 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
44200 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
44201 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
44205 IF(IMSS(4).GE.2) THEN
44206 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
44208 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
44209 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
44210 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
44211 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
44214 IF(IMSS(4).GE.2) THEN
44215 PARU(177)=COS(2D0*BE)*COS(BE+AL)
44217 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
44218 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
44219 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
44220 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
44223 IF(IMSS(4).GE.2) THEN
44224 PARU(178)=PARU(177)
44226 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
44229 C...Coupling to d-type quarks
44231 C...Coupling to u-type quarks
44232 PARU(182)=1D0/PARU(181)
44233 C...Coupling to leptons
44234 PARU(183)=PARU(181)
44237 C...Coupling to Z h
44238 PARU(186)=COS(BE-AL)
44239 C...Coupling to Z H
44240 PARU(187)=SIN(BE-AL)
44246 C...Coupling to W h
44247 PARU(195)=COS(BE-AL)
44249 C...Tell that all Higgs couplings have been set.
44252 C...Set R-Violating couplings.
44253 C...Set lambda couplings to common value or "natural values".
44254 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
44255 VIR3=1D0/(126D0)**3
44259 IF (IRI.NE.IRJ) THEN
44260 IF (IRI.LT.IRJ) THEN
44261 RVLAM(IRI,IRJ,IRK)=RMSS(51)
44262 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
44263 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
44264 & PMAS(9+2*IRK,1)*VIR3)
44266 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
44269 RVLAM(IRI,IRJ,IRK)=0D0
44275 C...Set lambda' couplings to common value or "natural values".
44276 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
44277 VIR3=1D0/(126D0)**3
44281 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
44282 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
44283 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
44284 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
44289 C...Set lambda'' couplings to common value or "natural values".
44290 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
44291 VIR3=1D0/(126D0)**3
44295 IF (IRJ.NE.IRK) THEN
44296 IF (IRJ.LT.IRK) THEN
44297 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
44298 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
44299 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
44300 & PMAS(2*IRK-1,1)*VIR3)
44302 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
44305 RVLAMB(IRI,IRJ,IRK) = 0D0
44312 C...Antisymmetrize couplings set by user
44313 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
44317 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
44318 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
44319 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
44321 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
44322 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
44323 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
44330 C...Write spectrum to SLHA file
44331 IF (IMSS(23).NE.0) THEN
44333 CALL PYSLHA(3,0,IFAIL)
44336 C...Second part of routine: set decay modes and branching ratios.
44338 C...Allow chi10 -> gravitino + gamma or not.
44339 KC=PYCOMP(KSUSY1+39)
44340 IF( IMSS(11) .NE. 0 ) THEN
44341 PMAS(KC,1)=RMSS(21)/1D9
44344 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
44345 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
44347 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
44348 & ' ALLOWING SUSY LLE DECAYS'
44349 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
44350 & ' ALLOWING SUSY LQD DECAYS'
44351 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
44352 & ' ALLOWING SUSY UDD DECAYS'
44353 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
44354 & ' --- Warning: R-Violating couplings possibly',
44355 & ' incompatible with proton decay'
44361 C...Loop over sparticle and Higgs species.
44362 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
44363 C...Find the LSP or NLSP for a gravitino LSP
44368 IF(KF.EQ.1000039) GOTO 300
44370 IF(PMAS(KC,1).LT.PMLSP) THEN
44376 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
44378 IF (KF.EQ.0) GOTO 370
44382 C...Check if there are any decays listed for this sparticle
44384 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
44386 CALL PYSLHA(2,KF,IFAIL)
44387 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
44388 ELSEIF (I.GE.37) THEN
44392 C...Sfermion decays.
44394 C...First check to see if sneutrino is lighter than chi10.
44395 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
44396 & PMAS(KC,1).LT.PMCHI1) THEN
44398 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
44402 ELSEIF(I.EQ.25) THEN
44403 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
44404 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
44406 C...Neutralino decays.
44407 ELSEIF(I.GE.26.AND.I.LE.29) THEN
44408 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
44409 C...chi10 stable or chi10 -> gravitino + gamma.
44410 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
44416 C...Chargino decays.
44417 ELSEIF(I.GE.30.AND.I.LE.31) THEN
44418 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
44420 C...Gravitino is stable.
44421 ELSEIF(I.EQ.32) THEN
44426 ELSEIF(I.GE.33.AND.I.LE.36) THEN
44427 C...Calculate decays to non-SUSY particles.
44428 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
44433 DO 330 I1=1,MDCY(KC,3)
44435 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
44436 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
44438 XLAM(0)=XLAM(0)+XLAM(I1)
44440 IDLAM(I1,J1)=KFDP(K1,J1)
44444 C...Add the decays to SUSY particles.
44445 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
44447 C...Zero the branching ratios for use in loop mode
44448 C...thanks to K. Matchev (FNAL)
44449 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
44453 C...Set stable particles.
44461 C...Store branching ratios in the standard tables.
44463 IDC=MDCY(KC,2)+MDCY(KC,3)-1
44469 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
44470 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
44471 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
44472 BRAT(IDC)=XLAM(IL)/XLAM(0)
44474 IF(MDME(IDC,1).GE.1) THEN
44475 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
44476 & PMAS(PYCOMP(KFDP(IDC,2)),1)
44477 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
44478 & PMAS(PYCOMP(KFDP(IDC,3)),1)
44481 IF(XMDIF.GE.0D0) THEN
44482 DELM=MIN(DELM,XMDIF)
44484 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
44485 WRITE(MSTU(11),*) ' KF = ',KF
44486 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
44490 ELSEIF(IDC.EQ.IDCSV) THEN
44491 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
44492 & 'channel not recognized:'
44493 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
44500 C...Store width, cutoff and lifetime.
44502 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
44503 PMAS(KC,3)=PMAS(KC,2)*10D0
44505 PMAS(KC,3)=0.95D0*DELM
44507 IF(PMAS(KC,2).NE.0D0) THEN
44508 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
44510 C...Write decays to SLHA file
44511 IF (IMSS(24).NE.0) THEN
44513 CALL PYSLHA(4,KF,IFAIL)
44521 C*********************************************************************
44524 C...Read/write spectrum or decay data from SLHA standard file(s).
44527 C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
44528 C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
44529 C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
44530 C... (KFORIG=0 : read all decay tables)
44531 C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
44532 C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
44533 C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
44534 C... (KFORIG=0 : read all MASS entries)
44536 C...Recent updates:
44537 C...17 Sep 2007: introduced /PYQNUM/ for QNUMBERS storage
44538 C... : Corrected QNUMBERS name-formation; root only until space
44539 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
44541 C...Double precision and integer declarations.
44542 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44543 IMPLICIT INTEGER(I-N)
44544 INTEGER PYK,PYCHGE,PYCOMP
44545 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44546 &KEXCIT=4000000,KDIMEN=5000000)
44548 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44549 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44550 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44551 COMMON/PYDAT4/CHAF(500,2)
44553 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44554 CHARACTER*40 ISAVER,VISAJE
44555 COMMON/PYINT4/MWID(500),WIDS(500,5)
44556 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
44558 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44559 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
44560 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
44561 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44562 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
44564 C...Local arrays, character variables and data.
44565 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
44566 & AU(3,3),AD(3,3),AE(3,3)
44567 COMMON/PYLH3C/CPRO(2),CVER(2)
44568 C...The common block of new states (QNUMBERS / PARTICLE)
44569 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
44570 C...- NQNUM : Number of QNUMBERS blocks that have been read in
44571 C...- KQNUM(I,0) : KF of new state
44572 C...- KQNUM(I,1) : 3 times electric charge
44573 C...- KQNUM(I,2) : Number of spin states: (2S + 1)
44574 C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
44575 C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
44576 C...- KQNUM(I,5:9) : space available for further quantum numbers
44577 DIMENSION MMOD(100),MSPC(100),KFDEC(100)
44578 SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
44579 C...MMOD: flags to set for each block read in.
44580 C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
44581 C...MSPC: Flags to set for each block read in.
44582 C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
44583 C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
44584 C...11: AD 12: AE 13: YU 14: YD 15: YE
44585 C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
44586 CHARACTER CPRO*12,CVER*12,CHNLIN*6
44587 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
44588 CHARACTER CHINL*120,CHKF*9,CHTMP*16
44591 C...Date of last Change
44592 PARAMETER (DOC='05 Nov 2007')
44593 C...Local arrays and initial values
44594 DIMENSION IDC(5),KFSUSY(50)
44603 &1000001,1000002,1000003,1000004,1000005,1000006,
44604 &2000001,2000002,2000003,2000004,2000005,2000006,
44605 &1000011,1000012,1000013,1000014,1000015,1000016,
44606 &2000011,2000012,2000013,2000014,2000015,2000016,
44607 &1000021,1000022,1000023,1000025,1000035,1000024,
44608 &1000037,1000039, 25, 35, 36, 37,
44609 & 6, 24, 45, 46,1000045, 9*0/
44611 RMFUN(IP)=PMAS(PYCOMP(IP),1)
44613 C...Shorthand for spectrum and decay table unit numbers
44617 C...Default for LHEF input: read header information
44618 IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
44619 IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
44620 IF (IMSS21.EQ.MSTP(161)) MLHEF=1
44621 IF (IMSS22.EQ.MSTP(161)) MLHEFD=1
44624 IF (NHELLO.EQ.0) THEN
44625 IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
44626 WRITE(MSTU(11),5000) DOC
44631 C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
44634 IF (MUPDA.EQ.2) LFN=IMSS22
44635 IF (MUPDA.EQ.3) LFN=IMSS(23)
44636 IF (MUPDA.EQ.4) LFN=IMSS(24)
44637 C...Flag that we have not yet found whatever we were asked to find.
44640 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
44642 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
44646 C...If reading LHEF header, start by rewinding file
44647 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
44649 C...If told to read spectrum, first zero all previous information.
44650 IF (MUPDA.EQ.1) THEN
44651 C...Zero all block read flags
44656 C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
44658 KC=PYCOMP(KFSUSY(ISUSY))
44661 C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
44669 IF (J.LE.2.AND.L.LE.2) THEN
44676 C...Zero signed masses.
44678 IF (J.LE.2) SMW(J)=0D0
44681 C...If reading decays, reset PYTHIA decay counters.
44682 ELSEIF (MUPDA.EQ.2) THEN
44683 C...Check if DECAY for this KF already read
44684 IF (KFORIG.NE.0) THEN
44685 DO 140 IDEC=1,NDECAY
44686 IF (KFORIG.EQ.KFDEC(IDEC)) THEN
44695 DO 150 KC=1,MSTU(6)
44696 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
44697 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
44699 ELSEIF (MUPDA.EQ.5) THEN
44700 C...Zero block read flags
44707 C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
44708 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
44709 C...Initialize program and version strings
44710 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
44715 C...Initialize read loop
44719 C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
44721 READ(LFN,'(A120)',END=400) CHINL
44722 C...Count which line number we're at.
44724 WRITE(CHNLIN,'(I6)') NLINE
44726 C...Skip comment and empty lines without processing.
44727 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
44729 C...We assume all upper case below. Rewrite CHINL to all upper case.
44733 IF (CHINL(INL:INL).NE.'#') THEN
44735 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
44737 C...Extra safety. Chek for sensible input on line
44738 IF (IGOOD.EQ.0) THEN
44740 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
44743 IF (INL.LT.120) GOTO 180
44745 IF (IGOOD.EQ.0) GOTO 170
44747 C...Exit when first <event> tag reached in LHEF file
44749 IF (CHINL(I1:I1+5).EQ.'<EVENT') THEN
44755 C...Check for BLOCK begin statement (spectrum).
44756 IF (CHINL(1:5).EQ.'BLOCK') THEN
44758 READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
44759 C...Check if another of this type of block was already read.
44760 C...(logarithmic interpolation not yet implemented, so duplicates always
44762 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
44763 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
44764 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
44765 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
44766 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
44767 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
44768 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
44769 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
44770 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
44771 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
44772 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
44773 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
44774 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
44775 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
44776 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
44777 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
44778 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
44779 C...Check for new particles
44780 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
44782 MSPC(19)=MSPC(19)+1
44784 READ(CHBLCK(9:60),*) KFQ
44787 IF (KQNUM(MQ,0).EQ.KFQ) THEN
44792 IF (NHELLO.EQ.0) THEN
44793 WRITE(MSTU(11),5000) DOC
44796 WRITE(MSTU(11),'(A,I9,A,F12.3)')
44797 & ' * (PYSLHA:) Reading in '//CHBLCK(1:8)//
44801 MSPC(19)=MSPC(19)+1
44803 C...Only read in new codes (also OK to overwrite if KF > 3000000)
44804 IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
44806 DO 230 KCT=100,MSTU(6)
44807 IF(KCHG(KCT,4).GT.100) KCQ=KCT
44813 C...First write PDG code as name
44815 WRITE(CHTMP,'(A)') CHTMP(2:10)
44816 C...Then look for real name
44819 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
44821 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
44824 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
44825 IF (IEND.LT.59) THEN
44826 READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
44827 IF (CHDUM.NE.' ') CHTMP=CHDUM
44829 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
44831 C...Set stable for now
44839 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
44840 & CHAF(KCQ,1), '. Entry ignored.'
44844 C...Finalize this line and read next.
44846 C...Check for DECAY begin statement (decays).
44847 ELSEIF (CHINL(1:3).EQ.'DEC') THEN
44851 C...Read KF code and WIDTH
44853 READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
44858 C...If this is not the KF we're looking for...
44859 IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
44860 C...Set block skip flag and read next line.
44864 C...Check whether decay table for this particle already read in
44865 DO 280 IDECAY=1,NDECAY
44866 IF (KFDEC(IDECAY).EQ.KF) THEN
44873 C...Determine PYTHIA KC code of particle
44879 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
44883 IF (KCREP.NE.0) THEN
44884 C...Particle is already known. Don't do anything yet.
44886 C... Add new particle. Actually, this should not happen.
44887 C... New particles should be added already when reading the spectrum
44888 C... information, so go under previously stable category.
44893 IF (WIDTH.LE.0D0) THEN
44894 C...Stable (i.e. LSP)
44896 & '* (PYSLHA:) Reading in SLHA stable particle ',
44897 & 'KF =',KF,': ',CHAF(KCREP,1)(1:16)
44898 IF (WIDTH.LT.0D0) THEN
44899 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
44906 C...Ignore any decay lines that may be present for this KF
44913 C...Finalize and start reading in decay modes.
44915 ELSEIF (MOD(MERR,10).GE.6) THEN
44916 C...If ignore block flag set, skip directly to next line.
44921 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
44922 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
44924 READ(CHINL,*) INDX, IVAL
44925 IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
44926 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
44927 IF (INDX.EQ.3) KCHG(KCQ,2)=0
44928 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
44929 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
44930 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
44931 IF (INDX.EQ.4) THEN
44933 IF (IVAL.EQ.1) THEN
44935 IF (CHTMP.EQ.' ') THEN
44936 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
44937 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
44941 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
44942 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
44943 CHTMP(ILAST:ILAST)='-'
44945 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
44954 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
44955 C...MASS: Mass spectrum
44956 IF (CHBLCK(1:4).EQ.'MASS') THEN
44957 READ(CHINL,*) KF, VAL
44960 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
44961 C...Read in masses for anything
44964 C...Don't read in masses for the light quarks
44965 IF (IABS(KF).LE.3) THEN
44966 WRITE(MSTU(11),'(A,I9,A,F12.3)')
44967 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
44973 PMAS(KC,1) = ABS(VAL)
44974 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
44975 WRITE(MSTU(11),'(A,I9,A,F12.3)')
44976 & ' * (PYSLHA:) Reading in MASS entry for KF =',
44977 & KF, ', pole mass =', VAL
44981 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
44982 IF (KF.EQ.1000022) SMZ(1)=VAL
44983 IF (KF.EQ.1000023) SMZ(2)=VAL
44984 IF (KF.EQ.1000025) SMZ(3)=VAL
44985 IF (KF.EQ.1000035) SMZ(4)=VAL
44986 IF (KF.EQ.1000024) SMW(1)=VAL
44987 IF (KF.EQ.1000037) SMW(2)=VAL
44989 ELSEIF (MUPDA.EQ.5) THEN
44992 C... MODSEL: Model selection and global switches
44993 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
44994 READ(CHINL,*) INDX, IVAL
44995 IF (INDX.LE.200.AND.INDX.GT.0) THEN
44996 IF (IMSS(1).EQ.0) IMSS(1)=11
44999 IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
45000 C... Switch on NMSSM
45001 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
45002 IMSS(13)=MAX(1,IMSS(13))
45003 C... Add NMSSM states if not already done
45033 DO 310 KCT=100,MSTU(6)
45034 IF(KCHG(KCT,4).GT.100) KCN=KCT
45040 C... Set stable for now
45046 CHAF(KCN,1)='~chi_50'
45052 ELSEIF (MUPDA.EQ.5) THEN
45053 C...If MUPDA = 5, skip all except MASS, return if MODSEL
45055 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
45056 & CHBLCK(1:8).EQ.'PARTICLE') THEN
45057 C...Don't print a warning for QNUMBERS when reading spectrum
45059 C...MINPAR: Minimal model parameters
45060 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
45061 READ(CHINL,*) INDX, VAL
45062 IF (INDX.LE.100.AND.INDX.GT.0) THEN
45068 IF (MMOD(3).NE.0) THEN
45070 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
45074 IF (INDX.EQ.3) RMSS(5)=VAL
45075 C...EXTPAR: non-minimal model parameters.
45076 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
45077 IF (MMOD(1).NE.0) THEN
45078 READ(CHINL,*) INDX, VAL
45079 IF (INDX.LE.200.AND.INDX.GT.0) THEN
45087 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
45091 IF (INDX.EQ.25) RMSS(5)=VAL
45092 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
45093 READ(CHINL,*) INDX, VAL
45094 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
45096 ELSEIF (INDX.EQ.4) THEN
45097 PMAS(PYCOMP(23),1)=VAL
45098 ELSEIF (INDX.EQ.6) THEN
45099 PMAS(PYCOMP(6),1)=VAL
45101 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
45102 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
45103 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
45105 C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
45107 IF (CHBLCK(5:6).EQ.'IM') IM=1
45108 320 READ(CHINL,*) INDX1, INDX2, VAL
45109 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
45110 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
45111 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
45113 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
45114 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
45115 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
45117 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
45118 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
45119 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
45121 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
45122 $ .CHBLCK(1:4).EQ.'STAU') THEN
45123 IF (CHBLCK(1:4).EQ.'STOP') THEN
45126 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
45129 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
45133 C...Set SFMIX element
45134 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
45135 MSPC(ISPC)=MSPC(ISPC)+1
45137 C...Running parameters
45138 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
45139 READ(CHBLCK(8:25),*,ERR=620) Q
45140 READ(CHINL,*) INDX, VAL
45142 IF (INDX.EQ.1) THEN
45148 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
45149 READ(CHINL,*,ERR=630) VAL
45151 MSPC(17)=MSPC(17)+1
45152 C...Higgs parameters set manually or with FeynHiggs.
45153 IMSS(4)=MAX(2,IMSS(4))
45154 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
45155 & .CHBLCK(1:2).EQ.'AE') THEN
45156 READ(CHBLCK(9:26),*,ERR=620) Q
45157 READ(CHINL,*) INDX1, INDX2, VAL
45158 IF (CHBLCK(2:2).EQ.'U') THEN
45159 AU(INDX1,INDX2)=VAL
45160 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
45161 MSPC(11)=MSPC(11)+1
45162 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
45163 AD(INDX1,INDX2)=VAL
45164 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
45165 MSPC(10)=MSPC(10)+1
45166 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
45167 AE(INDX1,INDX2)=VAL
45168 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
45169 MSPC(12)=MSPC(12)+1
45173 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
45174 IF (MSPC(18).EQ.0) THEN
45175 READ(CHBLCK(9:25),*,ERR=620) Q
45178 READ(CHINL,*) INDX, VAL
45180 MSPC(18)=MSPC(18)+1
45181 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
45183 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
45184 & .CHBLCK(1:2).EQ.'YE') THEN
45186 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
45187 READ(CHINL(1:6),*) INDX
45191 IF (CHINL(IT:IT).EQ.' ') GOTO 330
45192 C...Don't read index
45193 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
45197 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
45198 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
45200 C... Set unrecognized block flag.
45205 C...Read in decay information
45206 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
45207 C...Read new decay chanel
45208 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
45210 C...Read in branching ratio and number of daughters for this mode.
45211 READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
45212 READ(CHINL(4:50),*,ERR=600) DUM, NDA
45214 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
45215 & '(PYSLHA:) Decay data arrays full by KF ='
45217 C...If first decay channel, set decays start point in decay table
45218 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
45219 IF (KFORIG.EQ.0) WRITE(MSTU(11),*)
45220 & '* (PYSLHA:) Reading in SLHA decay table for ',
45221 & 'KF =',KF,': ',CHAF(KCREP,1)(1:16)
45222 C...Set particle parameters (mass set when reading BLOCK MASS above)
45224 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
45226 & '* Note: the Pythia gg->h/H/A cross section'//
45227 & ' is proportional to the h/H/A->gg width'
45230 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
45235 C...Add to list of DECAY blocks currently read
45241 C... Count up number of decay modes for this particle
45242 MDCY(KC,3)=MDCY(KC,3)+1
45243 C... Read in decay daughters.
45244 READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
45245 C... Flip sign if reading antiparticle decays (if antipartner exists)
45247 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
45248 & IDC(IDA)=MPSIGN*IDC(IDA)
45250 C...Switch on decay channel, with products ordered in decreasing ABS(KF)
45252 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
45253 BRSUM=BRSUM+ABS(BRAT(NDC))
45254 BRAT(NDC)=ABS(BRAT(NDC))
45257 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
45259 IDC(IDA)=IDC(IDA+1)
45264 IF (IFLIP.GT.0) GOTO 350
45265 C...Treat as ordinary decay, no fancy stuff.
45268 IF (IDA.LE.NDA) THEN
45269 KFDP(NDC,IDA)=IDC(IDA)
45274 C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
45275 C & (KFDP(NDC,J),J=1,NDA)
45277 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line'//
45282 ELSEIF(CHINL(1:1).EQ.'+') THEN
45284 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
45291 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
45292 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
45295 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
45296 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
45297 & CHBLCK(1:MIN(INL,40))//'... on line'//CHNLIN
45298 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
45299 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
45300 & //CHBLCK(1:INL)//'... on line'//CHNLIN
45301 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
45302 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
45303 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
45304 & //'... on line'//CHNLIN
45305 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
45306 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
45307 & /CHBLCK(1:INL)//'... on line'//CHNLIN
45308 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
45311 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
45312 & CHTMP(1:9)//' on line'//CHNLIN
45314 C...Iterate read loop
45317 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
45318 & ', ignoring subsequent lines.'
45319 WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
45322 C...End of read loop
45324 C...Set flag that KC codes have been rearranged.
45328 C...Perform possible tests that new information is consistent.
45329 IF (MUPDA.EQ.1) THEN
45332 C...Check Z and top masses
45333 IF (ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0) THEN
45334 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45335 CALL PYERRM(19,'(PYSLHA:) note Z boson mass, M ='//CHTMP)
45337 IF (ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0) THEN
45338 WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
45339 CALL PYERRM(19,'(PYSLHA:) note top quark mass, M ='
45345 C...Don't complain about right-handed neutrinos
45346 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
45348 C...Only check gravitino in GMSB scenarios
45349 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
45351 IF (PMAS(KC,1).EQ.0D0) THEN
45354 & ,'(PYSLHA:) No mass information found for KF ='
45358 C...Check mixing matrices (MSSM only)
45359 IF (IMSS(13).EQ.0) THEN
45360 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
45361 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
45362 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
45363 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
45364 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
45365 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
45366 IF (MSPC(5).NE.4) CALL PYERRM(9
45367 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
45368 IF (MSPC(6).NE.4) CALL PYERRM(9
45369 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
45370 IF (MSPC(7).NE.4) CALL PYERRM(9
45371 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
45372 IF (MSPC(8).LT.1) CALL PYERRM(9
45373 & ,'(PYSLHA:) Too few elements in HMIX')
45374 IF (MSPC(10).EQ.0) CALL PYERRM(9
45375 & ,'(PYSLHA:) Missing A_b trilinear coupling')
45376 IF (MSPC(11).EQ.0) CALL PYERRM(9
45377 & ,'(PYSLHA:) Missing A_t trilinear coupling')
45378 IF (MSPC(12).EQ.0) CALL PYERRM(9
45379 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
45380 IF (MSPC(17).LT.1) CALL PYERRM(9
45381 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
45383 C...Check wavefunction normalizations.
45386 IF (MSPC(ISPC).EQ.4) THEN
45388 IF (ISPC.EQ.7) KFSM=15
45389 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
45391 IF (ABS(1D0-CHECK).GT.1D-3) THEN
45394 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
45399 C...Neutralinos + charginos
45408 CN1=CN1+ZMIX(J,L)**2
45409 CN2=CN2+ZMIX(L,J)**2
45410 IF (J.LE.2.AND.L.LE.2) THEN
45411 CU1=CU1+UMIX(J,L)**2
45412 CU2=CU2+UMIX(L,J)**2
45413 CV1=CV1+VMIX(J,L)**2
45414 CV2=CV2+VMIX(L,J)**2
45417 C...NMIX normalization
45418 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
45419 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
45421 & '(PYSLHA:) NMIX: Inconsistent normalization.')
45422 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
45424 C...UMIX, VMIX normalizations
45425 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
45427 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
45429 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
45430 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
45433 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
45435 & '(PYSLHA:) VMIX: Inconsistent normalization.')
45436 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
45442 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
45443 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
45444 & '* PYSLHA: No spectrum inconsistencies were found.'
45446 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
45447 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
45448 & ,' Warning: one or more (serious)'//
45449 & ' inconsistencies were found in the spectrum !'
45450 & ,' Read the error messages above and check your'//
45453 C...Increase precision in Higgs sector using FeynHiggs
45454 IF (IMSS(4).EQ.3) THEN
45455 C...FeynHiggs needs MSOFT.
45457 IF (MSPC(18).EQ.0) THEN
45458 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
45459 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
45460 & ' Cannot call FeynHiggs.'
45463 WRITE(MSTU(11),'(1x,/1x,A/)')
45464 & '* (PYSLHA:) Now calling FeynHiggs.'
45466 IF (IERR.NE.0) IMSS(4)=2
45469 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
45471 IF (KFORIG.NE.0) IBEG=NDECAY
45472 DO 490 IDECAY=IBEG,NDECAY
45475 WRITE(CHKF,8300) KF
45476 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
45477 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
45478 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
45479 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
45483 DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45484 IF(MDME(IDA,2).GT.80) GOTO 460
45486 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
45490 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
45492 ELSEIF(PYCOMP(KP).EQ.0) THEN
45497 PMS=PMS-PMAS(KPC,1)
45498 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
45502 IF(KQ.NE.0) MERR=MAX(2,MERR)
45503 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
45505 IF(MERR.EQ.3) CALL PYERRM(17,
45506 & '(PYSLHA:) Unknown particle code in decay of KF ='
45508 IF(MERR.EQ.2) CALL PYERRM(17,
45509 & '(PYSLHA:) Charge not conserved in decay of KF ='
45511 IF(MERR.EQ.1) CALL PYERRM(7,
45512 & '(PYSLHA:) Kinematically unallowed decay of KF ='
45514 BRSUM=BRSUM+BRAT(IDA)
45515 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
45517 C...Check branching ratio sum.
45518 IF (BROPN.LE.0D0) THEN
45519 C...If zero, set stable.
45520 WRITE(CHTMP,8500) BROPN
45522 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
45523 & CHTMP(9:16)//'. Changed to stable.')
45526 C...If BR's > 1, rescale.
45527 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
45528 WRITE(CHTMP,8500) BRSUM
45529 IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
45530 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
45531 & ' ; sum was'//CHTMP(9:16)//'.')
45533 DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45534 IF(MDME(IDA,2).GT.80) GOTO 470
45535 BRAT(IDA)=FAC*BRAT(IDA)
45537 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
45538 C...If BR's < 1, insert dummy mode for proper cross section rescaling.
45539 WRITE(CHTMP,8500) BRSUM
45540 IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
45541 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
45542 & CHTMP(9:16)//'. Dummy mode will be inserted.')
45543 C...Move table and insert dummy mode
45544 DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45546 BRAT(NDC)=BRAT(IDA)
45547 KFDP(NDC,1)=KFDP(IDA,1)
45548 KFDP(NDC,2)=KFDP(IDA,2)
45549 KFDP(NDC,3)=KFDP(IDA,3)
45550 KFDP(NDC,4)=KFDP(IDA,4)
45551 KFDP(NDC,5)=KFDP(IDA,5)
45552 MDME(NDC,1)=MDME(IDA,1)
45555 BRAT(NDC)=1D0-BRSUM
45564 MDCY(KC,3)=MDCY(KC,3)+1
45565 MDCY(KC,2)=NDC-MDCY(KC,3)+1
45571 C...WRITE SPECTRUM ON SLHA FILE
45572 ELSEIF(MUPDA.EQ.3) THEN
45573 C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
45574 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
45579 PARMIN(4)=SIGN(1D0,RMSS(4))
45583 WRITE(LFN,7000) 'SLHA MSSM spectrum'
45584 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
45586 WRITE(LFN,7010) 'MODSEL', 'Model selection'
45587 WRITE(LFN,7110) 1, MODSEL(1)
45588 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
45589 IF (MODSEL(1).EQ.1) THEN
45590 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
45591 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
45592 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
45593 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
45594 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
45595 ELSEIF(MODSEL(2).EQ.2) THEN
45596 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
45597 WRITE(LFN,7210) 2, PARMIN(2), 'M'
45598 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
45599 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
45600 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
45601 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
45603 WRITE(LFN,7000) ' '
45604 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
45608 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
45610 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
45611 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
45612 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
45613 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
45614 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
45615 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
45616 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
45618 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
45622 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
45623 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
45624 WRITE(LFN,7210) 1, RMSS(4),'mu'
45625 WRITE(LFN,7010) 'ALPHA',' '
45626 WRITE(LFN,7210) 1, RMSS(18), 'alpha'
45627 WRITE(LFN,7020) 'AU',RMSUSY
45628 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
45629 WRITE(LFN,7020) 'AD',RMSUSY
45630 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
45631 WRITE(LFN,7020) 'AE',RMSUSY
45632 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
45633 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
45634 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
45635 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
45636 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
45637 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
45638 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
45639 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
45640 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
45641 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
45642 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
45643 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
45644 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
45645 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
45646 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
45647 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
45648 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
45651 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
45654 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
45657 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
45660 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
45663 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
45666 WRITE(LFN,7010) 'SPINFO'
45667 IF (IMSS(1).EQ.2) THEN
45670 ELSEIF (IMSS(1).EQ.12) THEN
45673 CVER(1)=ISAVER(1:12)
45675 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
45676 WRITE(LFN,7310) 2, CVER(1), 'Version number'
45679 C...Print user information about spectrum
45680 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
45681 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
45682 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
45683 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
45684 IF (MUPDA.EQ.1) THEN
45685 WRITE(MSTU(11),5020) LFN
45687 WRITE(MSTU(11),5010) LFN
45690 WRITE(MSTU(11),5400)
45691 WRITE(MSTU(11),5500) 'Pole masses'
45692 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
45693 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
45694 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
45695 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
45696 IF (IMSS(13).EQ.0) THEN
45697 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
45698 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
45699 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
45700 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
45701 & CHAF(37,1), ' ', ' ',' ',' ',
45702 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
45703 ELSEIF (IMSS(13).EQ.1) THEN
45712 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
45713 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
45714 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
45715 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
45716 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
45717 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
45718 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
45719 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
45720 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
45723 WRITE(MSTU(11),5400)
45724 WRITE(MSTU(11),5500) 'Mixing structure'
45725 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
45726 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
45727 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
45728 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
45729 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
45730 & ),(SFMIX(15,J),J=3,4)
45731 WRITE(MSTU(11),5400)
45732 WRITE(MSTU(11),5500) 'Couplings'
45733 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
45734 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
45735 WRITE(MSTU(11),5400)
45736 WRITE(MSTU(11),6500)
45740 C...Only rewind when reading
45741 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
45745 C...Serious error catching
45746 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
45747 write(*,*) CHINL(1:80)
45749 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
45750 WRITE(*,*) CHINL(1:72)
45752 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
45753 WRITE(*,*) CHINL(1:80)
45755 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
45756 WRITE(*,*) CHINL(1:80)
45757 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
45759 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
45760 WRITE(*,*) CHINL(1:80)
45766 C...Formats for user information printout.
45767 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.10: SUSY/BSM SPECTRUM '
45768 & ,'INTERFACE',1x,17('*')/1x,'*',2x
45769 & ,'PYSLHA: Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
45770 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
45771 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
45772 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
45773 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
45774 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
45775 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
45776 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
45777 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
45778 & ,'----------------')
45779 5400 FORMAT(1x,'*',1x,A)
45780 5500 FORMAT(1x,'*',1x,A,':')
45781 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
45782 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
45783 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
45784 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
45785 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
45786 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
45787 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
45788 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
45789 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
45790 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
45791 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
45792 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
45793 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
45794 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
45795 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
45796 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
45797 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
45798 & ,1x,F6.3,1x),'|')
45799 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
45800 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
45801 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
45802 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
45803 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
45804 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
45805 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
45806 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
45807 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
45808 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
45809 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
45810 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
45811 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
45812 & ,'A_tau = ',F8.2)
45813 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
45815 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
45817 C...Format to use for comments
45818 7000 FORMAT('# ',A)
45819 C...Format to use for block statements
45820 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
45821 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
45823 7110 FORMAT(1x,I4,1x,I4,3x,'#')
45824 C...Non-Indexed Double
45825 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
45827 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
45828 C...Long Indexed Double (PDG + double)
45829 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
45830 C...Indexed Char(12)
45831 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
45833 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
45835 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
45836 C...Write Decay Table
45837 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
45838 7510 FORMAT(4x,I5,1x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),
45844 C*********************************************************************
45847 C...Uses approximate analytical formulae to determine the full set of
45848 C...MSSM parameters from SUGRA input.
45849 C...See M. Drees and S.P. Martin, hep-ph/9504124
45853 C...Double precision and integer declarations.
45854 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45855 IMPLICIT INTEGER(I-N)
45856 INTEGER PYK,PYCHGE,PYCOMP
45857 C...Parameter statement to help give large particle numbers.
45858 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45859 &KEXCIT=4000000,KDIMEN=5000000)
45861 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45862 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45863 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45864 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
45866 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
45867 &' not intended for serious physics studies'
45880 C...Temporary sign change for AT. Others unchanged.
45884 SINB=TANB/SQRT(TANB**2+1D0)
45887 DTERM=XMZ2*COS(2D0*BETA)
45888 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
45889 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
45892 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
45893 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
45894 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
45895 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
45897 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
45898 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
45899 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
45900 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
45902 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
45903 IF(XARG.LT.0D0) THEN
45904 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
45905 & ' FROM THE SUM RULE. '
45906 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
45912 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
45913 PMAS(PYCOMP(KSUSY2+I),1)=XMER
45914 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
45915 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
45917 RMT=PYMRUN(6,PMAS(6,1)**2)
45918 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
45919 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
45920 RMB=PYMRUN(5,PMAS(6,1)**2)
45921 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
45922 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
45923 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
45924 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
45927 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
45928 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
45929 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
45930 XMU=SIGN(SQRT(XMU2),RMSS(4))
45932 IF(XMA2.GT.0D0) THEN
45933 RMSS(19)=SQRT(XMA2)
45935 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
45938 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
45939 IF(ARG.GT.0D0) THEN
45942 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
45945 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
45946 IF(ARG.GT.0D0) THEN
45949 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
45952 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
45953 IF(ARG.GT.0D0) THEN
45956 RMSS(10)=-SQRT(-ARG)
45958 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
45959 IF(ARG.GT.0D0) THEN
45962 RMSS(12)=-SQRT(-ARG)
45964 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
45965 IF(ARG.GT.0D0) THEN
45968 RMSS(11)=-SQRT(-ARG)
45974 C*********************************************************************
45977 C...Interface to ISASUSY version 7.71.
45978 C...Warning: this interface should not be used with earlier versions
45979 C...of ISASUSY, since common block incompatibilities may then arise.
45980 C...Calls SUGRA (in ISAJET) to perform RGE evolution.
45981 C...Then converts to Gunion-Haber conventions.
45984 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45986 INTEGER PYK,PYCHGE,PYCOMP
45987 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45988 &KEXCIT=4000000,KDIMEN=5000000)
45992 PARAMETER (DOC='01 May 2006')
45994 C...ISASUGRA Input:
45995 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
45996 C...XISAIN contains the MSSMi inputs in natural order.
45997 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
45999 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
46001 C...ISASUGRA Output
46002 CHARACTER*40 ISAVER,VISAJE
46004 COMMON /SSPAR/ SUPER(72)
46005 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
46006 $FBGUT,FTAGUT,FNGUT
46007 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
46008 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46009 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46010 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
46011 $VUMT,VDMT,ASMTP,ASMSS,M3Q
46012 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46013 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46014 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
46015 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
46017 SAVE /SUGMG/,/SSPAR/
46018 C SUPER: Filled by ISASUGRA.
46019 C SUPER(1) = mass of ~g
46020 C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
46021 C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
46022 C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
46024 C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
46025 C SUPER(29) = Higgsino mass = - mu
46026 C SUPER(30) = ratio v2/v1 of vev's
46027 C SUPER(31:34) = Signed neutralino masses
46028 C SUPER(35:50) = Neutralino mixing matrix
46029 C SUPER(51:52) = Signed chargino masses
46030 C SUPER(53:54) = Chargino left, right mixing angles
46031 C SUPER(55:58) = mass of h0, H0, A0, H+
46032 C SUPER(59) = Higgs mixing angle alpha
46033 C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
46034 C SUPER(66) = Gravitino mass
46035 C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
46036 C SUPER(70) = b-Yukawa at mA scale (not used)
46037 C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
46038 C GSS: Filled by ISASUGRA
46039 C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
46040 C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
46041 C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
46042 C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
46043 C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
46044 C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
46045 C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
46046 C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
46047 C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
46048 C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
46049 C GSS(31) = log(vuq)
46050 C MSS: Filled by ISASUGRA
46051 C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
46052 C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
46053 C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
46054 C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
46055 C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
46056 C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
46057 C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
46058 C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
46059 C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
46060 C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
46061 C MSS(31) = ha0 MSS(32) = h+
46062 C Unification, filled by ISASUGRA if applicable.
46063 C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
46065 C...SPYTHIA Input/Output
46067 DOUBLE PRECISION RMSS
46068 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46069 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46070 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46071 C...SLHA Input/Output
46072 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
46073 & AU(3,3),AD(3,3),AE(3,3)
46074 C...PYTHIA common blocks
46075 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46076 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
46077 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46079 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
46080 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
46083 CHARACTER*20 CHMOD(5)
46086 COMMON /SUGNU/ XNUSUG(18)
46090 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
46091 & 'truly unified SUGRA', 'non-minimal GMSB'/
46093 C...Start by checking for incompatibilities/inconsistencies:
46095 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
46096 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
46097 & ,' option not used by PYSUGI'
46100 C...ISAJET works with REAL numbers.
46101 MZERO=REAL(RMSS(8))
46103 AZERO=REAL(RMSS(16))
46105 SGNMU=REAL(RMSS(4))
46106 MTOP=REAL(PMAS(6,1))
46108 IF (IMSS(1).EQ.12) THEN
46111 ELSEIF(IMSS(1).EQ.13) THEN
46112 C...Read from isajet par file in IMSS(20)
46114 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
46116 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
46119 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
46120 CMrenna change to allow any susy model
46121 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
46122 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
46123 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
46124 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
46125 & ' gauge couplings:'
46126 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
46128 IF (IMODEL.EQ.4) THEN
46132 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
46133 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
46134 & //' sgn(mu), M_t:'
46135 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
46136 IF (IMODEL.EQ.3) THEN
46138 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
46139 & //' 0 to continue:'
46140 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
46141 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
46142 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
46143 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
46144 & //' generation masses'
46146 & ' NUSUG5 = GUT scale 3rd generation masses'
46148 IF (INUSUG.EQ.0) THEN
46150 ELSEIF (INUSUG.EQ.1) THEN
46151 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
46152 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
46153 IF (XNUSUG(3).LE.0.) THEN
46154 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
46157 ELSEIF (INUSUG.EQ.2) THEN
46158 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
46159 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
46160 ELSEIF (INUSUG.EQ.3) THEN
46161 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
46162 READ(LFN,*) XNUSUG(7),XNUSUG(8)
46163 ELSEIF (INUSUG.EQ.4) THEN
46164 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
46165 & //' M(ur), M(el), M(er):'
46166 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
46167 & XNUSUG(10),XNUSUG(9)
46168 ELSEIF (INUSUG.EQ.5) THEN
46169 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
46170 & //' M(Ll), M(Lr):'
46171 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
46172 & XNUSUG(15),XNUSUG(14)
46176 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
46178 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
46179 & ,' sgn(mu), M_t, C_gv:'
46180 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
46183 C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
46185 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
46186 IF (IMODEL.EQ.5) THEN
46188 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
46189 & ,' masses at M_mes'
46190 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
46191 & ,' shifts at M_mes'
46192 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
46194 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
46196 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
46198 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
46199 $ XGMIN(13),XGMIN(14)
46202 WRITE(MSTU(11),*) 'Invalid model choice.'
46210 C TANB=REAL(RMSS(5))
46211 C SGNMU=REAL(RMSS(4))
46214 C...Initialize MSSM parameter array
46215 130 DO 140 IPAR=1,72
46219 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
46220 C...Check whether ISASUSY thought the model was OK.
46221 IF (NOGOOD.NE.0) THEN
46222 IF (NOGOOD.EQ.1) CALL PYERRM(26
46223 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
46224 IF (NOGOOD.EQ.2) CALL PYERRM(26
46225 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
46226 IF (NOGOOD.EQ.3) CALL PYERRM(26
46227 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
46228 IF (NOGOOD.EQ.4) CALL PYERRM(26
46229 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
46230 IF (NOGOOD.EQ.7) CALL PYERRM(26
46231 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
46232 IF (NOGOOD.EQ.8) CALL PYERRM(26
46233 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
46234 C...Give warning, but don't stop, if LSP not ~chi_10.
46235 IF (NOGOOD.EQ.5) CALL PYERRM(16
46236 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
46238 C...Warn about possible GUT scale tachyons.
46239 IF (ITACHY.NE.0) CALL PYERRM(16,
46240 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
46241 C...Finalize spectrum (last iteration)
46242 C...(Thanks to A. Raklev for pointing this out.)
46243 C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
46244 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
46245 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
46246 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
46247 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
46248 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
46252 RMSS(1)=dble(GSS(7))
46253 RMSS(2)=dble(GSS(8))
46254 RMSS(3)=dble(GSS(9))
46255 RMSOFT(1)=dble(GSS(7))
46256 RMSOFT(2)=dble(GSS(8))
46257 RMSOFT(3)=dble(GSS(9))
46258 C...Mu = - Higgsino mass.
46261 C...Slepton and squark masses. 2 first generations.
46262 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
46263 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
46264 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
46265 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
46266 C...Third generation.
46267 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
46272 C...SLHA: store exact soft spectrum in RMSOFT
46273 RMSOFT(31)=SUPER(18)
46274 RMSOFT(32)=SUPER(20)
46275 RMSOFT(33)=SUPER(22)
46276 RMSOFT(34)=SUPER(19)
46277 RMSOFT(35)=SUPER(21)
46278 RMSOFT(36)=SUPER(23)
46279 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
46280 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
46281 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
46282 RMSOFT(44)=SUPER(3)
46283 RMSOFT(45)=SUPER(9)
46284 RMSOFT(46)=SUPER(15)
46285 RMSOFT(47)=SUPER(5)
46286 RMSOFT(48)=SUPER(7)
46287 RMSOFT(49)=SUPER(11)
46289 C...~b, ~t, and ~tau trilinear couplings and mixing angles.
46296 C...SLHA trilinears
46307 C...Higgs mixing angle alpha (Gunion-Haber convention).
46308 RMSS(18)=-SUPER(59)
46311 C...GUT scale coupling
46313 C...Gravitino mass (for future compatibility)
46314 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
46316 C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
46318 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
46319 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
46320 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
46321 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
46323 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
46324 C...Squarks and Sleptons.
46327 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
46328 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
46329 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
46330 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
46331 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
46332 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
46333 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
46334 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
46335 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
46337 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
46338 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
46339 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
46341 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
46342 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
46343 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
46344 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
46345 C...Signed masses (extra minus from going to G-H convention).
46351 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
46352 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
46353 C...Signed masses (extra minus from going to G-H convention).
46357 C... Neutralino Mixing.
46359 ZMIX(IN,1)= SUPER(38+4*(IN-1))
46360 ZMIX(IN,2)= SUPER(37+4*(IN-1))
46361 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
46362 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
46364 C...Chargino Mixing (PYTHIA same angle as HERWIG).
46367 IF (SUPER(53).GT.0) THX=-1D0
46368 IF (SUPER(54).GT.0) THY=-1D0
46369 UMIX(1,1) = -SIN(SUPER(53))
46370 UMIX(1,2) = -COS(SUPER(53))
46371 UMIX(2,1) = -THX*COS(SUPER(53))
46372 UMIX(2,2) = THX*SIN(SUPER(53))
46373 VMIX(1,1) = -SIN(SUPER(54))
46374 VMIX(1,2) = -COS(SUPER(54))
46375 VMIX(2,1) = -THY*COS(SUPER(54))
46376 VMIX(2,2) = THY*SIN(SUPER(54))
46377 C...Sfermion mixing (PYTHIA same angle as ISAJET)
46378 SFMIX(5,1)=COS(SUPER(63))
46379 SFMIX(5,2)=SIN(SUPER(63))
46380 SFMIX(5,3)=-SIN(SUPER(63))
46381 SFMIX(5,4)=COS(SUPER(63))
46382 SFMIX(6,1)=COS(SUPER(61))
46383 SFMIX(6,2)=SIN(SUPER(61))
46384 SFMIX(6,3)=-SIN(SUPER(61))
46385 SFMIX(6,4)=COS(SUPER(61))
46386 SFMIX(15,1)=COS(SUPER(65))
46387 SFMIX(15,2)=SIN(SUPER(65))
46388 SFMIX(15,3)=-SIN(SUPER(65))
46389 SFMIX(15,4)=COS(SUPER(65))
46391 IF (MSTP(122).NE.0) THEN
46392 C...Print a few lines to make the user know what's happening
46394 WRITE(MSTU(11),5000) DOC, ISAVER
46395 WRITE(MSTU(11),5100)
46396 IF (IMODEL.EQ.1) THEN
46397 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
46399 WRITE(MSTU(11),5300)
46401 WRITE(MSTU(11),5500) 'Pole masses'
46402 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
46403 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
46404 & ,(SUPER(IP),IP=19,25,2)
46405 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
46407 WRITE(MSTU(11),5400)
46408 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
46409 WRITE(MSTU(11),5400)
46410 WRITE(MSTU(11),5500) 'EW scale mixing structure'
46411 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
46412 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
46413 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
46414 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
46415 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
46416 & ),(SFMIX(15,J),J=3,4)
46417 WRITE(MSTU(11),5400)
46418 WRITE(MSTU(11),6450) RMSS(18)
46419 WRITE(MSTU(11),5400)
46420 WRITE(MSTU(11),5500) 'Couplings'
46421 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
46422 WRITE(MSTU(11),5400)
46425 C...Call FeynHiggs to improve Higgs sector if requested
46426 IF (IMSS(4).EQ.3) THEN
46427 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
46428 & ' (PYSUGI:) Now calling FeynHiggs.'
46430 IF (IERR.EQ.0) THEN
46432 IF (MSTP(122).NE.0) THEN
46433 WRITE(MSTU(11),5400)
46434 WRITE(MSTU(11),5500)
46435 & 'Corrected Higgs masses and mixing'
46436 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
46438 WRITE(MSTU(11),6450) RMSS(18)
46439 WRITE(MSTU(11),5400)
46444 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
46446 C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
46447 C...output by ISASUSY.
46448 IMSS(4)=MAX(2,IMSS(4))
46450 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
46451 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
46452 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
46453 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
46454 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
46455 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
46456 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
46457 & ,'----------------')
46458 5400 FORMAT(1x,'*',1x,A)
46459 5500 FORMAT(1x,'*',1x,A,':')
46460 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
46461 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
46462 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
46463 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
46464 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
46466 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
46467 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
46468 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
46470 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
46471 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
46472 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
46473 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
46474 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
46475 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
46476 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
46477 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
46478 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
46479 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
46480 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
46481 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
46482 & ,1x,F6.3,1x),'|')
46483 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
46484 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
46485 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
46486 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
46487 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
46488 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
46489 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
46490 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
46491 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
46492 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
46493 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
46494 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
46495 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
46496 & ,4x,'Alpha_GUT = ',F8.2)
46497 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
46498 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
46503 C*********************************************************************
46506 C...Interface to FeynHiggs for MSSM Higgs sector.
46507 C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
46510 SUBROUTINE PYFEYN(IERR)
46512 C...Double precision and integer declarations.
46513 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46514 IMPLICIT INTEGER(I-N)
46515 INTEGER PYK,PYCHGE,PYCOMP
46517 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46518 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46520 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46521 C...FeynHiggs variables
46522 DOUBLE PRECISION RMHIGG(4)
46523 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
46524 DOUBLE COMPLEX DMU,
46525 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
46527 C...SLHA Common Block
46528 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
46529 & AU(3,3),AD(3,3),AE(3,3)
46530 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
46533 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
46534 IF (IERR.NE.0) THEN
46535 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
46536 & //'Will not use FeynHiggs for this run.')
46574 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
46575 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
46576 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
46577 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
46578 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
46579 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
46580 IF (IERR.NE.0) THEN
46581 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
46582 & //' Will not use FeynHiggs for this run.')
46585 C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
46587 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
46588 IF (IERR.NE.0) THEN
46589 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
46590 & 'GSCORR. Will not use FeynHiggs for this run.')
46593 ALPHA = ASIN(DBLE(SAEFF))
46595 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
46596 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
46597 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
46598 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
46600 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
46601 & 1.15D0*PMAS(25,1)) THEN
46602 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
46603 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
46604 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
46607 PMAS(25,1)=RMHIGG(1)
46608 PMAS(35,1)=RMHIGG(2)
46609 PMAS(36,1)=RMHIGG(3)
46610 PMAS(37,1)=RMHIGG(4)
46615 C*********************************************************************
46618 C...Determines the running mass of Squarks.
46620 FUNCTION PYRNMQ(ID,DTERM)
46622 C...Double precision and integer declarations.
46623 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46624 IMPLICIT INTEGER(I-N)
46625 INTEGER PYK,PYCHGE,PYCOMP
46627 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46630 C...Local variables.
46631 DOUBLE PRECISION PI,R
46632 DOUBLE PRECISION TOL
46633 DOUBLE PRECISION CI(3)
46635 DOUBLE PRECISION PYALPS
46637 DATA PI,R/3.141592654D0,.61803399D0/
46638 DATA CI/0.47D0,0.07D0,0.02D0/
46642 AG=(0.71D0)**2/4D0/PI
46649 AS=PYALPS(XM02+6D0*XMG2)
46650 CG=8D0/9D0*((AS/AG)**2-1D0)
46651 BX=XM02+(CA+CG)*XMG2+DTERM
46652 AX=MIN(50D0**2,0.5D0*BX)
46653 CX=MAX(2000D0**2,2D0*BX)
46657 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
46665 CG=8D0/9D0*((AS1/AG)**2-1D0)
46666 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
46668 CG=8D0/9D0*((AS2/AG)**2-1D0)
46669 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
46670 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
46677 CG=8D0/9D0*((AS2/AG)**2-1D0)
46678 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
46685 CG=8D0/9D0*((AS1/AG)**2-1D0)
46686 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
46701 C*********************************************************************
46704 C...Calculates the mass eigenstates of the third generation sfermions.
46705 C...Created: 5-31-96
46709 C...Double precision and integer declarations.
46710 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46711 IMPLICIT INTEGER(I-N)
46712 INTEGER PYK,PYCHGE,PYCOMP
46713 C...Parameter statement to help give large particle numbers.
46714 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46715 &KEXCIT=4000000,KDIMEN=5000000)
46717 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46718 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46719 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46720 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46721 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46722 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
46724 C...Local variables.
46725 DOUBLE PRECISION BETA
46726 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
46727 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
46728 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
46729 DOUBLE PRECISION ATR,AMQR,AMQL
46730 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
46731 INTEGER IF,I,J,II,JJ,IT,L
46745 COS2B=COS(2D0*BETA)
46747 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
46757 XMQL2=CTT2*XM12+STT2*XM22
46758 XMQR2=STT2*XM12+CTT2*XM22
46759 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
46760 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
46762 C......SUBTRACT OUT D-TERM AND FERMION MASS
46763 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
46764 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
46765 IF(XMQL2.GE.0D0) THEN
46766 RMSS(10)=SQRT(XMQL2)
46768 RMSS(10)=-SQRT(-XMQL2)
46770 IF(XMQR2.GE.0D0) THEN
46771 RMSS(12)=SQRT(XMQR2)
46773 RMSS(12)=-SQRT(-XMQR2)
46776 C SAME FOR BOTTOM SQUARK
46782 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
46783 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
46784 IF(ABS(CTT).GE..9999D0) THEN
46787 ELSEIF(ABS(CTT).LE.1D-4) THEN
46791 XM12=(XMQL2-STT2*XM22)/CTT2
46792 XMQR2=STT2*XM12+CTT2*XM22
46793 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
46796 C......SUBTRACT OUT D-TERM AND FERMION MASS
46797 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
46798 IF(XMQR2.GE.0D0) THEN
46799 RMSS(11)=SQRT(XMQR2)
46801 RMSS(11)=-SQRT(-XMQR2)
46803 C SAME FOR TAU SLEPTON
46810 XMQL2=CTT2*XM12+STT2*XM22
46811 XMQR2=STT2*XM12+CTT2*XM22
46814 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
46816 C......SUBTRACT OUT D-TERM AND FERMION MASS
46817 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
46818 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
46819 IF(XMQL2.GE.0D0) THEN
46820 RMSS(13)=SQRT(XMQL2)
46822 RMSS(13)=-SQRT(-XMQL2)
46824 IF(XMQR2.GE.0D0) THEN
46825 RMSS(14)=SQRT(XMQR2)
46827 RMSS(14)=-SQRT(-XMQR2)
46832 IF(AMQL.LT.0D0) THEN
46839 IF(AMQR.LT.0D0) THEN
46845 XMF=PYMRUN(IF,PMAS(6,1)**2)
46847 AM2(1,1)=XMQL2+XMF2
46848 AM2(2,2)=XMQR2+XMF2
46849 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
46852 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
46853 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
46854 AM2(1,2)=XMF*(ATR+XMU*TANB)
46855 ELSEIF(L.EQ.2) THEN
46856 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
46857 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
46858 AM2(1,2)=XMF*(ATR+XMU/TANB)
46859 ELSEIF(L.EQ.3) THEN
46860 IF(IMSS(8).EQ.1) THEN
46861 AM2(1,1)=RMSS(6)**2
46862 AM2(2,2)=RMSS(7)**2
46867 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
46868 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
46869 AM2(1,2)=XMF*(ATR+XMU*TANB)
46874 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
46875 IF(DETM.LT.0D0) THEN
46876 WRITE(MSTU(11),*) ID2(L),DETM,AM2
46877 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
46879 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
46880 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
46884 IF(XMF22-XMF12.GT.0D0) THEN
46885 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
46887 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
46888 & AM2(1,2)/(XMF22-XMF12))
46904 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
46910 IF(DI(1,1).GT.DI(2,2)) THEN
46911 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
46912 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
46913 WRITE(MSTU(11),*) AM2
46914 WRITE(MSTU(11),*) DI
46915 WRITE(MSTU(11),*) RT
46926 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
46927 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
46928 & ' OFF DIAGONAL ELEMENTS '
46929 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
46930 WRITE(MSTU(11),*) DI
46931 WRITE(MSTU(11),*) ' ROTATION = ',RT
46933 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
46934 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
46935 & ' NEGATIVE MASSES '
46938 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
46939 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
46940 SFMIX(IF,1)=RT(1,1)
46941 SFMIX(IF,2)=RT(1,2)
46942 SFMIX(IF,3)=RT(2,1)
46943 SFMIX(IF,4)=RT(2,2)
46946 C.....TAU SNEUTRINO MASS...L=3
46948 XARG=AM2(1,1)+XMW2*COS2B
46949 IF(XARG.LT.0D0) THEN
46950 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
46951 & ' FROM THE SUM RULE. '
46952 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
46955 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
46960 C*********************************************************************
46963 C...Finds the mass eigenstates and mixing matrices for neutralinos
46968 C...Double precision and integer declarations.
46969 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46970 IMPLICIT INTEGER(I-N)
46972 C...Parameter statement to help give large particle numbers.
46973 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46974 &KEXCIT=4000000,KDIMEN=5000000)
46976 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46977 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46978 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46979 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46980 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46981 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
46983 C...Local variables.
46984 DOUBLE PRECISION XMW,XMZ,XM(4)
46985 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
46986 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
46987 DOUBLE PRECISION COSW,SINW
46988 DOUBLE PRECISION XMU
46989 DOUBLE PRECISION TANB,COSB,SINB
46990 DOUBLE PRECISION XM1,XM2,XM3,BETA
46991 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
46992 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
46993 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
46994 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
46995 DOUBLE PRECISION PYALPS,PYALEM
46996 DOUBLE PRECISION PYRNM3
46997 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
46998 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
46999 DATA KFNCHI/1000022,1000023,1000025,1000035/
47002 IF(IMSS(1).EQ.2) THEN
47005 C...M1, M2, AND M3 ARE INDEPENDENT
47010 ELSEIF(IOPT.GE.1) THEN
47014 A1=AEM/(1D0-PARU(102))
47017 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
47019 XM2=XM1*A2/A1*3D0/5D0
47021 ELSEIF(IOPT.EQ.3) THEN
47022 XM1=XM2*5D0/3D0*A1/A2
47027 IF(XM3.LE.0D0) THEN
47028 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
47034 IF(IMSS(3).EQ.1) THEN
47035 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
47040 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
47041 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
47042 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
47048 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
47049 RM2=PMAS(I,1)**2/XM3**2
47050 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
47051 IF(ARG.GE.0D0) THEN
47052 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
47054 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
47059 ELSEIF(X0.EQ.0D0) THEN
47063 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
47064 & 0.5D0*X0**2*LOG(AX0)
47065 BT=(-1D0-2D0*X0)/4D0
47070 ELSEIF(X1.EQ.0D0) THEN
47074 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
47075 & X1**2*LOG(AX1)+AT
47076 BT=(-1D0-2D0*X1)/4D0+BT
47080 X0=0.5D0*(1D0+RM2-RM1)
47081 Y0=-0.5D0*SQRT(-ARG)
47082 AMGX0=SQRT(X0**2+Y0**2)
47083 AM1X0=SQRT((1D0-X0)**2+Y0**2)
47084 ARGX0=ATAN2(-X0,-Y0)
47085 AR1X0=ATAN2(1D0-X0,Y0)
47090 ARGX1=ATAN2(-X1,-Y1)
47091 AR1X1=ATAN2(1D0-X1,Y1)
47092 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
47093 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
47094 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
47095 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
47096 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
47097 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
47102 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
47103 & /(2D0*PARU(2))*(15D0+AQ))
47106 C...NEUTRALINO MASSES
47112 XMZ=PMAS(23,1)/100D0
47113 XMW=PMAS(24,1)/100D0
47115 SINW=SQRT(PARU(102))
47116 COSW=SQRT(1D0-PARU(102))
47127 C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
47128 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
47129 AR(1,1) = XM1*COS(RMSS(30))
47130 AI(1,1) = XM1*SIN(RMSS(30))
47131 AR(2,2) = XM2*COS(RMSS(31))
47132 AI(2,2) = XM2*SIN(RMSS(31))
47137 AR(1,3) = -XMZ*SINW*COSB
47139 AR(1,4) = XMZ*SINW*SINB
47141 AR(2,3) = XMZ*COSW*COSB
47143 AR(2,4) = -XMZ*COSW*SINB
47145 AR(3,4) = -XMU*COS(RMSS(33))
47146 AI(3,4) = -XMU*SIN(RMSS(33))
47147 AR(4,3) = -XMU*COS(RMSS(33))
47148 AI(4,3) = -XMU*SIN(RMSS(33))
47149 C CALL PYEIG4(AR,WR,ZR)
47150 CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
47151 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
47152 & 'PROBLEM WITH PYEICG IN PYINOM ')
47160 IF(XM(K).LT.XM(J)) THEN
47178 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
47181 S=S+ZR(J,K)**2+ZI(J,K)**2
47184 ZMIX(I,J)=ZR(J,K)/SQRT(S)
47185 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
47186 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
47187 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
47191 C...CHARGINO MASSES
47192 C.....Find eigenvectors of X X^*
47201 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
47202 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
47203 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
47204 &XMU*COS(RMSS(33))*SINB)
47205 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
47206 &XMU*SIN(RMSS(33))*SINB)
47207 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
47208 &XMU*COS(RMSS(33))*SINB)
47209 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
47210 &XMU*SIN(RMSS(33))*SINB)
47211 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
47212 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
47213 & 'PROBLEM WITH PYEICG IN PYINOM ')
47216 IF(WR(2).LT.WR(1)) THEN
47224 SMW(I)=SQRT(WR(K))*100D0
47227 S=S+ZR(J,K)**2+ZI(J,K)**2
47230 UMIX(I,J)=ZR(J,K)/SQRT(S)
47231 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
47232 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
47233 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
47236 C...Force chargino mass > neutralino mass
47238 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
47239 CALL PYERRM(18,'(PYINOM:) '//
47240 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
47241 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
47244 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
47245 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
47247 C.....Find eigenvectors of X^* X
47258 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
47259 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
47260 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
47261 &XMU*COS(RMSS(33))*COSB)
47262 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
47263 &XMU*SIN(RMSS(33))*COSB)
47264 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
47265 &XMU*COS(RMSS(33))*COSB)
47266 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
47267 &XMU*SIN(RMSS(33))*COSB)
47268 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
47269 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
47270 & 'PROBLEM WITH PYEICG IN PYINOM ')
47273 IF(WR(2).LT.WR(1)) THEN
47283 S=S+ZR(J,K)**2+ZI(J,K)**2
47284 SIMAG=SIMAG+ZI(J,K)**2
47287 VMIX(I,J)=ZR(J,K)/SQRT(S)
47288 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
47289 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
47290 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
47294 C.....Simplify if no phases
47295 IF(SIMAG.LT.1D-6) THEN
47296 AR(1,1) = XM2*COS(RMSS(31))
47297 AR(2,2) = XMU*COS(RMSS(33))
47298 AR(1,2) = SQRT(2D0)*XMW*SINB
47299 AR(2,1) = SQRT(2D0)*XMW*COSB
47312 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
47317 VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
47318 VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
47319 VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
47320 VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
47321 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
47322 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
47323 ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
47327 C.....Must deal with phases
47329 CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
47330 CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
47331 CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
47332 CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
47338 CAI(I,J)=CMPLX(0D0,0D0)
47346 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
47347 & CMPLX(VMIX(J,L),VMIXI(J,L))
47353 CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
47354 CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
47357 VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
47358 VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
47361 VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
47362 VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
47365 VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
47366 VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
47369 VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
47370 VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
47371 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
47372 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
47373 ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
47374 & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
47382 C*********************************************************************
47385 C...Calculates the running of M3, the SU(3) gluino mass parameter.
47387 FUNCTION PYRNM3(RGUT)
47389 C...Double precision and integer declarations.
47390 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47391 IMPLICIT INTEGER(I-N)
47392 INTEGER PYK,PYCHGE,PYCOMP
47394 C...Local variables.
47396 DOUBLE PRECISION TOL
47398 DOUBLE PRECISION PYALPS
47400 DATA R/0.61803399D0/
47404 BX=RGUT*PYALPS(RGUT**2)
47405 AX=MIN(50D0,BX*0.5D0)
47406 CX=MAX(2000D0,2D0*BX)
47410 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
47418 F1=ABS(X1-RGUT*AS1)
47420 F2=ABS(X2-RGUT*AS2)
47421 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
47428 F2=ABS(X2-RGUT*AS2)
47435 F1=ABS(X1-RGUT*AS1)
47450 C*********************************************************************
47453 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
47454 C...Specific application: mixing in neutralino sector.
47456 SUBROUTINE PYEIG4(A,W,Z)
47458 C...Double precision and integer declarations.
47459 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47460 IMPLICIT INTEGER(I-N)
47461 INTEGER PYK,PYCHGE,PYCOMP
47463 C...Arrays: in call and local.
47464 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
47466 C...Coefficients of fourth-degree equation from matrix.
47467 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
47468 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
47472 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
47481 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
47482 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
47483 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
47484 B0=B0+(-1D0)**(I+1)*A(1,I)*(
47485 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
47486 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
47487 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
47490 C...Coefficients of third-degree equation needed for
47491 C...separation into two second-degree equations.
47492 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
47495 C0=-B1**2-B0*B3**2+4D0*B0*B2
47496 CQ=C1/3D0-C2**2/9D0
47497 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
47500 C...Cases with one or three real roots.
47501 IF(CQR.GE.0D0) THEN
47502 S1=(CR+SQRT(CQR))**(1D0/3D0)
47503 S2=(CR-SQRT(CQR))**(1D0/3D0)
47507 THE=ACOS(CR/SABS**3)/3D0
47512 C...Find and solve two second-degree equations.
47513 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
47514 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
47515 Q1=U/2D0+SQRT(U**2/4D0-B0)
47516 Q2=U/2D0-SQRT(U**2/4D0-B0)
47517 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
47522 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
47523 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
47524 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
47525 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
47527 C...Order eigenvalues in asceding mass.
47530 DO 130 I2=I1-1,1,-1
47531 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
47537 C...Find equation system for eigenvectors.
47540 D(J1,J1)=A(J1,J1)-W(I)
47547 C...Find largest element in matrix.
47551 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
47554 DAMAX=ABS(D(J1,J2))
47558 C...Subtract others by multiple of row selected above.
47560 DO 210 J3=JA+1,JA+3
47562 RL=D(J1,JB)/D(JA,JB)
47564 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
47565 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
47568 DAMAX=ABS(D(J1,J2))
47572 C...Do one more subtraction of a row.
47574 DO 230 J3=JC+1,JC+3
47576 IF(J1.EQ.JA) GOTO 230
47577 RL=D(J1,JD)/D(JC,JD)
47579 IF(J2.EQ.JB) GOTO 220
47580 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
47581 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
47583 DAMAX=ABS(D(J1,J2))
47587 C...Construct unnormalized eigenvector.
47589 JF2=JD+2-4*((JD+1)/4)
47590 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
47591 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
47594 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
47595 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
47598 C...Normalize and fill in final array.
47599 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
47600 SGN=(-1D0)**INT(PYR(0)+0.5D0)
47609 C*********************************************************************
47612 C...Determines the Higgs boson mass spectrum using several inputs.
47614 SUBROUTINE PYHGGM(ALPHA)
47616 C...Double precision and integer declarations.
47617 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47618 IMPLICIT INTEGER(I-N)
47619 INTEGER PYK,PYCHGE,PYCOMP
47620 C...Parameter statement to help give large particle numbers.
47621 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47622 &KEXCIT=4000000,KDIMEN=5000000)
47624 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47625 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47626 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47627 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47628 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
47630 C...Local variables.
47631 DOUBLE PRECISION AT,AB,XMU,TANB
47632 DOUBLE PRECISION ALPHA
47634 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
47635 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
47636 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
47637 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
47640 IF(IHOPT.EQ.2) THEN
47656 DMC=PMAS(PYCOMP(KSUSY1+37),1)
47663 IF(IHOPT.EQ.0) THEN
47664 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
47665 & DMHCH,DSA,DCA,DTANBA)
47666 ELSEIF(IHOPT.EQ.1) THEN
47667 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
47668 & DMHCH,DSA,DCA,DTANBA)
47669 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
47670 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
47671 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
47677 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
47678 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
47679 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
47680 & PMAS(PYCOMP(1000006),1),DSTOP2
47682 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
47683 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
47684 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
47685 & PMAS(PYCOMP(2000006),1),DSTOP1
47687 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
47688 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
47689 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
47690 & PMAS(PYCOMP(1000005),1),DSBOT2
47692 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
47693 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
47694 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
47695 & PMAS(PYCOMP(2000005),1),DSBOT1
47698 ELSEIF (IHOPT.EQ.3) THEN
47699 c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
47700 C...Currently only available for SLHA spectrum read-in.
47701 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
47702 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
47703 & //' spectrum, change IMSS(1) or IMSS(4) option.')
47719 C*********************************************************************
47722 C...This routine computes the renormalization group improved
47723 C...values of Higgs masses and couplings in the MSSM.
47725 C...Program based on the work by M. Carena, J.R. Espinosa,
47726 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
47728 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
47729 C...All masses in GeV units. MA is the CP-odd Higgs mass,
47730 C...MTOP is the physical top mass, MQ and MUR are the soft
47731 C...supersymmetry breaking mass parameters of left handed
47732 C...and right handed stops respectively, AU and AD are the
47733 C...stop and sbottom trilinear soft breaking terms,
47734 C...respectively, and MU is the supersymmetric
47735 C...Higgs mass parameter. We use the conventions from
47736 C...the physics report of Haber and Kane: left right
47737 C...stop mixing term proportional to (AU - MU/TANB)
47738 C...We use as input TANB defined at the scale MTOP
47740 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
47741 C...where MH and HM are the lightest and heaviest CP-even
47742 C...Higgs masses, MHCH is the charged Higgs mass and
47743 C...ALPHA is the Higgs mixing angle
47744 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
47746 C...Range of validity:
47747 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
47748 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
47749 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
47750 C...are the sbottom mass eigenvalues, respectively. This
47751 C...range automatically excludes the existence of tachyons.
47752 C...For the charged Higgs mass computation, the method is
47754 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
47755 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
47756 C...where M_SUSY**2 is the average of the squared stop mass
47757 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
47758 C...masses have been assumed to be of order of the stop ones
47759 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
47761 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
47762 &XMHCH,SA,CA,TANBA)
47764 C...Double precision and integer declarations.
47765 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47766 IMPLICIT INTEGER(I-N)
47767 INTEGER PYK,PYCHGE,PYCOMP
47768 C...Parameter statement to help give large particle numbers.
47769 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47770 &KEXCIT=4000000,KDIMEN=5000000)
47772 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47774 COMMON/PYHTRI/HHH(7)
47775 SAVE /PYDAT1/,/PYDAT2/
47777 C...Local variables.
47778 DOUBLE PRECISION PYALEM,PYALPS
47779 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
47780 DOUBLE PRECISION XMHCH,SA,CA
47781 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
47782 DOUBLE PRECISION Q02
47783 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
47784 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
47785 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
47786 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
47787 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
47788 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
47789 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
47790 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
47795 ALP1=AEM/(1D0-PARU(102))
47808 C...MBOTTOM(MTOP) = 3. GEV
47809 XMB = PYMRUN(5,XMTOP**2)
47810 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
47811 &LOG(XMTOP**2/XMZ**2))
47813 C...RMTOP= RUNNING TOP QUARK MASS
47814 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
47815 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
47816 T = LOG(XMS**2/XMTOP**2)
47817 SINB = TANB/((1D0 + TANB**2)**0.5D0)
47819 C...IF(MA.LE.XMTOP) TANBA = TANBT
47821 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
47822 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
47823 &LOG(XMA**2/XMTOP**2))
47825 SINBT = TANBT/SQRT(1D0 + TANBT**2)
47826 COSBT = 1D0/SQRT(1D0 + TANBT**2)
47827 C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
47828 G1 = SQRT(ALP1*4D0*PI)
47829 G2 = SQRT(ALP2*4D0*PI)
47830 G3 = SQRT(ALP3*4D0*PI)
47845 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
47846 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
47847 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
47848 &+ 3D0*(AU + AD)**2/XMS2)/6D0
47849 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
47850 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
47851 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
47852 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
47853 &- 16D0*G3**2) *T/16D0/PI2)
47854 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
47855 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
47856 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
47857 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
47858 &- 16D0*G3**2) *T/16D0/PI2)
47859 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
47860 &(HU2 + HD2)*T/16D0/PI2)
47861 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
47862 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
47863 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
47864 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
47865 &- 16D0*G3**2) *T/16D0/PI2)
47866 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
47867 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
47868 &- 16D0*G3**2) *T/16D0/PI2)
47869 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
47870 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
47871 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
47872 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
47874 &(1+ (6D0*HU2 -2D0* HD2
47875 &- 16D0*G3**2) *T/16D0/PI2)
47876 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
47878 &(1+ (6D0*HD2 -2D0* HU2/2D0
47879 &- 16D0*G3**2) *T/16D0/PI2)
47880 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
47881 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
47882 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
47883 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
47884 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
47885 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47886 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
47887 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47888 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
47889 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47890 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
47891 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47899 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
47900 &2D0* XLAM6*SINBT*COSBT
47901 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
47903 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
47905 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
47906 &2D0* XLAM6* COSBT*SINBT
47907 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
47908 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
47909 &((XLAM1* COSBT**2 +2D0*
47910 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
47911 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
47913 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
47914 &+ XLAM4) + XLAM6*COSBT**2
47915 &+ XLAM7* SINBT**2))
47917 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
47918 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
47921 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
47922 XMHCH = SQRT(XMHCH2)
47924 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
47925 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
47926 &XLAM6* COSBT*SINBT
47927 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
47928 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
47929 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
47930 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
47932 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
47933 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
47934 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
47935 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
47936 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
47937 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
47938 &XLAM6* COSBT*SINBT
47939 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
47940 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
47941 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
47951 C*********************************************************************
47954 C...This subroutine computes the CP-even higgs and CP-odd pole
47955 c...Higgs masses and mixing angles.
47957 C...Program based on the work by M. Carena, M. Quiros
47958 C...and C.E.M. Wagner, "Effective potential methods and
47959 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
47961 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
47963 C...where MCHI is the largest chargino mass, MA is the running
47964 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
47965 C...expectaion values at the scale MTOP, MQ is the third generation
47966 C...left handed squark mass parameter, MUR is the third generation
47967 C...right handed stop mass parameter, MDR is the third generation
47968 C...right handed sbottom mass parameter, MTOP is the pole top quark
47969 C...mass; AT,AB are the soft supersymmetry breaking trilinear
47970 C...couplings of the stop and sbottoms, respectively, and MU is the
47971 C...supersymmetric mass parameter
47973 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
47974 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
47975 C...masses are given, what makes the running of the program
47976 c...much faster and it is quite generally a good approximation
47977 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
47978 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
47979 c...and if IHIGGS=3, then h,H,A polarizations are computed
47981 C...Output: MH and MHP which are the lightest CP-even Higgs running
47982 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
47983 C...Higgs running and pole masses, repectively; SA and CA are the
47984 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
47985 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
47986 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
47987 C...the value of TANB at the CP-odd Higgs mass scale
47989 C...This subroutine makes use of CERN library subroutine
47990 C...integration package, which makes the computation of the
47991 C...pole Higgs masses somewhat faster. We thank P. Janot for this
47992 C...improvement. Those who are not able to call the CERN
47993 C...libraries, please use the subroutine SUBHPOLE2.F, which
47994 C...although somewhat slower, gives identical results
47996 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
47997 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
47999 C...Double precision and integer declarations.
48000 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48001 IMPLICIT INTEGER(I-N)
48004 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48006 INTEGER PYK,PYCHGE,PYCOMP
48008 C...Local variables.
48009 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
48010 &SSBOT2(2),B(2,2),COUPB(2,2),
48011 &HCOUPT(2,2),HCOUPB(2,2),
48012 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
48021 RXMT=PYMRUN(6,XMT**2)
48022 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
48023 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
48025 SINB = TANB/(TANB**2+1D0)**0.5D0
48026 COSB = 1D0/(TANB**2+1D0)**0.5D0
48027 COS2B = SINB**2 - COSB**2
48028 SINBPA = SINB*CA + COSB*SA
48029 COSBPA = COSB*CA - SINB*SA
48030 RMBOT = PYMRUN(5,XMT**2)
48033 IF(XMUR.LT.0D0) XMUR2=-XMUR2
48035 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
48036 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
48037 IF(XMST11.LT.0D0) GOTO 500
48038 IF(XMST22.LT.0D0) GOTO 500
48039 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
48040 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
48041 IF(XMSB11.LT.0D0) GOTO 500
48042 IF(XMSB22.LT.0D0) GOTO 500
48043 C WMST11 = RXMT**2 + XMQ2
48044 C WMST22 = RXMT**2 + XMUR2
48045 XMST12 = RXMT*(AT - XMU/TANB)
48046 XMSB12 = RMBOT*(AB - XMU*TANB)
48048 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48049 C...STOP EIGENVALUES CALCULATION
48050 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48052 STOP12 = 0.5D0*(XMST11+XMST22) +
48053 &0.5D0*((XMST11+XMST22)**2 -
48054 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
48055 STOP22 = 0.5D0*(XMST11+XMST22) -
48056 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
48057 &XMST12**2))**0.5D0
48059 IF(STOP22.LT.0D0) GOTO 500
48062 STOP1 = STOP12**0.5D0
48063 STOP2 = STOP22**0.5D0
48067 IF(XMST12.EQ.0D0) XST11 = 1D0
48068 IF(XMST12.EQ.0D0) XST12 = 0D0
48069 IF(XMST12.EQ.0D0) XST21 = 0D0
48070 IF(XMST12.EQ.0D0) XST22 = 1D0
48072 IF(XMST12.EQ.0D0) GOTO 110
48074 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
48075 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
48076 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
48077 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
48084 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
48085 &0.5D0*((XMSB11+XMSB22)**2 -
48086 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
48087 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
48088 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
48089 &XMSB12**2))**0.5D0
48090 IF(SBOT22.LT.0D0) GOTO 500
48091 SBOT1 = SBOT12**0.5D0
48092 SBOT2 = SBOT22**0.5D0
48097 IF(XMSB12.EQ.0D0) XSB11 = 1D0
48098 IF(XMSB12.EQ.0D0) XSB12 = 0D0
48099 IF(XMSB12.EQ.0D0) XSB21 = 0D0
48100 IF(XMSB12.EQ.0D0) XSB22 = 1D0
48102 IF(XMSB12.EQ.0D0) GOTO 130
48104 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
48105 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
48106 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
48107 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
48119 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48120 C...STARTING OF LIGHT HIGGS
48121 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48123 IF(IHIGGS.EQ.0) GOTO 490
48128 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
48129 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
48130 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
48131 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
48140 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
48141 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
48142 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
48143 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
48151 180 ITER = ITER + 1
48154 PR(I3)=PRUN+(I3-2)*EPS/2
48159 POLT = POLT + COUPT(I,J)**2*3D0*
48160 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
48167 POLB = POLB + COUPB(I,J)**2*3D0*
48168 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
48175 & 3D0*RXMT**2/8D0/PI**2/ V **2*
48177 & (-2D0*XMT**2+0.5D0*P2)*
48178 & PYFINT(P2,XMT2,XMT2)
48180 POL = POLT + POLB + POLTT
48181 POLAR(I3) = P2 - XMH**2 - POL
48183 DERIV = (POLAR(3)-POLAR(1))/EPS
48184 DRUN = - POLAR(2)/DERIV
48187 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
48193 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48194 C...END OF LIGHT HIGGS
48195 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48197 250 IF(IHIGGS.EQ.1) GOTO 490
48199 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48200 C... STARTING OF HEAVY HIGGS
48201 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48206 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
48207 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
48208 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
48209 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
48217 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
48218 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
48219 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
48220 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
48229 300 ITER = ITER + 1
48231 PR(I3)=PRUN+(I3-2)*EPS/2
48237 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
48238 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
48245 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
48246 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
48254 & 3D0*RXMT**2/8D0/PI**2/ V **2*
48256 & (-2D0*XMT**2+0.5D0*HP2)*
48257 & PYFINT(HP2,XMT2,XMT2)
48259 HPOL = HPOLT + HPOLB + HPOLTT
48260 POLAR(I3) =HP2-HM**2-HPOL
48262 DERIV = (POLAR(3)-POLAR(1))/EPS
48263 DRUN = - POLAR(2)/DERIV
48266 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
48274 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48275 C... END OF HEAVY HIGGS
48276 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48278 IF(IHIGGS.EQ.2) GOTO 490
48280 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48281 C...BEGINNING OF PSEUDOSCALAR HIGGS
48282 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48287 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
48288 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
48294 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
48295 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
48302 420 ITER = ITER + 1
48304 PR(I3)=PRUN+(I3-2)*EPS/2
48309 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
48310 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
48316 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
48317 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
48323 & 3D0*RXMT**2/8D0/PI**2/ V **2*
48324 & COSB**2/SINB**2 *
48326 & PYFINT(AP2,XMT2,XMT2)
48327 APOL = APOLT + APOLB + APOLTT
48328 POLAR(I3) = AP2 - XMA**2 -APOL
48330 DERIV = (POLAR(3)-POLAR(1))/EPS
48331 DRUN = - POLAR(2)/DERIV
48334 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
48340 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48341 C...END OF PSEUDOSCALAR HIGGS
48342 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48344 IF(IHIGGS.EQ.3) GOTO 490
48349 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
48350 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
48351 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
48352 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
48356 C*********************************************************************
48359 C...Auxiliary to PYPOLE.
48361 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
48362 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
48363 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
48364 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
48367 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48378 C MBOTTOM(MTOP) = 3. GEV
48379 MB = PYMRUN(5,MTOP**2)
48380 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
48381 *LOG(MTOP**2/MZ**2))
48382 C RMTOP= RUNNING TOP QUARK MASS
48383 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
48384 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
48385 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
48386 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
48387 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48389 C NEW DEFINITION, TGLU.
48391 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48392 TGLU = LOG(MGLU**2/MTOP**2)
48393 SINB = TANB/DSQRT(1D0 + TANB**2)
48396 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
48397 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
48398 *LOG(MA**2/MTOP**2))
48399 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
48400 SINB = TANBT/SQRT(1D0 + TANBT**2)
48401 COSB = 1D0/DSQRT(1D0 + TANBT**2)
48402 G1 = SQRT(ALPHA1*4D0*PI)
48403 G2 = SQRT(ALPHA2*4D0*PI)
48404 G3 = SQRT(ALPHA3*4D0*PI)
48407 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
48408 *SBOT1,SBOT2,DELTAMT,DELTAMB)
48409 IF(MQ.GT.MUR) TP = TQ - TU
48410 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
48411 IF(MQ.GT.MUR) TDP = TU
48412 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
48413 IF(MQ.GT.MD) TPD = TQ - TD
48414 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
48415 IF(MQ.GT.MD) TDPD = TD
48416 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
48418 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
48419 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
48420 * HD**2*(G1**2/3D0+G2**2)*TPD
48422 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
48423 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
48424 * HU**2*(-G1**2/3D0+G2**2)*TP
48426 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48428 C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
48429 C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
48430 C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
48434 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48437 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
48438 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
48439 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
48442 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
48443 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
48446 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
48447 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
48450 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
48451 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
48454 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
48455 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
48458 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
48459 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
48464 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
48465 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
48466 *(G2**2-G1**2/3D0)*TPD
48467 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
48468 *1D0/16D0/PI**2*G1**2*HU**2*TP
48469 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
48470 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
48471 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
48472 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
48474 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
48475 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
48476 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
48477 *+ (3D0*HD**2/2D0 + HU**2/2D0
48478 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
48479 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
48480 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
48481 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
48482 *(TP + TDP)/8D0/PI**2)
48483 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
48484 *+ (3D0*HU**2/2D0 + HD**2/2D0
48485 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
48486 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
48487 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
48488 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
48489 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
48490 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
48491 LAMBDA4 = (- G2**2/2D0)*(1D0
48492 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
48493 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
48499 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
48500 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
48502 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
48503 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
48504 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
48505 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
48508 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48509 CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
48510 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48512 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
48514 IF(MCHI.GT.MSSUSY) GOTO 100
48515 IF(MCHI.LT.MTOP) MCHI=MTOP
48517 TCHAR=LOG(MSSUSY**2/MCHI**2)
48519 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
48520 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
48521 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
48523 DELTAM112=2D0*DELTAL12*V**2*COSB**2
48524 DELTAM222=2D0*DELTAL12*V**2*SINB**2
48525 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
48527 M2(1,1)=M2(1,1)+DELTAM112
48528 M2(2,2)=M2(2,2)+DELTAM222
48529 M2(1,2)=M2(1,2)+DELTAM122
48530 M2(2,1)=M2(2,1)+DELTAM122
48534 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48535 CCC END OF CHARGINOS/NEUTRALINOS
48536 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48540 M2P(I,J) = M2(I,J) + VH(I,J)
48543 TRM2P = M2P(1,1) + M2P(2,2)
48544 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
48545 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
48546 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
48548 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
48550 IF(MH2P.LT.0.) GOTO 130
48552 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
48553 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
48554 IF(COS2ALPHA.GE.0.) THEN
48555 ALPHA = ASIN(SIN2ALPHA)/2D0
48557 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
48561 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48563 C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
48564 C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
48565 C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
48568 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48569 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
48570 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
48575 C*********************************************************************
48578 C...Auxiliary to PYRGHM.
48580 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
48581 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
48582 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
48583 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
48585 INTEGER MSTU,MSTJ,KCHG
48586 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48587 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48588 SAVE /PYDAT1/,/PYDAT2/
48590 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
48592 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
48593 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
48595 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
48600 SINBA = TANBA/DSQRT(TANBA**2+1D0)
48601 COSBA = SINBA/TANBA
48603 SINB = TANB/DSQRT(TANB**2+1D0)
48609 SW = 1D0-MW**2/MZ**2
48612 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
48613 G2 = DSQRT(0.0336D0*4D0*PI)
48614 G1 = DSQRT(0.0101D0*4D0*PI)
48616 IF(MQ.GT.MUR) MST = MQ
48617 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
48619 MSUSYT = DSQRT(MST**2 + MTOP**2)
48621 IF(MQ.GT.MD) MSB = MQ
48622 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
48624 MB = PYMRUN(5,MSB**2)
48625 MSUSYB = DSQRT(MSB**2 + MB**2)
48626 TT = LOG(MSUSYT**2/MTOP**2)
48627 TB = LOG(MSUSYB**2/MTOP**2)
48629 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
48630 HT = RMTOP/(V*SINB)
48633 G32 = ALPHA3*4D0*PI
48634 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
48635 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
48636 AL2 = 3D0/8D0/PI**2*HT**2
48637 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
48638 C ALST = 3./8./PI**2*HTST**2
48639 AL1 = 3D0/8D0/PI**2*HB**2
48642 AL(1,2) = (AL2+AL1)/2D0
48643 AL(2,1) = (AL2+AL1)/2D0
48646 IF(MA.GT.MTOP) THEN
48647 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
48648 * LOG(MTOP**2/MA**2))
48651 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
48652 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
48653 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
48654 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
48659 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
48660 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
48661 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
48662 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
48666 SINBT = TANBST/DSQRT(1D0+TANBST**2)
48669 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
48670 COSBB = SINBB/TANBSB
48675 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
48676 MTOP2 = DSQRT(MTOP4)
48677 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
48678 * /(1D0+DELTAMB)**4
48679 MBOT2 = DSQRT(MBOT4)
48681 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
48682 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48683 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48684 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
48685 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
48686 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48687 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48688 * MQ2 - MUR2)**2*0.25D0
48689 * + MTOP2*(AT-XMU/TANBST)**2)
48690 IF(STOP22.LT.0.) GOTO 120
48691 SBOT12 = (MQ2 + MD2)*.5D0
48692 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48693 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48694 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48695 SBOT22 = (MQ2 + MD2)*.5D0
48696 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48697 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48698 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48699 IF(SBOT22.LT.0.) SBOT22 = 10000D0
48701 STOP1 = DSQRT(STOP12)
48702 STOP2 = DSQRT(STOP22)
48703 SBOT1 = DSQRT(SBOT12)
48704 SBOT2 = DSQRT(SBOT22)
48706 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48708 C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
48709 C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
48710 C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
48711 C INDUCED CORRECTIONS.
48713 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48718 IF(X.EQ.Y) X = X - 0.00001D0
48719 IF(X.EQ.Z) X = X - 0.00002D0
48720 IF(Y.EQ.Z) Y = Y - 0.00003D0
48726 IF(X.EQ.Y) X = X - 0.00001D0
48727 IF(X.EQ.Z) X = X - 0.00002D0
48728 IF(Y.EQ.Z) Y = Y - 0.00003D0
48730 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
48731 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
48735 IF(X.EQ.Y) X = X - 0.00001D0
48736 IF(X.EQ.Z) X = X - 0.00002D0
48737 IF(Y.EQ.Z) Y = Y - 0.00003D0
48739 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
48741 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48743 C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
48744 C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
48745 C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
48746 C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
48747 C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
48748 C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
48749 C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
48750 C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
48751 C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
48752 C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
48753 C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
48756 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48758 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
48759 MTOP2 = DSQRT(MTOP4)
48760 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
48761 * /(1D0+DELTAMB)**4
48762 MBOT2 = DSQRT(MBOT4)
48764 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
48765 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48766 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48767 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
48768 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
48769 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48770 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48771 * MQ2 - MUR2)**2*0.25D0
48772 * + MTOP2*(AT-XMU/TANBST)**2)
48774 IF(STOP22.LT.0.) GOTO 120
48775 SBOT12 = (MQ2 + MD2)*.5D0
48776 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48777 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48778 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48779 SBOT22 = (MQ2 + MD2)*.5D0
48780 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48781 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48782 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48783 IF(SBOT22.LT.0.) GOTO 120
48786 STOP1 = DSQRT(STOP12)
48787 STOP2 = DSQRT(STOP22)
48788 SBOT1 = DSQRT(SBOT12)
48789 SBOT2 = DSQRT(SBOT22)
48791 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48793 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48796 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
48798 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
48799 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
48801 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
48803 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
48804 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
48806 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
48807 * (-.5D0*LOG(STOP12/STOP22)
48808 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
48809 * G(STOP12,STOP22))
48811 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
48812 * (.5D0*LOG(SBOT12/SBOT22)
48813 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
48814 * G(SBOT12,SBOT22))
48816 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
48817 * (MQ2+MBOT2)/(MD2+MBOT2))
48818 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
48819 * LOG(SBOT1**2/SBOT2**2)) +
48820 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
48821 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
48824 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
48825 * -STOP2**2))**2*G(STOP12,STOP22)
48827 VH3B(1,1)=VH3B(1,1)+
48828 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
48830 VH3T(1,1) = VH3T(1,1) +
48831 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
48833 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
48834 * (MQ2+MTOP2)/(MUR2+MTOP2))
48835 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
48836 * LOG(STOP1**2/STOP2**2)) +
48837 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
48838 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
48841 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
48842 * -SBOT2**2))**2*G(SBOT12,SBOT22)
48844 VH3T(2,2)=VH3T(2,2)+
48845 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
48846 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
48848 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
48849 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
48850 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
48853 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
48854 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
48855 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
48858 VH3T(1,2)=VH3T(1,2) +
48859 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
48861 VH3B(1,2)=VH3B(1,2) +
48862 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
48864 VH3T(2,1) = VH3T(1,2)
48865 VH3B(2,1) = VH3B(1,2)
48867 C TQ = LOG((MQ2 + MTOP2)/MTOP2)
48868 C TU = LOG((MUR2+MTOP2)/MTOP2)
48869 C TQD = LOG((MQ2 + MB**2)/MB**2)
48870 C TD = LOG((MD2+MB**2)/MB**2)
48875 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
48876 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
48877 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
48878 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
48897 C*********************************************************************
48900 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
48902 FUNCTION PYFINT(A,B,C)
48904 C...Double precision and integer declarations.
48905 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48906 IMPLICIT INTEGER(I-N)
48907 INTEGER PYK,PYCHGE,PYCOMP
48909 COMMON/PYINTS/XXM(20)
48912 C...Local variables.
48914 DOUBLE PRECISION PYFISB
48921 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
48926 C*********************************************************************
48929 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
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
48938 COMMON/PYINTS/XXM(20)
48941 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
48942 &(X*(XXM(2)-XXM(3))+XXM(3)))
48947 C*********************************************************************
48950 C...Calculates decays of sfermions.
48952 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
48954 C...Double precision and integer declarations.
48955 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48956 IMPLICIT INTEGER(I-N)
48957 INTEGER PYK,PYCHGE,PYCOMP
48958 C...Parameter statement to help give large particle numbers.
48959 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48960 &KEXCIT=4000000,KDIMEN=5000000)
48962 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48963 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48964 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48965 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48966 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48967 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
48969 C...Local variables.
48970 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
48971 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
48973 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
48974 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
48975 DOUBLE PRECISION PYLAMF,XL
48976 DOUBLE PRECISION TANW,XW,AEM,C1,AS
48977 DOUBLE PRECISION AL,AR,BL,BR
48978 DOUBLE PRECISION CH1,CH2,CH3,CH4
48979 DOUBLE PRECISION XMBOT,XMTOP
48980 DOUBLE PRECISION XLAM(0:400)
48981 INTEGER IDLAM(400,3)
48982 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
48983 DOUBLE PRECISION SR2
48984 DOUBLE PRECISION CBETA,SBETA
48985 DOUBLE PRECISION CW
48986 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
48987 DOUBLE PRECISION COSA,SINA,TANB
48988 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
48989 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
48991 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
48992 DATA IGG/23,25,35,36/
48993 DATA PI/3.141592654D0/
48994 DATA SR2/1.4142136D0/
48995 DATA KFNCHI/1000022,1000023,1000025,1000035/
48996 DATA KFCCHI/1000024,1000037/
48998 C...COUNT THE NUMBER OF DECAY MODES
49002 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
49003 &KFIN.EQ.KSUSY2+16) RETURN
49009 TANW = SQRT(XW/(1D0-XW))
49014 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
49019 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
49020 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
49026 C...ILR is 1 for left and 2 for right.
49028 C...IFL is matching non-SUSY flavour.
49029 IFL=MOD(KFIN,KSUSY1)
49030 C...IDU is weak isospin, 1 for down and 2 for up.
49041 XMBOT=PYMRUN(5,XMI2)
49042 XMTOP=PYMRUN(6,XMI2)
49056 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
49058 IF(IMSS(11).EQ.1) THEN
49061 XMGR=PMAS(PYCOMP(IDG),1)
49062 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
49065 ELSEIF(IFL.EQ.6) THEN
49070 IF(XMI.GT.XMGR+XMF) THEN
49075 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
49079 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
49081 C...CHARGED DECAYS:
49083 C...DI -> U CHI1-,CHI2-
49087 C...UI -> D CHI1+,CHI2+
49094 IF(XMI.GE.AXMJ+XMFP) THEN
49101 ELSEIF(IFL.LT.6) THEN
49106 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
49107 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
49113 ELSEIF(IFL.LT.5) THEN
49118 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
49119 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
49123 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
49124 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
49125 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
49126 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
49142 XL=PYLAMF(XMI2,XMA2,XMB2)
49143 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
49144 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
49145 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
49148 IDLAM(LKNT,1)=-KFCCHI(IX)
49149 IDLAM(LKNT,2)=IFL+1
49151 IDLAM(LKNT,1)=KFCCHI(IX)
49152 IDLAM(LKNT,2)=IFL-1
49163 IF(XMI.GE.AXMJ+XMF) THEN
49169 ELSEIF(IFL.LT.5) THEN
49172 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
49173 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
49174 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
49179 ELSEIF(IFL.LT.5) THEN
49182 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
49183 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
49184 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
49188 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
49189 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
49190 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
49191 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
49207 XL=PYLAMF(XMI2,XMA2,XMB2)
49208 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
49209 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
49210 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
49211 IDLAM(LKNT,1)=KFNCHI(IX)
49217 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
49221 IF(ILR.EQ.1) GOTO 160
49223 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
49224 IF(XMI.LT.XMSF1+XMB) GOTO 160
49226 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
49229 ELSEIF(IG.EQ.25) THEN
49232 ELSEIF(IFL.EQ.6) THEN
49234 ELSEIF(IFL.LT.5) THEN
49240 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
49241 & XMF**2/XMW*COSA/SBETA
49242 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
49243 & XMF**2/XMW*COSA/SBETA
49245 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
49246 & XMF**2/XMW*(-SINA)/CBETA
49247 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
49248 & XMF**2/XMW*(-SINA)/CBETA
49252 ELSEIF(IFL.EQ.6) THEN
49254 ELSEIF(IFL.EQ.15) THEN
49259 C.........need to complexify
49261 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
49264 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
49270 ELSEIF(IG.EQ.35) THEN
49273 ELSEIF(IFL.EQ.6) THEN
49275 ELSEIF(IFL.LT.5) THEN
49281 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
49282 & XMF**2/XMW*SINA/SBETA
49283 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
49284 & XMF**2/XMW*SINA/SBETA
49286 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
49287 & XMF**2/XMW*COSA/CBETA
49288 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
49289 & XMF**2/XMW*COSA/CBETA
49293 ELSEIF(IFL.EQ.6) THEN
49295 ELSEIF(IFL.EQ.15) THEN
49300 C.........Need to complexify
49302 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
49305 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
49311 ELSEIF(IG.EQ.36) THEN
49316 ELSEIF(IFL.EQ.6) THEN
49318 ELSEIF(IFL.LT.5) THEN
49325 ELSEIF(IFL.EQ.6) THEN
49327 ELSEIF(IFL.EQ.15) THEN
49332 C.........Need to complexify
49334 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
49336 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
49342 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
49343 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
49344 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
49345 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49348 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
49350 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
49353 IDLAM(LKNT,1)=KFIN-KSUSY1
49359 IF(MOD(IFL,2).EQ.0) THEN
49365 XMSF1=PMAS(PYCOMP(KF1),1)
49366 XMSF2=PMAS(PYCOMP(KF2),1)
49367 IF(XMI.GT.XMB+XMSF1) THEN
49368 IF(MOD(IFL,2).EQ.0) THEN
49370 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
49372 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
49376 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
49378 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
49381 XL=PYLAMF(XMI2,XMSF1**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))
49388 IF(XMI.GT.XMB+XMSF2) THEN
49389 IF(MOD(IFL,2).EQ.0) THEN
49391 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
49393 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
49397 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
49399 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
49402 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
49404 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
49407 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
49412 IF(MOD(IFL,2).EQ.0) THEN
49418 XMSF1=PMAS(PYCOMP(KF1),1)
49419 XMSF2=PMAS(PYCOMP(KF2),1)
49420 IF(XMI.GT.XMB+XMSF1) THEN
49425 IF(MOD(IFL,2).EQ.0) THEN
49428 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
49429 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
49430 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
49431 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
49434 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
49435 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
49436 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
49437 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
49448 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
49449 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
49450 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
49451 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
49454 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
49455 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
49456 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
49457 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
49466 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49468 C.......Need to complexify
49469 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
49470 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
49471 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
49472 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
49475 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
49477 IF(XMI.GT.XMB+XMSF2) THEN
49482 IF(MOD(IFL,2).EQ.0) THEN
49485 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
49486 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
49487 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
49488 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
49491 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
49492 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
49493 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
49494 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
49505 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
49506 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
49507 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
49508 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
49511 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
49512 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
49513 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
49514 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
49523 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49525 C.......Need to complexify
49526 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
49527 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
49528 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
49529 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
49532 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
49535 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
49540 IF(IFL.EQ.6) XMF=PMAS(6,1)
49541 IF(IFL.EQ.5) XMF=PMAS(5,1)
49542 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
49544 IF(XMI.GE.AXMJ+XMF) THEN
49561 XL=PYLAMF(XMI2,XMA2,XMB2)
49562 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
49563 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
49564 IDLAM(LKNT,1)=KSUSY1+21
49570 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
49571 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
49572 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
49573 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
49574 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
49575 C...M*M = C1**2 * G**2/(16PI**2)
49576 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
49578 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
49579 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
49580 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
49581 IDLAM(LKNT,1)=KSUSY1+22
49586 C...R-violating sfermion decays (SKANDS).
49587 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
49592 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
49593 XLAM(0)=XLAM(0)+XLAM(I)
49595 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
49600 C*********************************************************************
49603 C...Calculates gluino decay modes.
49605 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
49607 C...Double precision and integer declarations.
49608 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49609 IMPLICIT INTEGER(I-N)
49610 INTEGER PYK,PYCHGE,PYCOMP
49611 C...Parameter statement to help give large particle numbers.
49612 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49613 &KEXCIT=4000000,KDIMEN=5000000)
49615 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49616 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49617 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49618 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49619 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49621 C COMMON/PYINTS/XXM(20)
49623 COMMON/PYINTC/XXC(10),CXC(8)
49624 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
49626 C...Local variables
49627 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
49628 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
49629 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
49630 DOUBLE PRECISION PYLAMF,XL
49631 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
49632 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
49633 DOUBLE PRECISION XLAM(0:400)
49634 INTEGER IDLAM(400,3)
49635 INTEGER LKNT,IX,ILR,I,IKNT,IFL
49636 DOUBLE PRECISION SR2
49637 DOUBLE PRECISION GAM
49638 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
49639 EXTERNAL PYGAUS,PYXXZ6
49640 DOUBLE PRECISION PYGAUS,PYXXZ6
49641 DOUBLE PRECISION PREC
49642 INTEGER KFNCHI(4),KFCCHI(2)
49643 DATA PI/3.141592654D0/
49644 DATA SR2/1.4142136D0/
49646 DATA KFNCHI/1000022,1000023,1000025,1000035/
49647 DATA KFCCHI/1000024,1000037/
49649 C...COUNT THE NUMBER OF DECAY MODES
49651 IF(KFIN.NE.KSUSY1+21) RETURN
49655 TANW = SQRT(XW/(1D0-XW))
49665 XMI=SIGN(XMI,RMSS(3))
49667 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
49669 IF(IMSS(11).EQ.1) THEN
49672 XMGR=PMAS(PYCOMP(IDG),1)
49673 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
49674 IF(AXMI.GT.XMGR) THEN
49683 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
49687 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
49690 IF(AXMI.GE.AXMJ+XMF) THEN
49691 C...Minus sign difference from gluino-quark-squark feynman rules
49708 XL=PYLAMF(XMI2,XMA2,XMB2)
49709 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
49710 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
49711 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
49715 XLAM(LKNT)=XLAM(LKNT-1)
49716 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49717 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49723 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
49724 C...GLUINO -> NI Q QBAR
49728 IF(AXMI.GE.AXMJ) THEN
49730 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
49732 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
49739 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
49740 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
49746 T3I=SIGN(1D0,EI+1D-6)/2D0
49747 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
49748 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
49752 CXC(4)=DCONJG(GLIJ)
49756 CXC(8)=-DCONJG(GRIJ)
49758 S12MAX=(AXMI-AXMJ)**2
49759 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
49760 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
49762 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
49763 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
49764 IDLAM(LKNT,1)=KFNCHI(IX)
49768 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
49770 XLAM(LKNT)=XLAM(LKNT-1)
49771 IDLAM(LKNT,1)=KFNCHI(IX)
49776 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
49777 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
49778 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
49780 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
49781 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
49783 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
49786 IDLAM(LKNT,1)=KFNCHI(IX)
49789 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
49794 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
49795 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
49796 C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
49800 T3I=SIGN(1D0,EI+1D-6)/2D0
49801 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
49802 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
49804 CXC(4)=DCONJG(GLIJ)
49806 CXC(8)=-DCONJG(GRIJ)
49807 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
49808 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
49810 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
49811 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
49812 IDLAM(LKNT,1)=KFNCHI(IX)
49816 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
49818 XLAM(LKNT)=XLAM(LKNT-1)
49819 IDLAM(LKNT,1)=KFNCHI(IX)
49824 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
49825 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
49827 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
49828 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
49829 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
49831 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
49832 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
49834 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
49837 IDLAM(LKNT,1)=KFNCHI(IX)
49840 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
49846 C...GLUINO -> CI Q QBAR'
49850 IF(AXMI.GE.AXMJ) THEN
49852 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
49853 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
49856 S12MAX=(AXMI-AXMJ)**2
49861 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
49862 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
49865 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
49867 CXC(1)=DCMPLX(0D0,0D0)
49868 CXC(3)=DCMPLX(0D0,0D0)
49869 CXC(5)=DCMPLX(0D0,0D0)
49870 CXC(7)=DCMPLX(0D0,0D0)
49871 CXC(2)=UMIXC(IX,1)*OLPP/SR2
49872 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
49873 CXC(6)=DCMPLX(0D0,0D0)
49874 CXC(8)=DCMPLX(0D0,0D0)
49875 IF(XXC(5).LT.AXMI) THEN
49877 ELSEIF(XXC(6).LT.AXMI) THEN
49882 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
49883 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
49885 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
49886 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
49887 IDLAM(LKNT,1)=KFCCHI(IX)
49891 XLAM(LKNT)=XLAM(LKNT-1)
49892 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49893 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49894 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49896 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
49898 XLAM(LKNT)=XLAM(LKNT-1)
49899 IDLAM(LKNT,1)=KFCCHI(IX)
49903 XLAM(LKNT)=XLAM(LKNT-1)
49904 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49905 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49906 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49912 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
49913 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
49914 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
49915 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
49916 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
49917 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
49918 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
49919 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
49920 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
49921 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
49922 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
49923 CALL PYTBBC(IX,100,XMI,GAM)
49926 IDLAM(LKNT,1)=KFCCHI(IX)
49930 XLAM(LKNT)=XLAM(LKNT-1)
49931 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49932 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49933 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49934 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
49935 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
49936 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
49937 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
49943 C...R-parity violating (3-body) decays.
49944 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
49949 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
49950 XLAM(0)=XLAM(0)+XLAM(I)
49952 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
49958 C*********************************************************************
49961 C...Calculates the three-body decay of gluinos into
49962 C...neutralinos and third generation fermions.
49964 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
49966 C...Double precision and integer declarations.
49967 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49968 IMPLICIT INTEGER(I-N)
49969 INTEGER PYK,PYCHGE,PYCOMP
49970 C...Parameter statement to help give large particle numbers.
49971 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49972 &KEXCIT=4000000,KDIMEN=5000000)
49974 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49975 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49976 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49977 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49978 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49979 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
49981 C...Local variables.
49982 EXTERNAL PYSIMP,PYLAMF
49983 DOUBLE PRECISION PYSIMP,PYLAMF
49985 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
49986 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
49987 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
49988 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
49989 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
49990 DOUBLE PRECISION XLN1,XLN2,B1,B2
49991 DOUBLE PRECISION E,XMGLU,GAM
49992 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
49993 SAVE HRB,HLB,FLB,FRB
49994 DOUBLE PRECISION ALPHAW,ALPHAS
49995 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
49996 SAVE HLT,HRT,FLT,FRT
49997 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
49999 DOUBLE PRECISION AMBOT,SINC,COSC
50000 DOUBLE PRECISION AMTOP,SINA,COSA
50001 DOUBLE PRECISION SINW,COSW,TANW
50002 DOUBLE PRECISION ROT1(4,4)
50005 DATA IFIRST/.TRUE./
50008 SINB=TANB/SQRT(1D0+TANB**2)
50019 AMBOT=PYMRUN(5,XMGLU**2)
50020 AMTOP=PYMRUN(6,XMGLU**2)
50022 FAKT1=AMBOT/W2/AMW/COSB
50023 FAKT2=AMTOP/W2/AMW/SINB
50034 ROT1(2,1)=-ROT1(1,2)
50035 ROT1(2,2)=ROT1(1,1)
50038 ROT1(4,3)=-ROT1(3,4)
50039 ROT1(4,4)=ROT1(3,3)
50043 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
50048 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
50049 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
50050 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
50052 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
50053 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
50054 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
50055 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
50058 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
50059 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
50060 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
50061 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
50062 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
50063 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
50064 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
50068 C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
50069 C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
50070 C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
50071 C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
50075 IF(NINT(3D0*E).EQ.2) THEN
50082 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
50083 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
50092 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
50093 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
50099 SIN2D=SIND*COSD*2D0
50113 ALPHAW=PYALEM(XMG2)
50114 ALPHAS=PYALPS(XMG2)
50118 XM24=(XMG2+XM2)*(XM2+XMR2)
50120 SMAX=(XMG-ABS(XMR))**2
50121 XMQA=XMG2+2D0*XM2+XMR2
50123 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
50125 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
50127 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
50128 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
50129 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
50130 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
50131 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
50132 & +2D0*(FF*SIND2-HH*COSD2))*W
50133 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
50134 & +4D0*HFL*XM*XMR)*XLN1
50135 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
50136 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
50137 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
50138 & +8D0*HFL*XMQ4*SIN2D)*B1
50139 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
50140 & +4D0*HFR*XMR*XM)*XLN2
50141 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
50142 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
50143 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
50144 & -8D0*HFR*XMQ4*SIN2D)*B2
50145 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
50146 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
50147 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
50148 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
50149 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
50150 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
50151 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
50152 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
50153 G(5)=(2D0*(HH*COSD2-FF*SIND2)
50154 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
50155 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
50156 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
50157 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
50158 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
50159 & +COS2D*XM*(SBAR+XMG2-XMR2))
50160 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
50161 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
50162 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
50163 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
50164 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
50165 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
50166 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
50169 SUMME(LIN)=SUMME(LIN)+G(J)
50174 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
50175 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
50180 C*********************************************************************
50183 C...Calculates the three-body decay of gluinos into
50184 C...charginos and third generation fermions.
50186 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
50188 C...Double precision and integer declarations.
50189 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50190 IMPLICIT INTEGER(I-N)
50191 INTEGER PYK,PYCHGE,PYCOMP
50192 C...Parameter statement to help give large particle numbers.
50193 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50194 &KEXCIT=4000000,KDIMEN=5000000)
50196 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50197 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50198 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50199 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50200 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50201 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50203 C...Local variables.
50204 EXTERNAL PYSIMP,PYLAMF
50205 DOUBLE PRECISION PYSIMP,PYLAMF
50207 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
50208 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
50209 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
50210 DOUBLE PRECISION SUMME(0:100),A(4,8)
50211 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
50212 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
50213 DOUBLE PRECISION XMGLU,GAM
50214 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
50215 &DDD(2),EEE(2),FFF(2)
50216 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
50217 DOUBLE PRECISION ALPHAW,ALPHAS
50218 DOUBLE PRECISION AMC(2)
50220 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
50221 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
50225 DATA IFIRST/.TRUE./
50228 SINB=TANB/SQRT(1D0+TANB**2)
50236 AMBOT=PYMRUN(5,XMGLU**2)
50237 AMTOP=PYMRUN(6,XMGLU**2)
50240 FAKT1=AMBOT/W2/AMW/COSB
50241 FAKT2=AMTOP/W2/AMW/SINB
50246 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
50247 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
50248 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
50249 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
50250 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
50251 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
50252 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
50253 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
50255 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
50256 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
50257 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
50258 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
50262 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
50263 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
50264 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
50265 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
50267 COS2A=COSA**2-SINA**2
50268 SIN2A=SINA*COSA*2D0
50269 COS2C=COSC**2-SINC**2
50270 SIN2C=SINC*COSC*2D0
50277 ALPHAW=PYALEM(XMG2)
50278 ALPHAS=PYALPS(XMG2)
50282 XMQ2=XMG2+XMT2+XMB2+XMR2
50283 XMQ4=XMG*XMT*XMB*XMR
50284 XMQ3=XMG2*XMR2+XMT2*XMB2
50285 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
50286 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
50288 XMST(1)=AMST(1)*AMST(1)
50289 XMST(2)=AMST(1)*AMST(1)
50290 XMST(3)=AMST(2)*AMST(2)
50291 XMST(4)=AMST(2)*AMST(2)
50292 XMSB(1)=AMSB(1)*AMSB(1)
50293 XMSB(2)=AMSB(2)*AMSB(2)
50294 XMSB(3)=AMSB(1)*AMSB(1)
50295 XMSB(4)=AMSB(2)*AMSB(2)
50297 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
50298 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
50299 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
50300 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
50301 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
50302 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
50303 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
50304 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
50306 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
50307 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
50308 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
50309 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
50310 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
50311 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
50312 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
50313 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
50315 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
50316 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
50317 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
50318 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
50319 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
50320 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
50321 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
50322 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
50324 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
50325 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
50326 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
50327 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
50328 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
50329 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
50330 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
50331 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
50333 SMAX=(XMG-ABS(XMR))**2
50334 SMIN=(XMB+XMT)**2+0.1D0
50337 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
50338 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
50340 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
50341 W=DSQRT(W)/2D0/SBAR
50342 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
50343 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
50344 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
50345 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
50346 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
50347 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
50348 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
50349 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
50350 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
50351 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
50352 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
50353 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
50354 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
50355 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
50356 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
50357 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
50358 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
50359 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
50360 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
50361 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
50362 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
50363 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
50364 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
50365 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
50366 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
50367 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
50368 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
50369 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
50370 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
50371 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
50372 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
50373 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
50374 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
50375 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
50376 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
50377 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
50378 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
50379 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
50380 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
50381 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
50382 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
50383 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
50384 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
50386 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
50387 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
50388 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
50389 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
50390 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
50391 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
50392 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
50393 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
50394 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
50395 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
50396 & -A(J,6)*(XMG2+XMR2-SBAR)
50397 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
50398 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
50399 & /(GRS+XMSB(J)+XMST(J))
50403 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
50404 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
50409 C*********************************************************************
50412 C...Calculates decay widths for the neutralinos (admixtures of
50413 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
50415 C...Input: KCIN = KF code for particle
50416 C...Output: XLAM = widths
50417 C... IDLAM = KF codes for decay particles
50418 C... IKNT = number of decay channels defined
50419 C...AUTHOR: STEPHEN MRENNA
50421 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
50422 C...when CHIGAMMA .NE. 0
50423 C...10 FEB 96: Calculate this decay for small tan(beta)
50425 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
50427 C...Double precision and integer declarations.
50428 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50429 IMPLICIT INTEGER(I-N)
50430 INTEGER PYK,PYCHGE,PYCOMP
50431 C...Parameter statement to help give large particle numbers.
50432 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50433 &KEXCIT=4000000,KDIMEN=5000000)
50435 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50436 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50437 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50438 c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50440 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50441 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50442 C COMMON/PYINTS/XXM(20)
50444 COMMON/PYINTC/XXC(10),CXC(8)
50445 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50447 C...Local variables.
50448 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
50449 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
50451 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
50452 &XMZ,XMZ2,AXMJ,AXMI
50453 DOUBLE PRECISION S12MIN,S12MAX
50454 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
50455 DOUBLE PRECISION PYLAMF,XL
50456 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
50457 DOUBLE PRECISION PYX2XH,PYX2XG
50458 DOUBLE PRECISION XLAM(0:400)
50459 INTEGER IDLAM(400,3)
50460 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
50461 INTEGER ITH(3),KF1,KF2
50463 DOUBLE PRECISION DH(3),EH(3)
50464 DOUBLE PRECISION SR2
50465 DOUBLE PRECISION CBETA,SBETA
50466 DOUBLE PRECISION GAMCON,XMT1,XMT2
50467 DOUBLE PRECISION PYALEM,PI,PYALPS
50468 DOUBLE PRECISION RAT1,RAT2
50469 DOUBLE PRECISION T3T,FCOL
50470 DOUBLE PRECISION ALFA,BETA,TANB
50471 DOUBLE PRECISION PYXXGA
50472 EXTERNAL PYGAUS,PYXXZ6
50473 DOUBLE PRECISION PYGAUS,PYXXZ6
50474 DOUBLE PRECISION PREC
50475 INTEGER KFNCHI(4),KFCCHI(2)
50479 DATA PI/3.141592654D0/
50480 DATA SR2/1.4142136D0/
50481 DATA KFNCHI/1000022,1000023,1000025,1000035/
50482 DATA KFCCHI/1000024,1000037/
50484 C...COUNT THE NUMBER OF DECAY MODES
50493 TANW = SQRT(XW/XW1)
50495 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
50497 IF(KFIN.EQ.KFNCHI(2)) IX=2
50498 IF(KFIN.EQ.KFNCHI(3)) IX=3
50499 IF(KFIN.EQ.KFNCHI(4)) IX=4
50519 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
50524 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
50525 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
50529 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
50530 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
50532 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
50533 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
50537 GAMCON=AEM**3/8D0/PI/XMW2/XW
50538 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
50539 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
50540 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
50541 IDLAM(LKNT,1)=KSUSY1+22
50544 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
50548 C...GRAVITINO DECAY MODES
50550 IF(IMSS(11).EQ.1) THEN
50553 XMGR=PMAS(PYCOMP(IDG),1)
50556 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
50557 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
50562 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
50564 IF(AXMI.GT.XMGR+XMZ) THEN
50569 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
50570 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
50571 & (1D0-XMZ2/XMI2)**4
50573 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
50578 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
50579 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
50581 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
50586 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
50587 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
50589 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
50594 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
50595 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
50597 IF(IX.EQ.1) GOTO 300
50605 C...CHI0_I -> CHI0_J + GAMMA
50606 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
50607 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
50608 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
50609 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
50610 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
50611 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
50612 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
50614 IDLAM(LKNT,1)=KFNCHI(IJ)
50617 GAMCON=AEM**3/8D0/PI/XMW2/XW
50618 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
50619 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
50620 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
50624 C...CHI0_I -> CHI0_J + Z0
50625 IF(AXMI.GE.AXMJ+XMZ) THEN
50627 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
50628 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
50630 GX2=ABS(OLPP)**2+ABS(ORPP)**2
50631 GLR=DBLE(OLPP*DCONJG(ORPP))
50632 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
50633 IDLAM(LKNT,1)=KFNCHI(IJ)
50636 ELSEIF(AXMI.GE.AXMJ) THEN
50643 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
50644 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
50646 C...CHARGED LEPTONS
50648 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50649 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50651 T3I=SIGN(1D0,EI+1D-6)/2D0
50652 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50653 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50654 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50655 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50657 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50658 CXC(4)=DCONJG(GLIJ)
50659 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50661 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50662 CXC(8)=-DCONJG(GRIJ)
50664 S12MAX=(AXMI-AXMJ)**2
50665 IF( XXC(5).LT.AXMI ) THEN
50668 IF(XXC(6).LT.AXMI ) THEN
50674 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
50676 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50677 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50678 IDLAM(LKNT,1)=KFNCHI(IJ)
50681 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
50683 XLAM(LKNT)=XLAM(LKNT-1)
50684 IDLAM(LKNT,1)=KFNCHI(IJ)
50690 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
50691 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
50692 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
50694 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
50695 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
50697 IF( XXC(5).LT.AXMI ) THEN
50700 IF(XXC(6).LT.AXMI ) THEN
50706 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
50708 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50709 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50710 IDLAM(LKNT,1)=KFNCHI(IJ)
50718 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50719 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50721 T3I=SIGN(1D0,EI+1D-6)/2D0
50722 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50723 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50724 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50725 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50727 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50728 CXC(4)=DCONJG(GLIJ)
50729 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50731 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50732 CXC(8)=-DCONJG(GRIJ)
50734 S12MAX=(AXMI-AXMJ)**2
50735 IF( XXC(5).LT.AXMI ) THEN
50738 IF( XXC(6).LT.AXMI ) THEN
50745 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50746 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50747 IDLAM(LKNT,1)=KFNCHI(IJ)
50751 XLAM(LKNT)=XLAM(LKNT-1)
50752 IDLAM(LKNT,1)=KFNCHI(IJ)
50757 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
50759 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
50760 IF( XXC(5).LT.AXMI ) THEN
50765 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50766 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50769 XLAM(LKNT)=XLAM(LKNT-1)
50771 IDLAM(LKNT,1)=KFNCHI(IJ)
50777 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50778 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50780 T3I=SIGN(1D0,EI+1D-6)/2D0
50781 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50782 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50783 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50784 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50786 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50787 CXC(4)=DCONJG(GLIJ)
50788 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50790 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50791 CXC(8)=-DCONJG(GRIJ)
50793 S12MAX=(AXMI-AXMJ)**2
50794 IF( XXC(5).LT.AXMI ) THEN
50797 IF( XXC(6).LT.AXMI ) THEN
50803 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50805 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50806 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
50807 IDLAM(LKNT,1)=KFNCHI(IJ)
50810 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50812 XLAM(LKNT)=XLAM(LKNT-1)
50813 IDLAM(LKNT,1)=KFNCHI(IJ)
50819 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
50820 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
50821 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
50823 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
50824 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
50826 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
50827 IF(XXC(5).LT.AXMI) THEN
50829 ELSEIF(XXC(6).LT.AXMI) THEN
50834 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50836 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50837 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
50838 IDLAM(LKNT,1)=KFNCHI(IJ)
50846 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50847 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50849 T3I=SIGN(1D0,EI+1D-6)/2D0
50850 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50851 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50852 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50853 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50855 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50856 CXC(4)=DCONJG(GLIJ)
50857 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50859 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50860 CXC(8)=-DCONJG(GRIJ)
50862 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
50863 IF(XXC(5).LT.AXMI) THEN
50865 ELSEIF(XXC(6).LT.AXMI) THEN
50871 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50873 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50874 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
50875 IDLAM(LKNT,1)=KFNCHI(IJ)
50878 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50880 XLAM(LKNT)=XLAM(LKNT-1)
50881 IDLAM(LKNT,1)=KFNCHI(IJ)
50889 C...CHI0_I -> CHI0_J + H0_K
50896 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
50897 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
50898 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
50899 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
50900 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
50901 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
50902 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
50903 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
50905 XMH=PMAS(ITH(IH),1)
50907 IF(AXMI.GE.AXMJ+XMH) THEN
50909 XL=PYLAMF(XMI2,XMJ2,XMH2)
50910 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
50912 C...SIGN OF MASSES I,J
50914 IF(IH.EQ.3) XMK=-XMK
50915 GX2=ABS(F21K)**2+ABS(F12K)**2
50916 GLR=DBLE(F21K*DCONJG(F12K))
50917 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
50918 IDLAM(LKNT,1)=KFNCHI(IJ)
50919 IDLAM(LKNT,2)=ITH(IH)
50925 C...CHI0_I -> CHI+_J + W-
50930 IF(AXMI.GE.AXMJ+XMW) THEN
50932 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
50933 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
50934 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
50935 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
50936 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
50937 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
50938 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
50939 IDLAM(LKNT,1)=KFCCHI(IJ)
50943 XLAM(LKNT)=XLAM(LKNT-1)
50944 IDLAM(LKNT,1)=-KFCCHI(IJ)
50947 ELSEIF(AXMI.GE.AXMJ) THEN
50949 S12MAX=(AXMI-AXMJ)**2
50950 RT2I = 1D0/SQRT(2D0)
50951 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
50952 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
50953 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
50954 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
50955 CXC(5)=DCMPLX(0D0,0D0)
50956 CXC(7)=DCMPLX(0D0,0D0)
50960 T3I=SIGN(1D0,EI+1D-6)/2D0
50962 T3J=SIGN(1D0,EJ+1D-6)/2D0
50963 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
50964 & TANW+ZMIXC(IX,2)*T3J)*RT2I
50965 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
50966 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
50967 CXC(6)=DCMPLX(0D0,0D0)
50968 CXC(8)=DCMPLX(0D0,0D0)
50973 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50974 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
50977 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
50978 IF(XXC(5).LT.AXMI) THEN
50980 ELSEIF(XXC(6).LT.AXMI) THEN
50985 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
50987 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50988 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50989 IDLAM(LKNT,1)=KFCCHI(IJ)
50993 XLAM(LKNT)=XLAM(LKNT-1)
50994 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50995 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50996 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50997 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
50999 XLAM(LKNT)=XLAM(LKNT-1)
51000 IDLAM(LKNT,1)=KFCCHI(IJ)
51004 XLAM(LKNT)=XLAM(LKNT-1)
51005 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51006 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51007 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51011 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51012 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51013 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51015 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51016 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51018 IF(XXC(5).LT.AXMI) THEN
51021 IF(XXC(6).LT.AXMI) THEN
51026 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51028 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51029 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51030 XLAM(LKNT)=XLAM(LKNT-1)
51031 IDLAM(LKNT,1)=KFCCHI(IJ)
51035 XLAM(LKNT)=XLAM(LKNT-1)
51036 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51037 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51038 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51041 C...NOW, DO THE QUARKS
51046 T3I=SIGN(1D0,EI+1D-6)/2D0
51048 T3J=SIGN(1D0,EJ+1D-6)/2D0
51049 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
51050 & TANW+ZMIXC(IX,2)*T3J)
51051 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
51052 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
51053 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
51054 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
51055 IF(XXC(5).LT.AXMI) THEN
51058 IF(XXC(6).LT.AXMI) THEN
51063 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
51065 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51066 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51067 IDLAM(LKNT,1)=KFCCHI(IJ)
51071 XLAM(LKNT)=XLAM(LKNT-1)
51072 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51073 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51074 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51075 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51077 XLAM(LKNT)=XLAM(LKNT-1)
51078 IDLAM(LKNT,1)=KFCCHI(IJ)
51082 XLAM(LKNT)=XLAM(LKNT-1)
51083 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51084 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51085 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51093 C...CHI0_I -> CHI+_I + H-
51099 IF(AXMI.GE.AXMJ+XMHP) THEN
51101 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
51102 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
51103 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
51104 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
51106 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51107 GLR=DBLE(OLPP*DCONJG(ORPP))
51108 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
51109 IDLAM(LKNT,1)=KFCCHI(IJ)
51110 IDLAM(LKNT,2)=-ITHC
51113 XLAM(LKNT)=XLAM(LKNT-1)
51114 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51115 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51116 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51122 C...2-BODY DECAYS TO FERMION SFERMION
51124 IF(J.GE.7.AND.J.LE.10) GOTO 290
51127 XMSF1=PMAS(PYCOMP(KF1),1)
51128 XMSF2=PMAS(PYCOMP(KF2),1)
51138 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
51139 IF(MOD(J,2).EQ.0) THEN
51140 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
51141 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
51142 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
51145 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
51146 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
51147 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
51152 IF(AXMI.GE.XMF+XMSF1) THEN
51156 XL=PYLAMF(XMI2,XMA2,XMB2)
51157 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
51158 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
51159 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51160 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51165 XLAM(LKNT)=XLAM(LKNT-1)
51166 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51167 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51172 IF(AXMI.GE.XMF+XMSF2) THEN
51176 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
51177 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
51178 XL=PYLAMF(XMI2,XMA2,XMB2)
51179 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51180 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51185 XLAM(LKNT)=XLAM(LKNT-1)
51186 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51187 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51192 C...3-BODY DECAY TO Q Q~ GLUINO
51193 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
51194 IF(AXMI.GE.XMJ) THEN
51195 RT2I = 1D0/SQRT(2D0)
51196 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
51204 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51205 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51206 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
51212 T3I=SIGN(1D0,EI+1D-6)/2D0
51213 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51214 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51218 CXC(4)=DCONJG(GLIJ)
51222 CXC(8)=-DCONJG(GRIJ)
51224 S12MAX=(AXMI-AXMJ)**2
51225 C...ALL QUARKS BUT T
51226 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51228 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
51229 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51230 IDLAM(LKNT,1)=KSUSY1+21
51233 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51235 XLAM(LKNT)=XLAM(LKNT-1)
51236 IDLAM(LKNT,1)=KSUSY1+21
51242 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51243 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51244 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
51246 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
51247 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51249 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
51252 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51254 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
51255 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51256 IDLAM(LKNT,1)=KSUSY1+21
51263 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51264 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51265 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
51269 T3I=SIGN(1D0,EI+1D-6)/2D0
51270 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51271 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51273 CXC(4)=DCONJG(GLIJ)
51275 CXC(8)=-DCONJG(GRIJ)
51276 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51278 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
51279 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51280 IDLAM(LKNT,1)=KSUSY1+21
51283 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51285 XLAM(LKNT)=XLAM(LKNT-1)
51286 IDLAM(LKNT,1)=KSUSY1+21
51294 C...R-violating decay modes (SKANDS).
51295 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
51300 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
51301 XLAM(0)=XLAM(0)+XLAM(I)
51303 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
51308 C*********************************************************************
51311 C...Calculate decay widths for the charginos (admixtures of
51312 C...charged Wino and charged Higgsino.
51314 C...Input: KCIN = KF code for particle
51315 C...Output: XLAM = widths
51316 C... IDLAM = KF codes for decay particles
51317 C... IKNT = number of decay channels defined
51318 C...AUTHOR: STEPHEN MRENNA
51320 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
51321 C...when CHIENU .NE. 0
51323 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
51325 C...Double precision and integer declarations.
51326 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51327 IMPLICIT INTEGER(I-N)
51328 INTEGER PYK,PYCHGE,PYCOMP
51329 C...Parameter statement to help give large particle numbers.
51330 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51331 &KEXCIT=4000000,KDIMEN=5000000)
51333 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51334 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51335 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51336 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51337 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51339 C COMMON/PYINTS/XXM(20)
51341 COMMON/PYINTC/XXC(10),CXC(8)
51342 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51344 C...Local variables
51345 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
51346 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
51348 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
51349 &XMZ,XMZ2,AXMJ,AXMI
51350 DOUBLE PRECISION S12MIN,S12MAX
51351 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
51352 DOUBLE PRECISION PYLAMF,XL
51353 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
51354 DOUBLE PRECISION PYX2XH,PYX2XG
51355 DOUBLE PRECISION XLAM(0:400)
51356 INTEGER IDLAM(400,3)
51357 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
51360 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
51361 DOUBLE PRECISION SR2
51362 DOUBLE PRECISION CBETA,SBETA,TANB
51364 DOUBLE PRECISION PYALEM,PI,PYALPS
51365 DOUBLE PRECISION FCOL
51366 INTEGER KF1,KF2,ISF
51367 INTEGER KFNCHI(4),KFCCHI(2)
51369 DOUBLE PRECISION TEMP
51370 EXTERNAL PYGAUS,PYXXZ6
51371 DOUBLE PRECISION PYGAUS,PYXXZ6
51372 DOUBLE PRECISION PREC
51375 DATA ETAH/1D0,1D0,-1D0/
51376 DATA SR2/1.4142136D0/
51377 DATA PI/3.141592654D0/
51379 DATA KFNCHI/1000022,1000023,1000025,1000035/
51380 DATA KFCCHI/1000024,1000037/
51382 C...COUNT THE NUMBER OF DECAY MODES
51390 TANW = SQRT(XW/XW1)
51392 C...1 OR 2 DEPENDING ON CHARGINO TYPE
51394 IF(KFIN.EQ.KFCCHI(2)) IX=2
51412 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
51413 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
51417 C...GRAVITINO DECAY MODES
51419 IF(IMSS(11).EQ.1) THEN
51422 XMGR=PMAS(PYCOMP(IDG),1)
51424 C COSW=SQRT(1D0-XW)
51425 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51426 IF(AXMI.GT.XMGR+XMW) THEN
51432 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
51433 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
51434 & (1D0-XMW2/XMI2)**4
51436 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
51441 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
51442 & (ABS(UMIXC(IX,2))*SBETA)**2))
51443 & *(1D0-PMAS(37,1)**2/XMI2)**4
51447 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51448 IF(IX.EQ.1) GOTO 170
51453 C...CHI_2+ -> CHI_1+ + Z0
51454 IF(AXMI.GE.AXMJ+XMZ) THEN
51457 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
51458 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
51459 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
51460 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
51461 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51462 GLR=DBLE(OLPP*DCONJG(ORPP))
51463 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
51464 IDLAM(LKNT,1)=KFCCHI(1)
51468 C...CHARGED LEPTONS
51469 ELSEIF(AXMI.GE.AXMJ) THEN
51471 S12MAX=(AXMI-AXMJ)**2
51474 EI=KCHG(IABS(IA),1)/3D0
51475 T3I=SIGN(1D0,EI+1D-6)/2D0
51480 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51485 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
51486 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
51487 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
51488 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
51489 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51490 CXC(2)=DCMPLX(0D0,0D0)
51491 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51492 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
51493 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51494 CXC(6)=DCMPLX(0D0,0D0)
51495 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51496 CXC(8)=DCMPLX(0D0,0D0)
51497 IF( XXC(5).LT.AXMI ) THEN
51502 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
51504 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51505 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51506 IDLAM(LKNT,1)=KFCCHI(1)
51509 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
51511 XLAM(LKNT)=XLAM(LKNT-1)
51512 IDLAM(LKNT,1)=KFCCHI(1)
51516 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
51518 XLAM(LKNT)=XLAM(LKNT-1)
51519 IDLAM(LKNT,1)=KFCCHI(1)
51529 EI=KCHG(IABS(IA),1)/3D0
51530 T3I=SIGN(1D0,EI+1D-6)/2D0
51531 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51533 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51534 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51535 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
51536 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51537 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51538 IF( XXC(5).LT.AXMI ) THEN
51543 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
51545 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51546 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51547 IDLAM(LKNT,1)=KFCCHI(1)
51551 XLAM(LKNT)=XLAM(LKNT-1)
51552 IDLAM(LKNT,1)=KFCCHI(1)
51556 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
51557 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51558 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51560 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51562 IF( XXC(5).LT.AXMI ) THEN
51567 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51568 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51569 IDLAM(LKNT,1)=KFCCHI(1)
51578 EI=KCHG(IABS(IA),1)/3D0
51579 T3I=SIGN(1D0,EI+1D-6)/2D0
51580 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51582 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51583 CXC(2)=DCMPLX(0D0,0D0)
51584 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51585 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
51586 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51587 CXC(6)=DCMPLX(0D0,0D0)
51588 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51589 CXC(8)=DCMPLX(0D0,0D0)
51590 IF( XXC(5).LT.AXMI ) THEN
51595 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51597 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51598 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51599 IDLAM(LKNT,1)=KFCCHI(1)
51602 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51604 XLAM(LKNT)=XLAM(LKNT-1)
51605 IDLAM(LKNT,1)=KFCCHI(1)
51610 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51611 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51612 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51614 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51616 IF( XXC(5).LT.AXMI ) THEN
51621 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51622 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51623 IDLAM(LKNT,1)=KFCCHI(1)
51632 EI=KCHG(IABS(IA),1)/3D0
51633 T3I=SIGN(1D0,EI+1D-6)/2D0
51634 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51636 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51637 CXC(2)=DCMPLX(0D0,0D0)
51638 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51639 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
51640 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51641 CXC(6)=DCMPLX(0D0,0D0)
51642 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51643 CXC(8)=DCMPLX(0D0,0D0)
51644 IF( XXC(5).LT.AXMI ) THEN
51649 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51651 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51652 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51653 IDLAM(LKNT,1)=KFCCHI(1)
51656 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51658 XLAM(LKNT)=XLAM(LKNT-1)
51659 IDLAM(LKNT,1)=KFCCHI(1)
51667 C...CHI_2+ -> CHI_1+ + H0_K
51675 XMH=PMAS(ITH(IH),1)
51677 C...NO 3-BODY OPTION
51678 IF(AXMI.GE.AXMJ+XMH) THEN
51680 XL=PYLAMF(XMI2,XMJ2,XMH2)
51681 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
51682 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
51683 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
51684 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
51686 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51687 GLR=DBLE(OLPP*DCONJG(ORPP))
51688 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
51689 IDLAM(LKNT,1)=KFCCHI(1)
51690 IDLAM(LKNT,2)=ITH(IH)
51695 C...CHI1 JUMPS TO HERE
51698 C...CHI+_I -> CHI0_J + W+
51703 IF(AXMI.GE.AXMJ+XMW) THEN
51706 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
51708 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
51709 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
51710 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
51711 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
51712 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
51713 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
51714 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
51715 IDLAM(LKNT,1)=KFNCHI(IJ)
51719 ELSEIF(AXMI.GE.AXMJ) THEN
51721 S12MAX=(AXMI-AXMJ)**2
51723 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
51725 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
51726 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
51727 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
51728 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
51729 CXC(5)=DCMPLX(0D0,0D0)
51730 CXC(7)=DCMPLX(0D0,0D0)
51734 T3I=SIGN(1D0,EI+1D-6)/2D0
51736 T3J=SIGN(1D0,EJ+1D-6)/2D0
51737 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
51738 & TANW+ZMIXC(IJ,2)*T3J)/SR2
51739 CXC(4)=-DCONJG(UMIXC(IX,1))*(
51740 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
51741 CXC(6)=DCMPLX(0D0,0D0)
51742 CXC(8)=DCMPLX(0D0,0D0)
51747 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51748 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51751 CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
51752 IF(XXC(5).LT.AXMI) THEN
51754 ELSEIF(XXC(6).LT.AXMI) THEN
51759 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
51760 C...--> 1/(16PI)/M**3*(AEM/XW)**2
51761 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
51763 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51764 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
51765 IDLAM(LKNT,1)=KFNCHI(IJ)
51768 C...ONLY DECAY CHI+1 -> E+ NU_E
51769 IF( IMSS(12).NE. 0 ) GOTO 260
51770 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
51772 XLAM(LKNT)=XLAM(LKNT-1)
51773 IDLAM(LKNT,1)=KFNCHI(IJ)
51778 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51780 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51781 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
51783 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
51785 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
51786 IF(XXC(5).LT.AXMI) THEN
51788 ELSEIF(XXC(6).LT.AXMI) THEN
51793 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51794 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
51795 IDLAM(LKNT,1)=KFNCHI(IJ)
51800 C...NOW, DO THE QUARKS
51805 T3I=SIGN(1D0,EI+1D-6)/2D0
51807 T3J=SIGN(1D0,EJ+1D-6)/2D0
51808 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
51809 & TANW+ZMIXC(IJ,2)*T3J)
51810 CXC(4)=-DCONJG(UMIXC(IX,1))*(
51811 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
51812 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51813 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51814 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
51815 IF(XXC(5).LT.AXMI) THEN
51818 IF(XXC(6).LT.AXMI) THEN
51823 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
51825 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51826 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51827 IDLAM(LKNT,1)=KFNCHI(IJ)
51830 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51832 XLAM(LKNT)=XLAM(LKNT-1)
51833 IDLAM(LKNT,1)=KFNCHI(IJ)
51842 C...CHI+_I -> CHI0_J + H+
51848 IF(AXMI.GE.AXMJ+XMHP) THEN
51850 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
51851 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
51852 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
51853 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
51855 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51856 GLR=DBLE(OLPP*DCONJG(ORPP))
51857 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
51858 IDLAM(LKNT,1)=KFNCHI(IJ)
51866 C...2-BODY DECAYS TO FERMION SFERMION
51868 IF(J.GE.7.AND.J.LE.10) GOTO 240
51869 IF(MOD(J,2).EQ.0) THEN
51875 XMSF1=PMAS(PYCOMP(KF1),1)
51876 XMSF2=PMAS(PYCOMP(KF2),1)
51885 IF(MOD(J,2).EQ.0) THEN
51888 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
51889 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
51895 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
51897 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
51902 IF(AXMI.GE.XMF+XMSF1) THEN
51906 XL=PYLAMF(XMI2,XMA2,XMB2)
51907 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
51908 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
51909 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51910 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51912 IF(MOD(J,2).EQ.0) THEN
51922 IF(AXMI.GE.XMF+XMSF2) THEN
51926 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
51927 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
51928 XL=PYLAMF(XMI2,XMA2,XMB2)
51929 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51930 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51932 IF(MOD(J,2).EQ.0) THEN
51942 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
51943 C...A 2-BODY -- 2-BODY CHAIN
51944 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
51945 IF(AXMI.GE.XMJ) THEN
51948 S12MAX=(AXMI-AXMJ)**2
51953 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
51954 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
51957 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
51959 CXC(1)=DCMPLX(0D0,0D0)
51960 CXC(3)=DCMPLX(0D0,0D0)
51961 CXC(5)=DCMPLX(0D0,0D0)
51962 CXC(7)=DCMPLX(0D0,0D0)
51963 CXC(2)=UMIXC(IX,1)*OLPP/SR2
51964 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
51965 CXC(6)=DCMPLX(0D0,0D0)
51966 CXC(8)=DCMPLX(0D0,0D0)
51967 IF(XXC(5).LT.AXMI) THEN
51969 ELSEIF(XXC(6).LT.AXMI) THEN
51974 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
51975 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
51977 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
51978 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51979 IDLAM(LKNT,1)=KSUSY1+21
51982 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51984 XLAM(LKNT)=XLAM(LKNT-1)
51985 IDLAM(LKNT,1)=KSUSY1+21
51993 C...R-violating decay modes (SKANDS).
51994 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
51999 XLAM(0)=XLAM(0)+XLAM(I)
52000 IF(XLAM(I).LT.0D0) THEN
52001 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
52002 & (IDLAM(I,J),J=1,3)
52006 IF(XLAM(0).EQ.0D0) THEN
52008 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
52009 WRITE(MSTU(11),*) LKNT
52010 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
52016 C*********************************************************************
52019 C...Used in the calculation of inoi -> inoj + f + ~f.
52023 C...Double precision and integer declarations.
52024 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52025 IMPLICIT INTEGER(I-N)
52026 INTEGER PYK,PYCHGE,PYCOMP
52027 C...Parameter statement to help give large particle numbers.
52028 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52029 &KEXCIT=4000000,KDIMEN=5000000)
52031 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52032 C COMMON/PYINTS/XXM(20)
52034 COMMON/PYINTC/XXC(10),CXC(8)
52035 SAVE /PYDAT1/,/PYINTC/
52037 C...Local variables.
52038 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
52039 DOUBLE PRECISION PYXXZ6,X
52040 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
52041 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
52042 DOUBLE PRECISION SIJ
52043 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
52044 DOUBLE PRECISION OL2
52045 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
52048 C...Statement functions.
52049 C...Integral from x to y of (t-a)(b-t) dt.
52050 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
52051 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
52052 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
52053 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
52054 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
52055 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
52056 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
52057 C...Integral from x to y of (t-a)/(b-t) dt.
52058 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
52059 C...Integral from x to y of 1/(t-a) dt.
52060 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
52068 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
52069 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
52070 &( (X-XM22-S)**2 -4D0*XM22*S ) )
52072 S23MIN=(S23AVE-S23DEL)
52073 S23MAX=(S23AVE+S23DEL)
52090 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
52091 SIJ=2D0*XXC(2)*XXC(4)*S13
52092 IF(XMV.LE.1000D0) THEN
52093 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
52094 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
52095 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
52096 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
52097 IF(XXC(5).LE.10000D0) THEN
52098 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
52099 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
52100 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
52101 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
52102 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
52103 & *(S13-XMV**2)/WPROP2
52108 IF(XXC(6).LE.10000D0) THEN
52109 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
52110 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
52111 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
52112 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
52113 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
52114 & *(S13-XMV**2)/WPROP2
52123 IF(XXC(5).LE.10000D0) THEN
52124 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
52125 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
52126 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
52127 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
52131 IF(XXC(6).LE.10000D0) THEN
52132 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
52133 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
52134 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
52135 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
52140 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
52142 IF(PYXXZ6.LT.0D0) THEN
52143 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
52144 WRITE(MSTU(11),*) (XXC(I),I=1,5)
52145 WRITE(MSTU(11),*) (XXC(I),I=6,10)
52146 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
52147 WRITE(MSTU(11),*) S23MIN,S23MAX
52155 C*********************************************************************
52158 C...Calculates chi0_i -> chi0_j + gamma.
52160 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
52162 C...Double precision and integer declarations.
52163 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52164 IMPLICIT INTEGER(I-N)
52165 INTEGER PYK,PYCHGE,PYCOMP
52167 C...Local variables.
52168 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
52169 DOUBLE PRECISION F1,F2
52171 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
52172 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
52173 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
52174 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
52179 C*********************************************************************
52182 C...Calculates the decay rate for ino -> ino + gauge boson.
52184 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
52186 C...Double precision and integer declarations.
52187 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52188 IMPLICIT INTEGER(I-N)
52189 INTEGER PYK,PYCHGE,PYCOMP
52191 C...Local variables.
52192 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
52193 DOUBLE PRECISION XL,PYLAMF,C1
52194 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
52200 XL=PYLAMF(XMI2,XMJ2,XMV2)
52201 PYX2XG=C1/8D0/XMI3*SQRT(XL)
52202 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
52203 &12D0*GLR*XM1*XM2*XMV2)
52208 C*********************************************************************
52211 C...Calculates the decay rate for ino -> ino + H.
52213 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
52215 C...Double precision and integer declarations.
52216 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52217 IMPLICIT INTEGER(I-N)
52218 INTEGER PYK,PYCHGE,PYCOMP
52220 C...Local variables.
52221 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
52222 DOUBLE PRECISION XL,PYLAMF,C1
52223 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
52229 XL=PYLAMF(XMI2,XMJ2,XMV2)
52230 PYX2XH=C1/8D0/XMI3*SQRT(XL)
52231 &*(GX2*(XMI2+XMJ2-XMV2)+
52237 C*********************************************************************
52240 C...Calculates the non-standard decay modes of the Higgs boson.
52242 C...Author: Stephen Mrenna
52243 C...Last Update: April 2001
52244 C......Allow complex values for Z,U, and V
52246 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
52248 C...Double precision and integer declarations.
52249 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52250 IMPLICIT INTEGER(I-N)
52251 INTEGER PYK,PYCHGE,PYCOMP
52252 C...Parameter statement to help give large particle numbers.
52253 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52254 &KEXCIT=4000000,KDIMEN=5000000)
52256 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52257 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52258 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
52259 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52260 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52261 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52262 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
52264 C...Local variables.
52265 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
52266 COMPLEX*16 QIJ,RIJ,F21K,F12K
52268 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
52269 DOUBLE PRECISION XMI2,XMI3,XMJ2
52270 DOUBLE PRECISION PYLAMF,XL,CF,EI
52272 DOUBLE PRECISION TANW,XW,AEM,C1,AS
52273 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
52274 DOUBLE PRECISION XLAM(0:400)
52275 INTEGER IDLAM(400,3)
52276 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
52278 INTEGER KFNCHI(4),KFCCHI(2)
52279 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
52280 DOUBLE PRECISION SR2
52281 DOUBLE PRECISION BETA,ALFA
52282 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
52283 DOUBLE PRECISION PYALEM
52284 DOUBLE PRECISION AL,AR,ALR
52285 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
52286 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
52287 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
52288 DATA ITH/25,35,36,37/
52289 DATA ETAH/1D0,1D0,-1D0/
52290 DATA SR2/1.4142136D0/
52291 DATA KFNCHI/1000022,1000023,1000025,1000035/
52292 DATA KFCCHI/1000024,1000037/
52294 C...COUNT THE NUMBER OF DECAY MODES
52301 TANW = SQRT(XW/(1D0-XW))
52304 C...1 - 4 DEPENDING ON Higgs species.
52306 IF(KFIN.EQ.ITH(2)) IH=2
52307 IF(KFIN.EQ.ITH(3)) IH=3
52308 IF(KFIN.EQ.ITH(4)) IH=4
52331 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
52336 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52337 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52342 IF(IH.EQ.4) GOTO 220
52344 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52345 C...H0_K -> CHI0_I + CHI0_J
52358 IF(AXMI.GE.AXMJ+AXMK) THEN
52360 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
52361 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
52362 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
52363 & ZMIXC(IJ,3)*ZMIXC(IK,1))
52364 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
52365 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
52366 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
52367 & ZMIXC(IJ,4)*ZMIXC(IK,1))
52368 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
52369 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
52370 C...SIGN OF MASSES I,J
52372 GX2=ABS(F12K)**2+ABS(F21K)**2
52373 GLR=DBLE(F12K*DCONJG(F21K))
52374 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
52375 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
52376 IDLAM(LKNT,1)=KFNCHI(IJ)
52377 IDLAM(LKNT,2)=KFNCHI(IK)
52383 C...H0_K -> CHI+_I CHI-_J
52390 IF(AXMI.GE.AXMJ+AXMK) THEN
52392 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
52393 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
52394 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
52395 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
52396 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52397 GLR=DBLE(OLPP*DCONJG(ORPP))
52399 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
52400 IDLAM(LKNT,1)=KFCCHI(IJ)
52401 IDLAM(LKNT,2)=-KFCCHI(IK)
52407 C...HIGGS TO SFERMION SFERMION
52409 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
52411 XMJL=PMAS(PYCOMP(IJ),1)
52412 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
52413 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
52416 XL=PYLAMF(XMI2,XMJ2,XMJ2)
52423 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
52424 & XMF**2/XMW*SINA/CBETA
52425 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
52426 & XMF**2/XMW*SINA/CBETA
52428 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
52430 ELSEIF(IFL.EQ.15) THEN
52431 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
52437 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
52438 & XMF**2/XMW*COSA/SBETA
52439 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
52440 & XMF**2/XMW*COSA/SBETA
52442 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
52449 ELSEIF(IH.EQ.2) THEN
52451 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
52452 & XMF**2/XMW*COSA/CBETA
52453 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
52454 & XMF**2/XMW*COSA/CBETA
52456 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
52458 ELSEIF(IFL.EQ.15) THEN
52459 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
52465 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
52466 & XMF**2/XMW*SINA/SBETA
52467 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
52468 & XMF**2/XMW*SINA/SBETA
52470 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
52477 ELSEIF(IH.EQ.3) THEN
52483 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
52484 ELSEIF(IFL.EQ.15) THEN
52485 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
52489 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
52493 IF(IH.EQ.3) GOTO 180
52497 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
52504 IF(AXMI.GE.2D0*XMJ) THEN
52506 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52508 & +2D0*GHLR*ALR)**2
52514 IF(AXMI.GE.2D0*XMJR) THEN
52518 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
52521 XL=PYLAMF(XMI2,XMJ2,XMJ2)
52522 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52524 & +2D0*GHLR*ALR)**2
52525 IDLAM(LKNT,1)=IJ+KSUSY1
52526 IDLAM(LKNT,2)=-(IJ+KSUSY1)
52531 IF(AXMI.GE.XMJL+XMJR) THEN
52533 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
52534 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
52535 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
52538 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
52539 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52540 & (GHLL*AL+GHRR*AR)**2
52542 IDLAM(LKNT,2)=-(IJ+KSUSY1)
52546 IDLAM(LKNT,2)=IJ+KSUSY1
52548 XLAM(LKNT)=XLAM(LKNT-1)
52558 C...H+ -> CHI+_I + CHI0_J
52566 IF(AXMI.GE.AXMJ+AXMK) THEN
52568 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
52569 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
52570 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
52571 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
52572 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52573 GLR=DBLE(OLPP*DCONJG(ORPP))
52574 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
52575 IDLAM(LKNT,1)=KFNCHI(IJ)
52576 IDLAM(LKNT,2)=KFCCHI(IK)
52582 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
52583 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
52589 XM1=PMAS(PYCOMP(KSUSY1+6),1)
52590 XM2=PMAS(PYCOMP(KSUSY1+5),1)
52591 IF(XMI.GE.XM1+XM2) THEN
52592 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52594 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52595 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
52596 IDLAM(LKNT,1)=KSUSY1+6
52597 IDLAM(LKNT,2)=-(KSUSY1+5)
52602 XM1=PMAS(PYCOMP(KSUSY2+6),1)
52603 XM2=PMAS(PYCOMP(KSUSY1+5),1)
52604 IF(XMI.GE.XM1+XM2) THEN
52605 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52607 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52608 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
52609 IDLAM(LKNT,1)=KSUSY2+6
52610 IDLAM(LKNT,2)=-(KSUSY1+5)
52615 XM1=PMAS(PYCOMP(KSUSY1+6),1)
52616 XM2=PMAS(PYCOMP(KSUSY2+5),1)
52617 IF(XMI.GE.XM1+XM2) THEN
52618 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52620 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52621 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
52622 IDLAM(LKNT,1)=KSUSY1+6
52623 IDLAM(LKNT,2)=-(KSUSY2+5)
52628 XM1=PMAS(PYCOMP(KSUSY2+6),1)
52629 XM2=PMAS(PYCOMP(KSUSY2+5),1)
52630 IF(XMI.GE.XM1+XM2) THEN
52631 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52633 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52634 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
52635 IDLAM(LKNT,1)=KSUSY2+6
52636 IDLAM(LKNT,2)=-(KSUSY2+5)
52641 GL=-XMW/SR2*SIN(2D0*BETA)
52643 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
52644 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
52645 IF(XMI.GE.XM1+XM2) THEN
52646 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52648 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
52649 IDLAM(LKNT,1)=-(KSUSY1+IJ)
52650 IDLAM(LKNT,2)=KSUSY1+IJ+1
52658 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
52659 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
52660 IF(XMI.GE.XM1+XM2) THEN
52661 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52663 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
52664 IDLAM(LKNT,1)=-(KSUSY1+IJ)
52665 IDLAM(LKNT,2)=KSUSY1+IJ+1
52670 C...H+ -> TAU1 NUTAUL
52671 XM1=PMAS(PYCOMP(KSUSY1+15),1)
52672 XM2=PMAS(PYCOMP(KSUSY1+16),1)
52673 IF(XMI.GE.XM1+XM2) THEN
52674 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52676 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
52677 IDLAM(LKNT,1)=-(KSUSY1+15)
52678 IDLAM(LKNT,2)= KSUSY1+16
52682 C...H+ -> TAU2 NUTAUL
52683 XM1=PMAS(PYCOMP(KSUSY2+15),1)
52684 XM2=PMAS(PYCOMP(KSUSY1+16),1)
52685 IF(XMI.GE.XM1+XM2) THEN
52686 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52688 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
52689 IDLAM(LKNT,1)=-(KSUSY2+15)
52690 IDLAM(LKNT,2)= KSUSY1+16
52698 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
52699 XLAM(0)=XLAM(0)+XLAM(I)
52701 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
52706 C*********************************************************************
52709 C...Calculates the decay rate for a Higgs to an ino pair.
52711 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
52713 C...Double precision and integer declarations.
52714 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52715 IMPLICIT INTEGER(I-N)
52716 INTEGER PYK,PYCHGE,PYCOMP
52718 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52721 C...Local variables.
52722 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
52723 DOUBLE PRECISION XL,PYLAMF,C1
52724 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
52730 XL=PYLAMF(XMI2,XMJ2,XMK2)
52731 PYH2XX=C1/4D0/XMI3*SQRT(XL)
52732 &*(GX2*(XMI2-XMJ2-XMK2)-
52734 IF(PYH2XX.LT.0D0) PYH2XX=0D0
52739 C*********************************************************************
52742 C...Integration by adaptive Gaussian quadrature.
52743 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
52745 FUNCTION PYGAUS(F, A, B, EPS)
52747 C...Double precision and integer declarations.
52748 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52749 IMPLICIT INTEGER(I-N)
52750 INTEGER PYK,PYCHGE,PYCOMP
52752 C...Local declarations.
52754 DOUBLE PRECISION F,W(12), X(12)
52755 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
52756 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
52757 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
52758 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
52759 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
52760 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
52761 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
52762 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
52763 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
52764 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
52765 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
52766 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
52768 C...The Gaussian quadrature algorithm.
52770 IF(B .EQ. A) GOTO 140
52771 CONST = 5D-3 / ABS(B-A)
52782 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
52787 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
52790 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
52792 IF(BB .NE. B) GOTO 100
52795 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
52797 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
52806 C*********************************************************************
52809 C...Integration by adaptive Gaussian quadrature.
52810 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
52811 C...Carbon copy of PYGAUS, but avoids having to use it recursively.
52813 FUNCTION PYGAU2(F, A, B, EPS)
52815 C...Double precision and integer declarations.
52816 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52817 IMPLICIT INTEGER(I-N)
52818 INTEGER PYK,PYCHGE,PYCOMP
52820 C...Local declarations.
52822 DOUBLE PRECISION F,W(12), X(12)
52823 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
52824 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
52825 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
52826 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
52827 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
52828 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
52829 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
52830 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
52831 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
52832 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
52833 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
52834 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
52836 C...The Gaussian quadrature algorithm.
52838 IF(B .EQ. A) GOTO 140
52839 CONST = 5D-3 / ABS(B-A)
52850 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
52855 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
52858 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
52860 IF(BB .NE. B) GOTO 100
52863 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
52865 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
52874 C*********************************************************************
52877 C...Simpson formula for an integral.
52879 FUNCTION PYSIMP(Y,X0,X1,N)
52881 C...Double precision and integer declarations.
52882 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52883 IMPLICIT INTEGER(I-N)
52884 INTEGER PYK,PYCHGE,PYCOMP
52886 C...Local variables.
52887 DOUBLE PRECISION Y,X0,X1,H,S
52893 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
52900 C*********************************************************************
52903 C...The standard lambda function.
52905 FUNCTION PYLAMF(X,Y,Z)
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
52912 C...Local variables.
52913 DOUBLE PRECISION PYLAMF,X,Y,Z
52915 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
52916 IF(PYLAMF.LT.0D0) PYLAMF=0D0
52921 C*********************************************************************
52924 C...Generates 3-body decays of gauginos.
52926 SUBROUTINE PYTBDY(IDIN)
52928 C...Double precision and integer declarations.
52929 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52930 IMPLICIT INTEGER(I-N)
52931 INTEGER PYK,PYCHGE,PYCOMP
52932 C...Parameter statement to help give large particle numbers.
52933 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52934 &KEXCIT=4000000,KDIMEN=5000000)
52936 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52937 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52938 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52939 C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
52940 C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
52941 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52942 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52943 C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
52944 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
52946 C...Local variables.
52947 DOUBLE PRECISION XM(5)
52948 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
52949 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
52950 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
52951 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
52952 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
52953 DOUBLE PRECISION CPHI1,SPHI1
52954 DOUBLE PRECISION S23DEL,EPS
52955 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
52956 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
52957 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
52959 DATA INOID/22,23,25,35/
52970 S12MIN=(XM(1)+XM(2))**2
52971 S12MAX=(XM(5)-XM(3))**2
52972 YJACO1=S12MAX-S12MIN
52974 C...Initialize some parameters
52986 C...Mrenna: check that we are indeed decaying a SUSY particle
52987 IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
52991 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
52992 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
52994 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
52995 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
52996 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
52997 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
53000 EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
53001 T3I=SIGN(1D0,EI+1D-6)/2D0
53004 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
53006 ELSEIF(IZID1*IZID2.NE.0) THEN
53008 GMMZ=PMAS(23,1)*PMAS(23,2)
53010 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
53011 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
53013 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
53014 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
53016 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
53018 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
53020 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
53021 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
53022 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
53023 XM1M2=SMZ(IZID1)*SMZ(IZID2)
53024 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
53026 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
53028 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
53030 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
53032 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
53033 IF(IZID1.NE.0) THEN
53034 XM1M2=SMZ(IZID1)*SMW(IWID2)
53038 XM1M2=SMZ(IZID2)*SMW(IWID1)
53041 RT2I = 1D0/SQRT(2D0)
53043 GMMZ=PMAS(24,1)*PMAS(24,2)
53045 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
53046 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
53049 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
53051 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
53052 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
53053 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
53054 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
53055 EJ=KCHG(IABS(JA),1)/3D0
53056 T3J=SIGN(1D0,EJ+1D-6)/2D0
53057 QRLS=DCMPLX(0D0,0D0)
53063 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
53064 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
53065 IF(MOD(IA,2).EQ.0) THEN
53066 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
53067 & TANW+ZMIXC(IZID2,2)*T3I)
53068 QLRT=-DCONJG(UMIXC(IZID1,1))*(
53069 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
53071 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
53072 & TANW+ZMIXC(IZID2,2)*T3J)
53073 QLRT=-DCONJG(UMIXC(IZID1,1))*(
53074 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
53076 ELSEIF(IWID1*IWID2.NE.0) THEN
53079 XM1M2=SMW(IWID1)*SMW(IWID2)
53081 GMMZ=PMAS(23,1)*PMAS(23,2)
53083 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
53084 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
53085 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
53086 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
53088 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
53089 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
53090 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
53091 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
53092 QRLS=-DCMPLX(EI/XW1)*ORPP
53093 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53094 QRRS=-DCMPLX(EI/XW1)*OLPP
53095 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53096 IF(MOD(IA,2).EQ.0) THEN
53097 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
53098 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
53100 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
53101 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
53103 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
53110 IF(ISKIP.NE.0) THEN
53113 S12=S12MIN+YJACO1*(KT-1)/99
53114 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
53115 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
53116 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
53117 & -(2D0*XM(1)*XM(2))**2
53118 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
53119 & -(2D0*XM(3)*XM(5))**2
53122 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
53124 S23MIN=S23AVE-S23DEL
53125 S23MAX=S23AVE+S23DEL
53126 YJACO2=S23MAX-S23MIN
53129 S23=S23MIN+YJACO2*(KS-1)/99
53132 WU2 = (UH-ZM12)*(UH-ZM22)
53133 WT2 = (TH-ZM12)*(TH-ZM22)
53135 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
53136 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
53137 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
53138 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
53139 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
53140 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
53141 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
53142 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
53143 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
53144 IF(WT0.GT.WTMAX) WTMAX=WT0
53154 BX=S12MIN+0.5D0*YJACO1
53157 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
53165 C...SOLVE FOR F1 AND F2
53166 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
53167 &-(2D0*XM(1)*XM(2))**2
53168 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
53169 &-(2D0*XM(3)*XM(5))**2
53172 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
53174 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
53175 &-(2D0*XM(1)*XM(2))**2
53176 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
53177 &-(2D0*XM(3)*XM(5))**2
53180 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
53183 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
53184 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
53190 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
53191 & -(2D0*XM(1)*XM(2))**2
53192 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
53193 & -(2D0*XM(3)*XM(5))**2
53196 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
53203 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
53204 & -(2D0*XM(1)*XM(2))**2
53205 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
53206 & -(2D0*XM(3)*XM(5))**2
53209 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
53214 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
53224 180 S12=S12MIN+PYR(0)*YJACO1
53227 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
53228 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
53229 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
53230 &-(2D0*XM(1)*XM(2))**2
53231 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
53232 &-(2D0*XM(3)*XM(5))**2
53235 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
53237 S23MIN=S23AVE-S23DEL
53238 S23MAX=S23AVE+S23DEL
53239 YJACO2=S23MAX-S23MIN
53240 S23=S23MIN+PYR(0)*YJACO2
53242 C...CHECK THE SAMPLING
53243 IF(IKNT.GT.100) THEN
53244 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
53247 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
53249 IF(ISKIP.EQ.0) GOTO 190
53255 WU2 = (UH-ZM12)*(UH-ZM22)
53256 WT2 = (TH-ZM12)*(TH-ZM22)
53258 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
53259 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
53261 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
53262 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
53263 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
53264 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
53265 c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
53266 c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
53267 c &/DCMPLX(TH-XML2)
53268 c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
53269 c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
53270 c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
53271 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
53272 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
53273 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
53275 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
53276 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
53278 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
53279 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
53281 P1=SQRT(D1*D1-XM(1)**2)
53282 P2=SQRT(D2*D2-XM(2)**2)
53283 P3=SQRT(D3*D3-XM(3)**2)
53284 CTHE1=2D0*PYR(0)-1D0
53285 ANG1=2D0*PYR(0)*PARU(1)
53289 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
53291 P(N+1,1)=P1*STHE1*CPHI1
53292 P(N+1,2)=P1*STHE1*SPHI1
53297 ANG3=2D0*PYR(0)*PARU(1)
53300 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
53302 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
53304 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
53305 &+P3*STHE3*SPHI3*SPHI1
53306 &+P3*CTHE3*STHE1*CPHI1
53307 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
53308 &-P3*STHE3*SPHI3*CPHI1
53309 &+P3*CTHE3*STHE1*SPHI1
53310 P(N+3,3)=P3*STHE3*CPHI3*STHE1
53315 P(N+2,I)=-P(N+1,I)-P(N+3,I)
53323 C*********************************************************************
53326 C...Finds the s-hat dependent eigenvalues of the inverse propagator
53327 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
53328 C...phase space generation. Extended to include techni-a meson, and
53329 C...to return the width.
53331 SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
53333 C...Double precision and integer declarations.
53334 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53335 IMPLICIT INTEGER(I-N)
53336 INTEGER PYK,PYCHGE,PYCOMP
53337 C...Parameter statement to help give large particle numbers.
53338 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53339 &KEXCIT=4000000,KDIMEN=5000000)
53341 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53342 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53343 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53344 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
53345 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
53347 C...Local variables.
53348 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
53349 &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
53350 &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
53357 SINW=MIN(SQRT(PARU(102)),1D0)
53358 COSW=SQRT(1D0-SINW**2)
53360 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
53361 QUPD=2D0*RTCM(2)-1D0
53363 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
53364 FAR=SQRT(AEM/ALPRHT)
53368 FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
53381 AR(2,2) = SH-PMAS(23,1)**2
53382 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
53383 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
53384 AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
53405 CALL PYWIDT(23,SH,WDTP,WDTE)
53406 AT(2,2) = WDTP(0)*SHR
53407 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
53408 AT(3,3) = WDTP(0)*SHR
53409 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
53410 AT(4,4) = WDTP(0)*SHR
53411 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
53412 AT(5,5) = WDTP(0)*SHR
53416 AR(1,1) = SH-PMAS(24,1)**2
53417 AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
53418 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
53425 CALL PYWIDT(24,SH,WDTP,WDTE)
53426 AT(1,1) = WDTP(0)*SHR
53427 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
53428 AT(2,2) = WDTP(0)*SHR
53429 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
53430 AT(3,3) = WDTP(0)*SHR
53433 CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
53438 WX(I)=SQRT(ABS(SH-WR(I)))
53440 IF(WR(I).LT.SXMN) THEN
53451 C*********************************************************************
53454 C...Finds eigenvalues of a general complex matrix
53456 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
53457 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
53458 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
53459 C OF A COMPLEX GENERAL MATRIX.
53463 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
53464 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53465 C DIMENSION STATEMENT.
53467 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
53469 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
53470 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
53472 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
53473 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
53474 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
53478 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
53479 C RESPECTIVELY, OF THE EIGENVALUES.
53481 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
53482 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
53484 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
53485 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
53486 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
53488 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
53490 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53491 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53493 C THIS VERSION DATED AUGUST 1983.
53496 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
53498 INTEGER N,NM,IS1,IS2,IERR,MATZ
53499 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
53500 X FV1(5),FV2(5),FV3(5)
53501 IF (N .LE. NM) GOTO 100
53505 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
53506 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
53507 IF (MATZ .NE. 0) GOTO 110
53508 C .......... FIND EIGENVALUES ONLY ..........
53509 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
53511 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
53512 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
53513 IF (IERR .NE. 0) GOTO 120
53514 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
53518 C*********************************************************************
53521 C...Auxiliary to PYEICG.
53523 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
53524 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
53526 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
53527 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
53528 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
53530 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
53531 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
53535 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53536 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53537 C DIMENSION STATEMENT.
53539 C N IS THE ORDER OF THE MATRIX.
53541 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
53542 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
53543 C SET LOW=1, IGH=N.
53545 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
53546 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
53547 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
53548 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
53549 C THE REDUCTION BY CORTH, IF PERFORMED.
53553 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
53554 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
53555 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
53556 C EIGENVECTORS IS TO BE PERFORMED.
53558 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
53559 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
53560 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
53561 C FOR INDICES IERR+1,...,N.
53564 C ZERO FOR NORMAL RETURN,
53565 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
53566 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
53568 C CALLS PYCDIV FOR COMPLEX DIVISION.
53569 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
53570 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
53572 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53573 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53575 C THIS VERSION DATED AUGUST 1983.
53578 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
53580 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
53581 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
53582 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
53586 IF (LOW .EQ. IGH) GOTO 130
53587 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
53592 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
53593 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
53594 YR = HR(I,I-1) / NORM
53595 YI = HI(I,I-1) / NORM
53600 SI = YR * HI(I,J) - YI * HR(I,J)
53601 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
53606 SI = YR * HI(J,I) + YI * HR(J,I)
53607 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
53612 C .......... STORE ROOTS ISOLATED BY CBAL ..........
53613 130 DO 140 I = 1, N
53614 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
53623 C .......... SEARCH FOR NEXT EIGENVALUE ..........
53624 150 IF (EN .LT. LOW) GOTO 320
53627 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
53628 C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
53629 160 DO 170 LL = LOW, EN
53631 IF (L .EQ. LOW) GOTO 180
53632 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
53633 X + DABS(HR(L,L)) + DABS(HI(L,L))
53634 TST2 = TST1 + DABS(HR(L,L-1))
53635 IF (TST2 .EQ. TST1) GOTO 180
53637 C .......... FORM SHIFT ..........
53638 180 IF (L .EQ. EN) GOTO 300
53639 IF (ITN .EQ. 0) GOTO 310
53640 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
53643 XR = HR(ENM1,EN) * HR(EN,ENM1)
53644 XI = HI(ENM1,EN) * HR(EN,ENM1)
53645 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
53646 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
53647 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
53648 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
53649 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
53652 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
53656 C .......... FORM EXCEPTIONAL SHIFT ..........
53657 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
53660 210 DO 220 I = LOW, EN
53661 HR(I,I) = HR(I,I) - SR
53662 HI(I,I) = HI(I,I) - SI
53669 C .......... REDUCE TO TRIANGLE (ROWS) ..........
53675 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
53676 XR = HR(I-1,I-1) / NORM
53678 XI = HI(I-1,I-1) / NORM
53681 HI(I-1,I-1) = 0.0D0
53682 HI(I,I-1) = SR / NORM
53689 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
53690 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
53691 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
53692 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
53698 IF (SI .EQ. 0.0D0) GOTO 250
53699 NORM = PYTHAG(HR(EN,EN),SI)
53700 SR = HR(EN,EN) / NORM
53704 C .......... INVERSE OPERATION (COLUMNS) ..........
53705 250 DO 280 J = LP1, EN
53714 IF (I .EQ. J) GOTO 260
53716 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
53717 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
53718 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
53719 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
53724 IF (SI .EQ. 0.0D0) GOTO 160
53729 HR(I,EN) = SR * YR - SI * YI
53730 HI(I,EN) = SR * YI + SI * YR
53734 C .......... A ROOT FOUND ..........
53735 300 WR(EN) = HR(EN,EN) + TR
53736 WI(EN) = HI(EN,EN) + TI
53739 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
53740 C CONVERGED AFTER 30*N ITERATIONS ..........
53745 C*********************************************************************
53748 C...Auxiliary to PYEICG.
53750 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
53751 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
53753 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
53754 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
53755 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
53757 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
53758 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
53759 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
53760 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
53761 C THIS GENERAL MATRIX TO HESSENBERG FORM.
53765 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53766 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53767 C DIMENSION STATEMENT.
53769 C N IS THE ORDER OF THE MATRIX.
53771 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
53772 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
53773 C SET LOW=1, IGH=N.
53775 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
53776 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
53777 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
53778 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
53779 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
53781 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
53782 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
53783 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
53784 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
53785 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
53786 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
53791 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
53792 C HAVE BEEN DESTROYED.
53794 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
53795 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
53796 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
53797 C FOR INDICES IERR+1,...,N.
53799 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
53800 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
53801 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
53802 C THE EIGENVECTORS HAS BEEN FOUND.
53805 C ZERO FOR NORMAL RETURN,
53806 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
53807 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
53809 C CALLS PYCDIV FOR COMPLEX DIVISION.
53810 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
53811 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
53813 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53814 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53816 C THIS VERSION DATED OCTOBER 1989.
53818 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
53819 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
53822 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
53824 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
53825 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
53826 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
53828 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
53832 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
53841 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
53842 C FROM THE INFORMATION LEFT BY CORTH ..........
53843 IEND = IGH - LOW - 1
53844 IF (IEND.LT.0) GOTO 220
53845 IF (IEND.EQ.0) GOTO 170
53846 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
53847 DO 160 II = 1, IEND
53849 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
53850 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
53851 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
53852 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
53855 DO 120 K = IP1, IGH
53856 ORTR(K) = HR(K,I-1)
53857 ORTI(K) = HI(K,I-1)
53865 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
53866 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
53873 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
53874 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
53880 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
53885 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
53886 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
53887 YR = HR(I,I-1) / NORM
53888 YI = HI(I,I-1) / NORM
53893 SI = YR * HI(I,J) - YI * HR(I,J)
53894 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
53899 SI = YR * HI(J,I) + YI * HR(J,I)
53900 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
53904 DO 200 J = LOW, IGH
53905 SI = YR * ZI(J,I) + YI * ZR(J,I)
53906 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
53911 C .......... STORE ROOTS ISOLATED BY CBAL ..........
53912 220 DO 230 I = 1, N
53913 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
53922 C .......... SEARCH FOR NEXT EIGENVALUE ..........
53923 240 IF (EN .LT. LOW) GOTO 430
53926 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
53927 C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
53928 250 DO 260 LL = LOW, EN
53930 IF (L .EQ. LOW) GOTO 270
53931 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
53932 X + DABS(HR(L,L)) + DABS(HI(L,L))
53933 TST2 = TST1 + DABS(HR(L,L-1))
53934 IF (TST2 .EQ. TST1) GOTO 270
53936 C .......... FORM SHIFT ..........
53937 270 IF (L .EQ. EN) GOTO 420
53938 IF (ITN .EQ. 0) GOTO 550
53939 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
53942 XR = HR(ENM1,EN) * HR(EN,ENM1)
53943 XI = HI(ENM1,EN) * HR(EN,ENM1)
53944 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
53945 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
53946 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
53947 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
53948 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
53951 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
53955 C .......... FORM EXCEPTIONAL SHIFT ..........
53956 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
53959 300 DO 310 I = LOW, EN
53960 HR(I,I) = HR(I,I) - SR
53961 HI(I,I) = HI(I,I) - SI
53968 C .......... REDUCE TO TRIANGLE (ROWS) ..........
53974 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
53975 XR = HR(I-1,I-1) / NORM
53977 XI = HI(I-1,I-1) / NORM
53980 HI(I-1,I-1) = 0.0D0
53981 HI(I,I-1) = SR / NORM
53988 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
53989 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
53990 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
53991 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
53997 IF (SI .EQ. 0.0D0) GOTO 350
53998 NORM = PYTHAG(HR(EN,EN),SI)
53999 SR = HR(EN,EN) / NORM
54003 IF (EN .EQ. N) GOTO 350
54009 HR(EN,J) = SR * YR + SI * YI
54010 HI(EN,J) = SR * YI - SI * YR
54012 C .......... INVERSE OPERATION (COLUMNS) ..........
54013 350 DO 390 J = LP1, EN
54022 IF (I .EQ. J) GOTO 360
54024 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
54025 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
54026 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
54027 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
54030 DO 380 I = LOW, IGH
54035 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
54036 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
54037 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
54038 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
54043 IF (SI .EQ. 0.0D0) GOTO 250
54048 HR(I,EN) = SR * YR - SI * YI
54049 HI(I,EN) = SR * YI + SI * YR
54052 DO 410 I = LOW, IGH
54055 ZR(I,EN) = SR * YR - SI * YI
54056 ZI(I,EN) = SR * YI + SI * YR
54060 C .......... A ROOT FOUND ..........
54061 420 HR(EN,EN) = HR(EN,EN) + TR
54063 HI(EN,EN) = HI(EN,EN) + TI
54067 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
54068 C VECTORS OF UPPER TRIANGULAR FORM ..........
54074 TR = DABS(HR(I,J)) + DABS(HI(I,J))
54075 IF (TR .GT. NORM) NORM = TR
54078 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
54079 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
54087 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
54088 DO 490 II = 1, ENM1
54095 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
54096 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
54101 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
54104 460 YR = 0.01D0 * YR
54106 IF (TST2 .GT. TST1) GOTO 460
54108 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
54109 C .......... OVERFLOW CONTROL ..........
54110 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
54111 IF (TR .EQ. 0.0D0) GOTO 490
54113 TST2 = TST1 + 1.0D0/TST1
54114 IF (TST2 .GT. TST1) GOTO 490
54116 HR(J,EN) = HR(J,EN)/TR
54117 HI(J,EN) = HI(J,EN)/TR
54123 C .......... END BACKSUBSTITUTION ..........
54124 C .......... VECTORS OF ISOLATED ROOTS ..........
54126 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
54134 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
54135 C VECTORS OF ORIGINAL FULL MATRIX.
54136 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
54141 DO 540 I = LOW, IGH
54146 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
54147 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
54155 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
54156 C CONVERGED AFTER 30*N ITERATIONS ..........
54161 C*********************************************************************
54164 C...Auxiliary to PYCMQR
54166 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
54169 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
54171 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
54172 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
54174 S = DABS(BR) + DABS(BI)
54179 S = BRS**2 + BIS**2
54180 CR = (ARS*BRS + AIS*BIS)/S
54181 CI = (AIS*BRS - ARS*BIS)/S
54185 C*********************************************************************
54188 C...Auxiliary to PYCMQR
54190 C (YR,YI) = COMPLEX DSQRT(XR,XI)
54191 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
54194 SUBROUTINE PYCSRT(XR,XI,YR,YI)
54196 DOUBLE PRECISION XR,XI,YR,YI
54197 DOUBLE PRECISION S,TR,TI,PYTHAG
54201 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
54202 IF (TR .GE. 0.0D0) YR = S
54203 IF (TI .LT. 0.0D0) S = -S
54204 IF (TR .LE. 0.0D0) YI = S
54205 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
54206 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
54210 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
54211 DOUBLE PRECISION A,B
54213 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
54215 DOUBLE PRECISION P,R,S,T,U
54216 P = DMAX1(DABS(A),DABS(B))
54217 IF (P .EQ. 0.0D0) GOTO 110
54218 R = (DMIN1(DABS(A),DABS(B))/P)**2
54221 IF (T .EQ. 4.0D0) GOTO 110
54223 U = 1.0D0 + 2.0D0*S
54231 C*********************************************************************
54234 C...Auxiliary to PYEICG
54236 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
54237 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
54238 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
54239 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
54241 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
54242 C EIGENVALUES WHENEVER POSSIBLE.
54246 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
54247 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
54248 C DIMENSION STATEMENT.
54250 C N IS THE ORDER OF THE MATRIX.
54252 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54253 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
54257 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54258 C RESPECTIVELY, OF THE BALANCED MATRIX.
54260 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
54261 C ARE EQUAL TO ZERO IF
54262 C (1) I IS GREATER THAN J AND
54263 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
54265 C SCALE CONTAINS INFORMATION DETERMINING THE
54266 C PERMUTATIONS AND SCALING FACTORS USED.
54268 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
54269 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
54270 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
54271 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
54272 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
54273 C = D(J,J) J = LOW,...,IGH
54274 C = P(J) J = IGH+1,...,N.
54275 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
54278 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
54280 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
54281 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
54282 C K,L HAVE BEEN REVERSED.)
54284 C ARITHMETIC IS REAL THROUGHOUT.
54286 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
54287 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
54289 C THIS VERSION DATED AUGUST 1983.
54292 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
54294 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
54295 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
54296 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
54305 C .......... IN-LINE PROCEDURE FOR ROW AND
54306 C COLUMN EXCHANGE ..........
54308 IF (J .EQ. M) GOTO 130
54328 130 IF(IEXC.EQ.1) GOTO 140
54329 IF(IEXC.EQ.2) GOTO 180
54330 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
54331 C AND PUSH THEM DOWN ..........
54332 140 IF (L .EQ. 1) GOTO 320
54334 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
54335 150 DO 170 JJ = 1, L
54339 IF (I .EQ. J) GOTO 160
54340 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
54349 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
54350 C AND PUSH THEM LEFT ..........
54353 190 DO 210 J = K, L
54356 IF (I .EQ. J) GOTO 200
54357 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
54364 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
54366 220 SCALE(I) = 1.0D0
54367 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
54368 230 NOCONV = .FALSE.
54375 IF (J .EQ. I) GOTO 240
54376 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
54377 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
54379 C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
54380 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
54384 250 IF (C .GE. G) GOTO 260
54389 270 IF (C .LT. G) GOTO 280
54393 C .......... NOW BALANCE ..........
54394 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
54396 SCALE(I) = SCALE(I) * F
54400 AR(I,J) = AR(I,J) * G
54401 AI(I,J) = AI(I,J) * G
54405 AR(J,I) = AR(J,I) * F
54406 AI(J,I) = AI(J,I) * F
54411 IF (NOCONV) GOTO 230
54418 C*********************************************************************
54421 C...Auxiliary to PYEICG.
54423 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
54424 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
54425 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
54426 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
54428 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
54429 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
54430 C BALANCED MATRIX DETERMINED BY CBAL.
54434 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
54435 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
54436 C DIMENSION STATEMENT.
54438 C N IS THE ORDER OF THE MATRIX.
54440 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
54442 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
54443 C AND SCALING FACTORS USED BY CBAL.
54445 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
54447 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
54448 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
54449 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
54453 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
54454 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
54455 C IN THEIR FIRST M COLUMNS.
54457 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
54458 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
54460 C THIS VERSION DATED AUGUST 1983.
54463 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
54465 INTEGER I,J,K,M,N,II,NM,IGH,LOW
54466 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
54469 IF (M .EQ. 0) GOTO 150
54470 IF (IGH .EQ. LOW) GOTO 120
54472 DO 110 I = LOW, IGH
54474 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
54475 C IF THE FOREGOING STATEMENT IS REPLACED BY
54476 C S=1.0D0/SCALE(I). ..........
54478 ZR(I,J) = ZR(I,J) * S
54479 ZI(I,J) = ZI(I,J) * S
54483 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
54484 C IGH+1 STEP 1 UNTIL N DO -- ..........
54485 120 DO 140 II = 1, N
54487 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
54488 IF (I .LT. LOW) I = LOW - II
54490 IF (K .EQ. I) GOTO 140
54506 C*********************************************************************
54509 C...Auxiliary to PYEICG.
54511 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
54512 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
54513 C BY MARTIN AND WILKINSON.
54514 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
54516 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
54517 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
54518 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
54519 C UNITARY SIMILARITY TRANSFORMATIONS.
54523 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
54524 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
54525 C DIMENSION STATEMENT.
54527 C N IS THE ORDER OF THE MATRIX.
54529 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
54530 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
54531 C SET LOW=1, IGH=N.
54533 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54534 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
54538 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54539 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
54540 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
54541 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
54542 C HESSENBERG MATRIX.
54544 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
54545 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
54547 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
54549 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
54550 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
54552 C THIS VERSION DATED AUGUST 1983.
54555 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
54557 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
54558 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
54559 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
54563 IF (LA .LT. KP1) GOTO 210
54570 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
54572 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
54574 IF (SCALE .EQ. 0.0D0) GOTO 200
54576 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
54579 ORTR(I) = AR(I,M-1) / SCALE
54580 ORTI(I) = AI(I,M-1) / SCALE
54581 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
54585 F = PYTHAG(ORTR(M),ORTI(M))
54586 IF (F .EQ. 0.0D0) GOTO 120
54589 ORTR(M) = (1.0D0 + G) * ORTR(M)
54590 ORTI(M) = (1.0D0 + G) * ORTI(M)
54595 C .......... FORM (I-(U*UT)/H) * A ..........
54596 130 DO 160 J = M, N
54599 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
54602 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
54603 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
54610 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
54611 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
54615 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
54619 C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
54622 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
54623 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
54630 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
54631 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
54636 ORTR(M) = SCALE * ORTR(M)
54637 ORTI(M) = SCALE * ORTI(M)
54638 AR(M,M-1) = -G * AR(M,M-1)
54639 AI(M,M-1) = -G * AI(M,M-1)
54645 C*********************************************************************
54648 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
54651 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
54653 INTEGER N,NP,INDX(N)
54655 COMPLEX*16 A(NP,NP)
54656 PARAMETER (TINY=1.0D-20)
54658 REAL*8 AAMAX,VV(6),DUM
54659 COMPLEX*16 SUM,DUMC
54665 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
54667 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
54674 SUM=SUM-A(I,K)*A(K,J)
54682 SUM=SUM-A(I,K)*A(K,J)
54686 IF (DUM.GE.AAMAX) THEN
54701 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
54704 A(I,J)=A(I,J)/A(J,J)
54712 C*********************************************************************
54715 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
54718 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
54720 INTEGER N,NP,INDX(N)
54721 COMPLEX*16 A(NP,NP),B(N)
54732 SUM=SUM-A(I,J)*B(J)
54734 ELSE IF (ABS(SUM).NE.0D0) THEN
54742 SUM=SUM-A(I,J)*B(J)
54749 C***********************************************************************
54752 C...Calculates full and partial widths of resonances.
54753 C....copy of PYWIDT, used for techniparticle widths
54755 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
54757 C...Double precision and integer declarations.
54758 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54759 IMPLICIT INTEGER(I-N)
54760 INTEGER PYK,PYCHGE,PYCOMP
54761 C...Parameter statement to help give large particle numbers.
54762 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54763 &KEXCIT=4000000,KDIMEN=5000000)
54765 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54766 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54767 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54768 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
54769 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54770 COMMON/PYINT1/MINT(400),VINT(400)
54771 COMMON/PYINT4/MWID(500),WIDS(500,5)
54772 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54773 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
54774 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
54775 &/PYINT4/,/PYMSSM/,/PYTCSM/
54776 C...Local arrays and saved variables.
54777 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
54779 SAVE MOFSV,WIDWSV,WID2SV
54780 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
54782 C...Compressed code and sign; mass.
54789 C...Reset width information.
54794 C...Common electroweak and strong constants.
54797 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
54800 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
54802 RADC=1D0+AS/PARU(1)
54804 IF(KFLA.EQ.23) THEN
54806 XWC=1D0/(16D0*XW*XW1)
54807 FAC=(AEM*XWC/3D0)*SHR
54809 DO 130 I=1,MDCY(KC,3)
54811 IF(MDME(IDC,1).LT.0) GOTO 130
54812 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
54813 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
54814 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
54818 AF=SIGN(1D0,EF+0.1D0)
54821 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
54822 ELSEIF(I.LE.16) THEN
54823 C...Z0 -> l+ + l-, nu + nubar
54825 AF=SIGN(1D0,EF+0.1D0)
54829 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
54830 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
54832 WDTP(0)=WDTP(0)+WDTP(I)
54836 ELSEIF(KFLA.EQ.24) THEN
54838 FAC=(AEM/(24D0*XW))*SHR
54839 DO 140 I=1,MDCY(KC,3)
54841 IF(MDME(IDC,1).LT.0) GOTO 140
54842 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
54843 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
54844 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
54847 C...W+/- -> q + qbar'
54848 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
54849 ELSEIF(I.LE.20) THEN
54850 C...W+/- -> l+/- + nu
54853 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
54854 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
54855 WDTP(0)=WDTP(0)+WDTP(I)
54858 C.....V8 -> quark anti-quark
54859 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
54862 IF(ITCM(2).EQ.0) THEN
54864 ELSEIF(ITCM(2).EQ.1) THEN
54867 DO 150 I=1,MDCY(KC,3)
54869 IF(MDME(IDC,1).LT.0) GOTO 150
54870 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
54872 IF(RM1.GT.0.25D0) GOTO 150
54874 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
54879 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
54880 IF(I.EQ.6) WID2=WIDS(6,1)
54881 WDTP(0)=WDTP(0)+WDTP(I)
54888 C*********************************************************************
54891 C...Calculates R-violating decays of sfermions.
54894 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
54896 C...Double precision and integer declarations.
54897 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54898 IMPLICIT INTEGER(I-N)
54899 C...Parameter statement to help give large particle numbers.
54900 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54901 &KEXCIT=4000000,KDIMEN=5000000)
54903 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54904 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54905 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54906 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54907 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
54908 C...Local variables.
54909 DOUBLE PRECISION XLAM(0:400)
54910 INTEGER IDLAM(400,3), PYCOMP
54911 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
54913 C...IS R-VIOLATION ON ?
54914 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
54915 C...Mass eigenstate counter
54916 ICNT=INT(KFIN/KSUSY1)
54917 C...SM KF code of SUSY particle
54918 KFSM=KFIN-ICNT*KSUSY1
54919 C...Squared Sparticle Mass
54920 SM=PMAS(PYCOMP(KFIN),1)**2
54921 C... Squared mass of top quark
54922 SMT=PMAS(PYCOMP(6),1)**2
54923 C...IS L-VIOLATION ON ?
54924 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
54925 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
54926 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
54932 C...~e,~mu,~tau -> nu_I + lepton-_J
54934 IDLAM(LKNT,1)= 12 +2*(I-1)
54935 IDLAM(LKNT,2)= 11 +2*(J-1)
54938 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
54939 IF (IMSS(51).NE.0) XLAM(LKNT) =
54940 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54941 C...KINEMATICS CHECK
54942 IF (XLAM(LKNT).EQ.0D0) THEN
54948 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
54954 IDLAM(LKNT,1)=-12 -2*(I-1)
54955 IDLAM(LKNT,2)= 11 +2*(K-1)
54958 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
54959 IF (IMSS(51).NE.0) XLAM(LKNT) =
54960 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54961 C...KINEMATICS CHECK
54962 IF (XLAM(LKNT).EQ.0D0) THEN
54968 C...~e,~mu,~tau -> u_Jbar + d_K
54973 IDLAM(LKNT,1)=-2 -2*(J-1)
54974 IDLAM(LKNT,2)= 1 +2*(K-1)
54977 IF (IMSS(52).NE.0) THEN
54978 C...Use massive top quark
54979 IF (IDLAM(LKNT,1).EQ.-6) THEN
54980 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
54983 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
54984 C...If no top quark, all decay products massless
54986 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
54988 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54990 C...KINEMATICS CHECK
54991 IF (XLAM(LKNT).EQ.0D0) THEN
54998 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
54999 C...No right-handed neutrinos
55001 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
55006 C...~nu_J -> lepton+_I + lepton-_K
55008 IDLAM(LKNT,1)=-11 -2*(I-1)
55009 IDLAM(LKNT,2)= 11 +2*(K-1)
55012 RM2=RVLAM(I,J,K)**2 * SM
55013 IF (IMSS(51).NE.0) XLAM(LKNT) =
55014 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55015 C...KINEMATICS CHECK
55016 IF (XLAM(LKNT).EQ.0D0) THEN
55022 C...~nu_I -> dbar_J + d_K
55027 IDLAM(LKNT,1)=-1 -2*(J-1)
55028 IDLAM(LKNT,2)= 1 +2*(K-1)
55031 RM2=3*RVLAMP(I,J,K)**2 * SM
55032 IF (IMSS(52).NE.0) XLAM(LKNT) =
55033 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55034 C...KINEMATICS CHECK
55035 IF (XLAM(LKNT).EQ.0D0) THEN
55042 C * SDOWN -> NU(BAR) + D and LEPTON- + U
55043 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
55047 C...~d_J -> nu_Ibar + d_K
55049 IDLAM(LKNT,1)=-12 -2*(I-1)
55050 IDLAM(LKNT,2)= 1 +2*(K-1)
55053 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
55054 IF (IMSS(52).NE.0) XLAM(LKNT) =
55055 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55056 C...KINEMATICS CHECK
55057 IF (XLAM(LKNT).EQ.0D0) THEN
55065 C...~d_K -> nu_I + d_J
55067 IDLAM(LKNT,1)= 12 +2*(I-1)
55068 IDLAM(LKNT,2)= 1 +2*(J-1)
55071 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
55072 IF (IMSS(52).NE.0) XLAM(LKNT) =
55073 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55074 C...KINEMATICS CHECK
55075 IF (XLAM(LKNT).EQ.0D0) THEN
55078 C...~d_K -> lepton_I- + u_J
55080 IDLAM(LKNT,1)= 11 +2*(I-1)
55081 IDLAM(LKNT,2)= 2 +2*(J-1)
55084 IF (IMSS(52).NE.0) THEN
55085 C...Use massive top quark
55086 IF (IDLAM(LKNT,2).EQ.6) THEN
55087 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
55089 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
55090 C...If no top quark, all decay products massless
55092 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
55094 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55096 C...KINEMATICS CHECK
55097 IF (XLAM(LKNT).EQ.0D0) THEN
55104 C * SUP -> LEPTON+ + D
55105 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
55109 C...~u_J -> lepton_I+ + d_K
55111 IDLAM(LKNT,1)=-11 -2*(I-1)
55112 IDLAM(LKNT,2)= 1 +2*(K-1)
55115 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
55116 IF (IMSS(52).NE.0) XLAM(LKNT) =
55117 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55118 C...KINEMATICS CHECK
55119 IF (XLAM(LKNT).EQ.0D0) THEN
55126 C...BARYON NUMBER VIOLATING DECAYS
55127 IF (IMSS(53).GE.1) THEN
55128 C * SUP -> DBAR + DBAR
55129 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
55133 C...~u_I -> dbar_J + dbar_K
55135 C...(anti-) symmetry J <-> K.
55137 IDLAM(LKNT,1) = -1 -2*(J-1)
55138 IDLAM(LKNT,2) = -1 -2*(K-1)
55141 RM2 = 2.*(RVLAMB(I,J,K)**2)
55142 & * SFMIX(KFSM,2*ICNT)**2 * SM
55144 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55145 C...KINEMATICS CHECK
55146 IF (XLAM(LKNT).EQ.0D0) THEN
55153 C * SDOWN -> UBAR + DBAR
55154 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
55158 C...LAMB coupling antisymmetric in J and K.
55160 C...~d_K -> ubar_I + dbar_K
55162 IDLAM(LKNT,1)= -2 -2*(I-1)
55163 IDLAM(LKNT,2)= -1 -2*(J-1)
55166 C...Use massive top quark
55167 IF (IDLAM(LKNT,1).EQ.-6) THEN
55168 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
55171 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
55172 C...If no top quark, all decay products massless
55174 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
55176 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55178 C...KINEMATICS CHECK
55179 IF (XLAM(LKNT).EQ.0D0) THEN
55192 C*********************************************************************
55195 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
55198 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
55200 C...Double precision and integer declarations.
55201 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55202 IMPLICIT INTEGER(I-N)
55203 C...Parameter statement to help give large particle numbers.
55204 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55205 &KEXCIT=4000000,KDIMEN=5000000)
55207 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55208 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55209 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
55210 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55211 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55212 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
55213 C...Local variables.
55214 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55216 DOUBLE PRECISION XLAM(0:400)
55217 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
55218 INTEGER IDLAM(400,3), PYCOMP
55220 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
55222 C...R-VIOLATING DECAYS
55223 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
55225 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
55226 C...WHICH NEUTRALINO ?
55228 IF (KFSM.EQ.23) NCHI=2
55229 IF (KFSM.EQ.25) NCHI=3
55230 IF (KFSM.EQ.35) NCHI=4
55231 C...SIGN OF MASS (Opposite convention as HERWIG)
55233 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
55235 C...Useful parameters for the calculation of the A and B constants.
55236 WMASS = PMAS(PYCOMP(24),1)
55237 ECHG = 2*SQRT(PARU(103)*PARU(1))
55238 COSB=1/(SQRT(1+RMSS(5)**2))
55239 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
55240 COSW=SQRT(1-PARU(102))
55241 SINW=SQRT(PARU(102))
55242 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
55243 C...Run quark masses to neutralino mass squared (for Higgs-type
55245 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
55247 RMQ(I)=PYMRUN(I,SQMCHI)
55249 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
55251 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
55252 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
55253 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
55254 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
55256 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
55257 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
55258 C2=ECHG*ZPMIX(NCHI,1)
55259 C3=GW*ZPMIX(NCHI,2)/COSW
55263 C x=1-2 : Select A or B constant (1:A ; 2:B)
55264 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
55265 C 11-16:e,nu_e,mu,...)
55266 C z=1-2 : Mass eigenstate number
55267 C...CALCULATE COUPLINGS
55269 CMS=PMAS(PYCOMP(I),1)
55270 C...Intermediate sleptons
55271 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
55272 & *(C2-C3*SINW**2))
55273 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
55274 & *(C2-C3*SINW**2))
55275 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
55277 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
55279 C...Inermediate sneutrinos
55281 AB(2,I+1,1)=5D-1*C3
55284 C...Inermediate sdown
55287 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
55288 & *ED*(C2-C3*SINW**2))
55289 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
55290 & *ED*(C2-C3*SINW**2))
55291 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
55292 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
55293 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
55294 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
55295 C...Inermediate sup
55298 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
55299 & *EU*(C2-C3*SINW**2))
55300 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
55301 & *EU*(C2-C3*SINW**2))
55302 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
55303 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
55304 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
55305 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
55308 IF (IMSS(51).GE.1) THEN
55309 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
55310 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
55311 C...STEP IN I,J,K USING SINGLE COUNTER
55313 C...LAMBDA COUPLING ASYM IN I,J
55314 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
55316 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55317 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
55318 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
55320 C...Set coupling, and decay product masses on/off
55321 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
55322 & ,MOD(ISC,3)+1)**2
55324 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
55326 C...Resonance KF codes (1=I,2=J,3=K)
55327 KFR(1)=-IDLAM(LKNT,1)
55328 KFR(2)=-IDLAM(LKNT,2)
55329 KFR(3)=-IDLAM(LKNT,3)
55330 C...Calculate width.
55331 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55332 & IDLAM(LKNT,3),XLAM(LKNT))
55333 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55334 C...Charge conjugate mode.
55336 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55337 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55338 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55339 XLAM(LKNT)=XLAM(LKNT-1)
55340 C...KINEMATICS CHECK
55341 IF (XLAM(LKNT).EQ.0D0) THEN
55348 IF (IMSS(52).GE.1) THEN
55349 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
55350 C * CHI0 -> NUBAR_I + DBAR_J + D_K
55353 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55354 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55355 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55357 C...Set coupling, and decay product masses on/off
55358 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
55359 & ,MOD(ISC,3)+1)**2
55361 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
55363 C...Resonance KF codes (1=I,2=J,3=K)
55364 KFR(1)=-IDLAM(LKNT,1)
55365 KFR(2)=-IDLAM(LKNT,2)
55366 KFR(3)=-IDLAM(LKNT,3)
55367 C...Calculate width.
55368 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55370 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55371 C...Charge conjugate mode.
55373 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55374 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55375 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55376 XLAM(LKNT)=XLAM(LKNT-1)
55377 C...KINEMATICS CHECK
55378 IF (XLAM(LKNT).EQ.0D0) THEN
55382 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
55384 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55385 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
55386 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55388 C...Set coupling, and decay product masses on/off
55389 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
55390 & ,MOD(ISC,3)+1)**2
55392 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
55393 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
55394 C...Resonance KF codes (1=I,2=J,3=K)
55395 KFR(1)=-IDLAM(LKNT,1)
55396 KFR(2)=-IDLAM(LKNT,2)
55397 KFR(3)=-IDLAM(LKNT,3)
55398 C...Calculate width.
55399 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55401 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55402 C...Charge conjugate mode.
55404 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55405 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55406 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55407 XLAM(LKNT)=XLAM(LKNT-1)
55408 C...KINEMATICS CHECK
55409 IF (XLAM(LKNT).EQ.0D0) THEN
55415 IF (IMSS(53).GE.1) THEN
55416 C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
55417 C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
55419 C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
55420 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
55422 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
55423 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55424 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
55426 C...Set coupling, and decay product masses on/off
55427 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
55428 & +1,MOD(ISC,3)+1)**2
55430 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
55431 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
55432 C...Resonance KF codes (1=I,2=J,3=K)
55433 KFR(1) = IDLAM(LKNT,1)
55434 KFR(2) = IDLAM(LKNT,2)
55435 KFR(3) = IDLAM(LKNT,3)
55436 C...Calculate width.
55437 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55438 & IDLAM(LKNT,3),XLAM(LKNT))
55439 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55440 C...Charge conjugate mode.
55442 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55443 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55444 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55445 XLAM(LKNT)=XLAM(LKNT-1)
55446 C...KINEMATICS CHECK
55447 IF (XLAM(LKNT).EQ.0D0) THEN
55459 C*********************************************************************
55462 C...Calculates R-violating chargino decay widths.
55465 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
55467 C...Double precision and integer declarations.
55468 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55469 IMPLICIT INTEGER(I-N)
55470 C...Parameter statement to help give large particle numbers.
55471 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55472 &KEXCIT=4000000,KDIMEN=5000000)
55474 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55475 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55476 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
55477 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55478 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55479 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
55480 C...Local variables.
55481 DOUBLE PRECISION XLAM(0:400)
55482 INTEGER IDLAM(400,3), PYCOMP
55483 C...Information from main routine to PYRVGW
55484 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55486 C...Auxiliary variables needed for BV (RV Gauge STOre)
55487 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
55489 C...Running quark masses
55490 DOUBLE PRECISION RMQ(6)
55491 C...Decay product masses on/off
55493 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
55497 C...IF R-VIOLATION ON.
55498 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
55500 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
55501 C...WHICH CHARGINO ?
55503 IF (KFSM.EQ.37) NCHI = 2
55505 C...Useful parameters for calculating the A and B constants.
55506 C...SIGN OF MASS (Opposite convention as HERWIG)
55508 IF (SMW(NCHI).LT.0D0) ISM = -1
55509 WMASS = PMAS(PYCOMP(24),1)
55510 COSB = 1/(SQRT(1+RMSS(5)**2))
55511 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
55512 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
55513 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
55514 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
55517 C...Running masses at Q^2=MCHI^2.
55518 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
55520 RMQ(I)=PYMRUN(I,SQMCHI)
55523 C... AB(x,y,z) coefficients:
55524 C x=1-2 : A or B coefficient (1:A ; 2:B)
55525 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
55526 C 11-16:e,nu_e,mu,...)
55527 C z=1-2 : Mass eigenstate number
55529 C...Intermediate sleptons
55532 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
55534 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
55536 C...Intermediate sneutrinos
55537 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
55539 AB(2,I+1,1) = ISM*C3
55541 C...Intermediate sdown
55543 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
55544 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
55545 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
55546 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
55547 C...Intermediate sup
55549 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
55550 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
55551 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
55552 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
55555 C...LLE TYPE R-VIOLATION
55556 IF (IMSS(51).GE.1) THEN
55557 C...LOOP OVER DECAY MODES
55560 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
55561 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
55563 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
55564 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
55565 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
55567 C...Set coupling, and decay product masses on/off
55568 RVLAMC = GW2 * 5D-1 *
55569 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
55572 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
55573 C...Resonance KF codes (1=I,2=J,3=K).
55576 KFR(3) = -IDLAM(LKNT,3)+1
55577 C...Calculate width.
55578 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55579 & IDLAM(LKNT,3),XLAM(LKNT))
55580 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55581 C...KINEMATICS CHECK
55582 IF (XLAM(LKNT).EQ.0D0) THEN
55586 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
55587 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
55589 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
55590 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
55591 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
55593 C...Set coupling, and decay product masses on/off
55594 RVLAMC = GW2 * 5D-1 *
55595 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55596 C...I,J SYMMETRY => FACTOR 2
55599 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
55600 C...Resonance KF codes (1=I,2=J,3=K)
55601 KFR(1)=IDLAM(LKNT,1)-1
55602 KFR(2)=IDLAM(LKNT,2)-1
55604 C...Calculate width.
55605 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55606 & IDLAM(LKNT,3),XLAM(LKNT))
55607 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55608 C...KINEMATICS CHECK
55609 IF (XLAM(LKNT).EQ.0D0) THEN
55614 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
55616 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55617 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
55618 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
55620 C...Set coupling, and decay product masses on/off
55621 RVLAMC = GW2 * 5D-1 *
55622 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55623 C...I,J SYMMETRY => FACTOR 2
55626 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
55627 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
55628 C...Resonance KF codes (1=I,2=J,3=K)
55629 KFR(1) =-IDLAM(LKNT,1)+1
55630 KFR(2) =-IDLAM(LKNT,2)+1
55632 C...Calculate width.
55633 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55634 & IDLAM(LKNT,3),XLAM(LKNT))
55635 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55636 C...KINEMATICS CHECK
55637 IF (XLAM(LKNT).EQ.0D0) THEN
55644 C...LQD TYPE R-VIOLATION
55645 IF (IMSS(52).GE.1) THEN
55646 C...LOOP OVER DECAY MODES
55649 C...CHI+ -> NUBAR_I + DBAR_J + U_K
55651 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55652 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55653 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
55655 C...Set coupling, and decay product masses on/off
55656 RVLAMC = 3. * GW2 * 5D-1 *
55657 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55659 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
55661 C...Resonance KF codes (1=I,2=J,3=K)
55664 KFR(3)=-IDLAM(LKNT,3)+1
55665 C...Calculate width.
55666 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55668 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55669 C...KINEMATICS CHECK
55670 IF (XLAM(LKNT).EQ.0D0) THEN
55674 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
55676 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55677 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
55678 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
55680 C...Set coupling, and decay product masses on/off
55681 RVLAMC = 3. * GW2 * 5D-1 *
55682 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55684 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
55685 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
55686 C...Resonance KF codes (1=I,2=J,3=K)
55689 KFR(3)=-IDLAM(LKNT,3)+1
55690 C...Calculate width.
55691 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55693 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55694 C...KINEMATICS CHECK
55695 IF (XLAM(LKNT).EQ.0D0) THEN
55699 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
55701 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55702 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55703 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55705 C...Set coupling, and decay product masses on/off
55706 RVLAMC = 3. * GW2 * 5D-1 *
55707 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55709 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
55710 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
55711 C...Resonance KF codes (1=I,2=J,3=K)
55712 KFR(1)=-IDLAM(LKNT,1)+1
55713 KFR(2)=-IDLAM(LKNT,2)+1
55715 C...Calculate width.
55716 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55718 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55719 C...KINEMATICS CHECK
55720 IF (XLAM(LKNT).EQ.0D0) THEN
55724 C * CHI+ -> NU_I + U_J + DBAR_K.
55726 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
55727 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
55728 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
55730 C...Set coupling, and decay product masses on/off
55732 RVLAMC = 3. * GW2 * 5D-1 *
55733 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55734 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
55736 C...Resonance KF codes (1=I,2=J,3=K)
55737 KFR(1)=IDLAM(LKNT,1)-1
55738 KFR(2)=IDLAM(LKNT,2)-1
55740 C...Calculate width.
55741 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55743 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55744 C...KINEMATICS CHECK
55745 IF (XLAM(LKNT).EQ.0D0) THEN
55752 C...UDD TYPE R-VIOLATION
55753 C...These decays need special treatment since more than one BV coupling
55754 C...contributes (with interference). Consider e.g. (symbolically)
55755 C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
55756 C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
55757 C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
55758 C...The problem is that a single call to PYRVGW would evaluate all
55759 C...these terms and sum them, but without the different couplings. The
55760 C...way out is to call PYRVGW three times, once for the first line, once
55761 C...for the second line, and then once for all the lines (it is
55762 C...impossible to get just the last line out) without multiplying by
55763 C...couplings. The last line is then obtained as the result of the third
55764 C...call minus the results of the two first calls. Each term is then
55765 C...multiplied by its respective coupling before the whole thing is
55766 C...summed up in XLAM.
55767 C...Note that with three interfering resonances, this procedure becomes
55768 C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
55770 IF (IMSS(53).GE.1) THEN
55771 C...LOOP OVER DECAY MODES
55774 C...CHI+ -> U_I + U_J + D_K
55775 C...Decay mode I<->J symmetric.
55776 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
55778 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
55779 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
55780 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55782 C...Set coupling, and decay product masses on/off
55783 RVLAMC= 6. * GW2 * 5D-1
55784 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
55786 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
55788 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
55791 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
55792 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
55793 C...Resonance KF codes (1=I,2=J,3=K)
55794 KFR(1) = -IDLAM(LKNT,1)+1
55797 C...Calculate width.
55798 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55799 & IDLAM(LKNT,3),XRESI)
55800 C...Resonance KF codes (1=I,2=J,3=K)
55802 KFR(2) = -IDLAM(LKNT,2)+1
55804 C...Calculate width.
55805 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55806 & IDLAM(LKNT,3),XRESJ)
55807 C...Resonance KF codes (1=I,2=J,3=K)
55808 KFR(1) = -IDLAM(LKNT,1)+1
55809 KFR(2) = -IDLAM(LKNT,2)+1
55811 C...Calculate width.
55812 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55813 & IDLAM(LKNT,3),XRESIJ)
55814 IF (ABS((XRESI+XRESJ)/XRESIJ-1.).GT.1D-4) THEN
55815 XRESIJ = XRESIJ-XRESI-XRESJ
55819 C...CALCULATE TOTAL WIDTH
55820 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
55821 & + RVLJIK*RVLIJK * XRESIJ
55822 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55823 C...KINEMATICS CHECK
55824 IF (XLAM(LKNT).EQ.0D0) THEN
55828 C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
55829 C...Symmetry I<->J<->K.
55830 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
55831 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
55833 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
55834 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55835 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
55837 C...Set coupling, and decay product masses on/off
55838 RVLAMC = 6. * GW2 * 5D-1
55839 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
55841 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
55843 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
55846 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
55847 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
55848 C...Collect symmetry factors
55849 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
55850 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
55851 & RVLAMC = 5D-1 * RVLAMC
55852 C...Resonance KF codes (1=I,2=J,3=K)
55853 KFR(1) = IDLAM(LKNT,1)-1
55856 C...Calculate width.
55857 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55858 & IDLAM(LKNT,3),XRESI)
55859 C...Resonance KF codes (1=I,2=J,3=K)
55861 KFR(2) = IDLAM(LKNT,2)-1
55863 C...Calculate width.
55864 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55865 & IDLAM(LKNT,3),XRESJ)
55866 C...Resonance KF codes (1=I,2=J,3=K)
55869 KFR(3) = IDLAM(LKNT,3)-1
55870 C...Calculate width.
55871 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55872 & IDLAM(LKNT,3),XRESK)
55873 C...Resonance KF codes (1=I,2=J,3=K)
55874 KFR(1) = IDLAM(LKNT,1)-1
55875 KFR(2) = IDLAM(LKNT,2)-1
55877 C...Calculate width.
55878 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55879 & IDLAM(LKNT,3),XRESIJ)
55880 IF (ABS(XRESIJ/(XRESI+XRESJ)-1.).GT.1D-4) THEN
55881 XRESIJ = XRESI+XRESJ-XRESIJ
55885 C...Resonance KF codes (1=I,2=J,3=K)
55887 KFR(2) = IDLAM(LKNT,2)-1
55888 KFR(3) = IDLAM(LKNT,3)-1
55889 C...Calculate width.
55890 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55891 & IDLAM(LKNT,3),XRESJK)
55892 IF (ABS(XRESJK/(XRESJ+XRESK)-1.).GT.1D-4) THEN
55893 XRESJK = XRESJ+XRESK-XRESJK
55897 C...Resonance KF codes (1=I,2=J,3=K)
55898 KFR(1) = IDLAM(LKNT,1)-1
55900 KFR(3) = IDLAM(LKNT,3)-1
55901 C...Calculate width.
55902 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55903 & IDLAM(LKNT,3),XRESIK)
55904 IF (ABS(XRESIK/(XRESI+XRESK)-1.).GT.1D-4) THEN
55905 XRESIK = XRESI+XRESK-XRESIK
55909 C...CALCULATE TOTAL WIDTH
55911 & RVLIJK**2 * XRESI
55912 & + RVLJKI**2 * XRESJ
55913 & + RVLKIJ**2 * XRESK
55914 & + RVLIJK*RVLJKI * XRESIJ
55915 & + RVLIJK*RVLKIJ * XRESIK
55916 & + RVLJKI*RVLKIJ * XRESJK
55917 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
55918 C...KINEMATICS CHECK
55919 IF (XLAM(LKNT).EQ.0D0) THEN
55931 C*********************************************************************
55934 C...Calculates R-violating gluino decay widths.
55935 C...See BV part of PYRVCH for comments about the way the BV decay width
55936 C...is calculated. Same comments apply here.
55939 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
55941 C...Double precision and integer declarations.
55942 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55943 IMPLICIT INTEGER(I-N)
55944 C...Parameter statement to help give large particle numbers.
55945 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55946 &KEXCIT=4000000,KDIMEN=5000000)
55948 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55949 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55950 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
55951 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55952 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55953 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
55954 C...Local variables.
55955 DOUBLE PRECISION XLAM(0:400)
55956 INTEGER IDLAM(400,3), PYCOMP
55957 C...Information from main routine to PYRVGW
55958 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55960 C...Auxiliary variables needed for BV (RV Gauge STOre)
55961 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
55963 C...Running quark masses
55964 DOUBLE PRECISION RMQ(6)
55965 C...Decay product masses on/off
55967 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
55970 C...IF LQD OR UDD TYPE R-VIOLATION ON.
55971 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
55975 C x=1-2 : Select A or B coupling (1:A ; 2:B)
55976 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
55977 C 11-16:e,nu_e,mu,... not used here)
55978 C z=1-2 : Mass eigenstate number
55981 AB(1,I,1) = SFMIX(I,2)
55982 AB(1,I,2) = SFMIX(I,4)
55984 AB(2,I,1) = -SFMIX(I,1)
55985 AB(2,I,2) = -SFMIX(I,3)
55987 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
55989 IF (IMSS(52).GE.1) THEN
55990 C...STEP IN I,J,K USING SINGLE COUNTER
55992 C * GLUINO -> NUBAR_I + DBAR_J + D_K.
55994 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55995 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55996 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55998 C...Set coupling, and decay product masses on/off
55999 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
56002 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
56003 C...Resonance KF codes (1=I,2=J,3=K)
56005 KFR(2) = -IDLAM(LKNT,2)
56006 KFR(3) = -IDLAM(LKNT,3)
56007 C...Calculate width.
56008 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56011 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
56012 C...Charge conjugate mode.
56014 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
56015 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
56016 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
56017 XLAM(LKNT) = XLAM(LKNT-1)
56018 C...KINEMATICS CHECK
56019 IF (XLAM(LKNT).EQ.0D0) THEN
56023 C * GLUINO -> LEPTON+_I + UBAR_J + D_K
56025 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
56026 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
56027 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
56029 C...Set coupling, and decay product masses on/off
56030 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
56031 & **2* 5D-1 * GSTR2
56033 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
56034 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
56035 C...Resonance KF codes (1=I,2=J,3=K)
56037 KFR(2) = -IDLAM(LKNT,2)
56038 KFR(3) = -IDLAM(LKNT,3)
56039 C...Calculate width.
56040 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56042 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
56043 C...Charge conjugate mode.
56045 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
56046 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
56047 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
56048 XLAM(LKNT) = XLAM(LKNT-1)
56049 C...KINEMATICS CHECK
56050 IF (XLAM(LKNT).EQ.0D0) THEN
56058 IF (IMSS(53).GE.1) THEN
56059 C...STEP IN I,J,K USING SINGLE COUNTER
56061 C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
56062 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
56064 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
56065 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
56066 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
56068 C...Set coupling, and decay product masses on/off. A factor of 2 for
56069 C...(N_C-1) has been used to cancel a factor 0.5.
56070 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
56073 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
56074 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
56075 C...Resonance KF codes (1=I,2=J,3=K)
56076 KFR(1) = IDLAM(LKNT,1)
56079 C...Calculate width.
56080 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56082 C...Resonance KF codes (1=I,2=J,3=K)
56084 KFR(2) = IDLAM(LKNT,2)
56086 C...Calculate width.
56087 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56089 C...Resonance KF codes (1=I,2=J,3=K)
56092 KFR(3) = IDLAM(LKNT,3)
56093 C...Calculate width.
56094 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56096 C...Resonance KF codes (1=I,2=J,3=K)
56097 KFR(1) = IDLAM(LKNT,1)
56098 KFR(2) = IDLAM(LKNT,2)
56100 C...Calculate width.
56101 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56103 C...Calculate interference function. (Factor -1/2 to make up for factor
56105 IF (ABS((XRESI+XRESJ)/XRESIJ-1D0).GT.1D-4) THEN
56106 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
56110 C...Resonance KF codes (1=I,2=J,3=K)
56112 KFR(2) = IDLAM(LKNT,2)
56113 KFR(3) = IDLAM(LKNT,3)
56114 C...Calculate width.
56115 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56117 IF (ABS((XRESJ+XRESK)/XRESJK-1).GT.1D-4) THEN
56118 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
56122 C...Resonance KF codes (1=I,2=J,3=K)
56123 KFR(1) = IDLAM(LKNT,1)
56125 KFR(3) = IDLAM(LKNT,3)
56126 C...Calculate width.
56127 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56129 IF (ABS((XRESI+XRESK)/XRESIK-1).GT.1D-4) THEN
56130 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
56134 C...Calculate total width (factor 1/2 from 1/(N_C-1))
56135 XLAM(LKNT) = XRESI + XRESJ + XRESK
56136 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
56138 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
56139 C...Charge conjugate mode.
56141 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
56142 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
56143 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
56144 XLAM(LKNT) = XLAM(LKNT-1)
56145 C...KINEMATICS CHECK
56146 IF (XLAM(LKNT).EQ.0D0) THEN
56156 C*********************************************************************
56159 C...Auxiliary function to PYRVSF for calculating R-Violating
56160 C...sfermion widths. Though the decay products are most often treated
56161 C...as massless in the calculation, the kinematical boundary of phase
56162 C...space is tested using the true masses.
56163 C...MODE = 1: All decay products massive
56164 C...MODE = 2: Decay product 1 massless
56165 C...MODE = 3: Decay product 2 massless
56166 C...MODE = 4: All decay products massless
56168 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
56170 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
56171 IMPLICIT INTEGER (I-N)
56172 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56173 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56174 SAVE /PYDAT1/,/PYDAT2/
56175 DOUBLE PRECISION SM(3)
56176 INTEGER PYCOMP, KC(3)
56180 SM(1)=PMAS(KC(1),1)**2
56181 SM(2)=PMAS(KC(2),1)**2
56182 SM(3)=PMAS(KC(3),1)**2
56183 C...Kinematics check
56184 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
56188 C...CM momenta squared
56189 IF (MODE.EQ.1) THEN
56190 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
56191 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
56192 ELSE IF (MODE.EQ.2) THEN
56193 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
56194 ELSE IF (MODE.EQ.3) THEN
56195 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
56199 C...Calculate Width
56200 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
56204 C*********************************************************************
56207 C...Generalized Matrix Element for R-Violating 3-body widths.
56209 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
56211 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
56212 IMPLICIT INTEGER (I-N)
56213 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56214 &KEXCIT=4000000,KDIMEN=5000000)
56215 PARAMETER (EPS=1D-4)
56216 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56217 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56219 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
56220 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
56221 DOUBLE PRECISION XLIM(3,3)
56222 INTEGER KC(0:3), PYCOMP
56223 LOGICAL DCMASS, DCHECK(6)
56224 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
56228 KC(0) = PYCOMP(KFIN)
56229 KC(1) = PYCOMP(ID1)
56230 KC(2) = PYCOMP(ID2)
56231 KC(3) = PYCOMP(ID3)
56232 RMS(0) = PMAS(KC(0),1)
56233 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
56234 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
56235 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
56236 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
56237 XLIM(1,1)=(RMS(1)+RMS(2))**2
56238 XLIM(1,2)=(RMS(0)-RMS(3))**2
56239 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
56240 XLIM(2,1)=(RMS(2)+RMS(3))**2
56241 XLIM(2,2)=(RMS(0)-RMS(1))**2
56242 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
56243 XLIM(3,1)=(RMS(1)+RMS(3))**2
56244 XLIM(3,2)=(RMS(0)-RMS(2))**2
56245 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
56246 C...Check Phase Space
56247 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
56251 C...INITIALIZE RESONANCE INFORMATION
56254 IRES = 2*(JRES-1)+IMASS
56256 DCHECK(IRES) =.FALSE.
56257 C...NO RIGHT-HANDED NEUTRINOS
56258 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
56259 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
56260 & .KFR(JRES).EQ.0) GOTO 100
56261 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
56262 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
56263 INTRES(IRES,1) = IABS(KFR(JRES))
56264 INTRES(IRES,2) = IMASS
56265 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
56266 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
56270 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
56272 C...RESONANCE CONTRIBUTIONS
56273 C...(Only sum contributions where the resonance is off shell).
56274 C...Store whether diagram on/off in DCHECK.
56275 C...LOOP OVER MASS STATES
56278 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
56279 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
56280 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
56281 DCHECK(IDR) =.TRUE.
56282 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
56286 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
56287 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
56288 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
56289 DCHECK(IDR) =.TRUE.
56290 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
56294 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
56295 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
56296 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
56297 DCHECK(IDR) =.TRUE.
56298 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
56301 C... L-R INTERFERENCES
56302 C... (Only add contributions where both contributing diagrams
56303 C... are non-resonant).
56305 IF (DCHECK(1).AND.DCHECK(2)) THEN
56306 C...Bug corrected 11/12 2001. Skands.
56307 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
56308 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
56309 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
56313 IF (DCHECK(3).AND.DCHECK(4)) THEN
56314 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
56315 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
56316 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
56320 IF (DCHECK(5).AND.DCHECK(6)) THEN
56321 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
56322 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
56323 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
56325 C... TRUE INTERFERENCES
56326 C... (Only add contributions where both contributing diagrams
56327 C... are non-resonant).
56329 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
56334 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
56335 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
56336 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
56337 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
56342 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
56343 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
56344 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
56345 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
56350 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
56351 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
56352 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
56353 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
56361 C*********************************************************************
56364 C...Function to integrate resonance contributions
56366 FUNCTION PYRVI1(ID1,ID2,ID3)
56369 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
56370 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
56371 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
56372 LOGICAL MFLAG,DCMASS
56373 EXTERNAL PYRVG1,PYGAUS
56374 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56376 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56377 SAVE/PYRVNV/,/PYRVPM/
56378 C...Initialize mass and width information
56384 RESM(1)= RES(IDR,1)
56385 RESW(1)= RES(IDR,2)
56386 C...A->B and B->A for antisparticles
56387 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56388 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56389 C...Integration boundaries and mass flag
56390 LO = (RM(1)+RM(2))**2
56391 HI = (RM(0)-RM(3))**2
56393 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
56397 C*********************************************************************
56400 C...Function to integrate L-R interference contributions
56402 FUNCTION PYRVI2(ID1,ID2,ID3)
56405 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
56406 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
56407 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
56408 LOGICAL MFLAG,DCMASS
56409 EXTERNAL PYRVG2,PYGAUS
56410 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56412 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56413 SAVE/PYRVNV/,/PYRVPM/
56414 C...Initialize mass and width information
56420 RESM(1)= RES(IDR,1)
56421 RESW(1)= RES(IDR,2)
56422 RESM(2)= RES(IDR+1,1)
56423 RESW(2)= RES(IDR+1,2)
56424 C...A->B and B->A for antisparticles
56425 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56426 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56427 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
56428 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
56429 C...Boundaries and mass flag
56430 LO = (RM(1)+RM(2))**2
56431 HI = (RM(0)-RM(3))**2
56433 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
56437 C*********************************************************************
56440 C...Function to integrate true interference contributions
56442 FUNCTION PYRVI3(ID1,ID2,ID3)
56445 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
56446 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
56447 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
56448 LOGICAL MFLAG,DCMASS
56449 EXTERNAL PYRVG3,PYGAUS
56450 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56452 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56453 SAVE/PYRVNV/,/PYRVPM/
56454 C...Initialize mass and width information
56460 RESM(1)= RES(IDR,1)
56461 RESW(1)= RES(IDR,2)
56462 RESM(2)= RES(IDR2,1)
56463 RESW(2)= RES(IDR2,2)
56464 C...A -> B and B -> A for antisparticles
56465 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56466 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56467 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
56468 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
56469 C...Boundaries and mass flag
56470 LO = (RM(1)+RM(2))**2
56471 HI = (RM(0)-RM(3))**2
56473 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
56477 C*********************************************************************
56480 C...Integrand for resonance contributions
56485 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56486 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
56487 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
56490 RVR = PYRVR(X,RESM(1),RESW(1))
56491 C1 = 2D0*SQRT(MAX(0D0,X))
56492 IF (.NOT.MFLAG) THEN
56494 E3 = (RM(0)**2-X)/C1
56496 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
56498 E2 = (X-RM(1)**2+RM(2)**2)/C1
56499 E3 = (RM(0)**2-X-RM(3)**2)/C1
56500 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
56501 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
56502 DELTAY = 4D0*SR1*SR2
56503 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
56504 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
56505 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
56510 C*********************************************************************
56513 C...Integrand for L-R interference contributions
56518 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56519 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
56520 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
56523 C1 = 2D0*SQRT(MAX(0D0,X))
56524 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
56525 IF (.NOT.MFLAG) THEN
56527 E3 = (RM(0)**2-X)/C1
56529 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
56531 E2 = (X-RM(1)**2+RM(2)**2)/C1
56532 E3 = (RM(0)**2-X-RM(3)**2)/C1
56533 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
56534 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
56535 DELTAY = 4D0*SR1*SR2
56536 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
56537 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
56538 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
56543 C*********************************************************************
56546 C...Function to do Y integration over true interference contributions
56551 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56552 C...Second Dalitz variable for PYRVG4
56554 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
56555 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
56556 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
56558 EXTERNAL PYGAU2,PYRVG4
56559 SAVE/PYRVPM/,/PYG2DX/
56561 C1=2D0*SQRT(MAX(1D-9,X))
56563 IF (.NOT.MFLAG) THEN
56565 E3 = (RM(0)**2-X)/C1
56569 E2 = (X-RM(1)**2+RM(2)**2)/C1
56570 E3 = (RM(0)**2-X-RM(3)**2)/C1
56572 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
56573 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
56574 YMIN = SQ1-(SR1+SR2)**2
56575 YMAX = SQ1-(SR1-SR2)**2
56577 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
56581 C*********************************************************************
56584 C...Integrand for true intereference contributions
56589 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56591 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
56593 SAVE /PYRVPM/,/PYG2DX/
56595 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
56596 IF (.NOT.MFLAG) THEN
56597 PYRVG4 = RVS*B(1)*B(2)*X*Y
56599 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
56600 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
56601 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
56602 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
56607 C*********************************************************************
56610 C...Breit-Wigner for resonance contributions
56612 FUNCTION PYRVR(Mab2,RM,RW)
56615 DOUBLE PRECISION Mab2,RM,RW,PYRVR
56616 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
56620 C*********************************************************************
56623 C...Interference function
56625 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
56628 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
56629 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
56634 C*********************************************************************
56637 C...Stores one parton/particle in commonblock PYJETS.
56639 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
56641 C...Double precision and integer declarations.
56642 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56643 IMPLICIT INTEGER(I-N)
56644 INTEGER PYK,PYCHGE,PYCOMP
56646 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56647 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56648 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56649 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56651 C...Standard checks.
56653 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56654 IPA=MAX(1,IABS(IP))
56655 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
56656 &'(PY1ENT:) writing outside PYJETS memory')
56658 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
56660 C...Find mass. Reset K, P and V vectors.
56662 IF(MSTU(10).EQ.1) PM=P(IPA,5)
56663 IF(MSTU(10).GE.2) PM=PYMASS(KF)
56670 C...Store parton/particle in K and P vectors.
56672 IF(IP.LT.0) K(IPA,1)=2
56675 P(IPA,4)=MAX(PE,PM)
56676 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
56677 P(IPA,1)=PA*SIN(THE)*COS(PHI)
56678 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
56679 P(IPA,3)=PA*COS(THE)
56681 C...Set N. Optionally fragment/decay.
56683 IF(IP.EQ.0) CALL PYEXEC
56688 C*********************************************************************
56691 C...Stores two partons/particles in their CM frame,
56692 C...with the first along the +z axis.
56694 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
56696 C...Double precision and integer declarations.
56697 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56698 IMPLICIT INTEGER(I-N)
56699 INTEGER PYK,PYCHGE,PYCOMP
56701 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56702 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56703 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56704 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56706 C...Standard checks.
56708 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56709 IPA=MAX(1,IABS(IP))
56710 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
56711 &'(PY2ENT:) writing outside PYJETS memory')
56714 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
56715 &'(PY2ENT:) unknown flavour code')
56717 C...Find masses. Reset K, P and V vectors.
56719 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
56720 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
56722 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
56723 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
56732 C...Check flavours.
56733 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
56734 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
56735 IF(MSTU(19).EQ.1) THEN
56738 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
56739 & '(PY2ENT:) unphysical flavour combination')
56744 C...Store partons/particles in K vectors for normal case.
56747 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
56750 C...Store partons in K vectors for parton shower evolution.
56754 K(IPA,4)=MSTU(5)*(IPA+1)
56756 K(IPA+1,4)=MSTU(5)*IPA
56757 K(IPA+1,5)=K(IPA+1,4)
56760 C...Check kinematics and store partons/particles in P vectors.
56761 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
56762 &'(PY2ENT:) energy smaller than sum of masses')
56763 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
56766 P(IPA,4)=SQRT(PM1**2+PA**2)
56769 P(IPA+1,4)=SQRT(PM2**2+PA**2)
56772 C...Set N. Optionally fragment/decay.
56774 IF(IP.EQ.0) CALL PYEXEC
56779 C*********************************************************************
56782 C...Stores three partons or particles in their CM frame,
56783 C...with the first along the +z axis and the third in the (x,z)
56784 C...plane with x > 0.
56786 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
56788 C...Double precision and integer declarations.
56789 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56790 IMPLICIT INTEGER(I-N)
56791 INTEGER PYK,PYCHGE,PYCOMP
56793 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56794 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56795 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56796 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56798 C...Standard checks.
56800 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56801 IPA=MAX(1,IABS(IP))
56802 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
56803 &'(PY3ENT:) writing outside PYJETS memory')
56807 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
56808 &'(PY3ENT:) unknown flavour code')
56810 C...Find masses. Reset K, P and V vectors.
56812 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
56813 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
56815 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
56816 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
56818 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
56819 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
56828 C...Check flavours.
56829 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
56830 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
56831 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
56832 IF(MSTU(19).EQ.1) THEN
56834 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
56835 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
56836 & KQ1+KQ3.EQ.4)) THEN
56838 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
56844 C...Store partons/particles in K vectors for normal case.
56847 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
56849 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
56852 C...Store partons in K vectors for parton shower evolution.
56858 IF(KQ1.EQ.-1) KCS=5
56859 K(IPA,KCS)=MSTU(5)*(IPA+1)
56860 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
56861 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
56862 K(IPA+1,9-KCS)=MSTU(5)*IPA
56863 K(IPA+2,KCS)=MSTU(5)*IPA
56864 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
56867 C...Check kinematics.
56869 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
56870 &0.5D0*X3*PECM.LE.PM3) MKERR=1
56871 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
56872 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
56873 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
56874 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
56875 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
56876 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
56877 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
56878 IF(MKERR.NE.0) CALL PYERRM(13,
56879 &'(PY3ENT:) unphysical kinematical variable setup')
56881 C...Store partons/particles in P vectors.
56883 P(IPA,4)=SQRT(PA1**2+PM1**2)
56885 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
56886 P(IPA+2,3)=PA3*CTHE3
56887 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
56889 P(IPA+1,1)=-P(IPA+2,1)
56890 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
56891 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
56894 C...Set N. Optionally fragment/decay.
56896 IF(IP.EQ.0) CALL PYEXEC
56901 C*********************************************************************
56904 C...Stores four partons or particles in their CM frame, with
56905 C...the first along the +z axis, the last in the xz plane with x > 0
56906 C...and the second having y < 0 and y > 0 with equal probability.
56908 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
56910 C...Double precision and integer declarations.
56911 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56912 IMPLICIT INTEGER(I-N)
56913 INTEGER PYK,PYCHGE,PYCOMP
56915 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56916 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56917 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56918 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56920 C...Standard checks.
56922 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56923 IPA=MAX(1,IABS(IP))
56924 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
56925 &'(PY4ENT:) writing outside PYJETS momory')
56930 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
56931 &'(PY4ENT:) unknown flavour code')
56933 C...Find masses. Reset K, P and V vectors.
56935 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
56936 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
56938 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
56939 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
56941 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
56942 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
56944 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
56945 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
56954 C...Check flavours.
56955 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
56956 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
56957 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
56958 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
56959 IF(MSTU(19).EQ.1) THEN
56961 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
56962 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
56963 & KQ1+KQ4.EQ.4)) THEN
56964 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
56967 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
56974 C...Store partons/particles in K vectors for normal case.
56977 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
56979 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
56982 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
56985 C...Store partons for parton shower evolution from q-g-g-qbar or
56987 ELSEIF(KQ1+KQ2.NE.0) THEN
56993 IF(KQ1.EQ.-1) KCS=5
56994 K(IPA,KCS)=MSTU(5)*(IPA+1)
56995 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
56996 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
56997 K(IPA+1,9-KCS)=MSTU(5)*IPA
56998 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
56999 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
57000 K(IPA+3,KCS)=MSTU(5)*IPA
57001 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
57003 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
57009 K(IPA,4)=MSTU(5)*(IPA+1)
57011 K(IPA+1,4)=MSTU(5)*IPA
57012 K(IPA+1,5)=K(IPA+1,4)
57013 K(IPA+2,4)=MSTU(5)*(IPA+3)
57014 K(IPA+2,5)=K(IPA+2,4)
57015 K(IPA+3,4)=MSTU(5)*(IPA+2)
57016 K(IPA+3,5)=K(IPA+3,4)
57019 C...Check kinematics.
57021 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
57022 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
57024 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
57025 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
57026 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
57027 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
57028 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
57029 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
57030 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
57031 STHE4=SQRT(1D0-CTHE4**2)
57032 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
57033 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
57034 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
57035 STHE2=SQRT(1D0-CTHE2**2)
57036 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
57037 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
57038 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
57039 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
57040 IF(MKERR.EQ.1) CALL PYERRM(13,
57041 &'(PY4ENT:) unphysical kinematical variable setup')
57043 C...Store partons/particles in P vectors.
57045 P(IPA,4)=SQRT(PA1**2+PM1**2)
57047 P(IPA+3,1)=PA4*STHE4
57048 P(IPA+3,3)=PA4*CTHE4
57049 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
57051 P(IPA+1,1)=PA2*STHE2*CPHI2
57052 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
57053 P(IPA+1,3)=PA2*CTHE2
57054 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
57056 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
57057 P(IPA+2,2)=-P(IPA+1,2)
57058 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
57059 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
57062 C...Set N. Optionally fragment/decay.
57064 IF(IP.EQ.0) CALL PYEXEC
57069 C*********************************************************************
57072 C...An interface from a two-fermion generator to include
57073 C...parton showers and hadronization.
57075 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
57077 C...Double precision and integer declarations.
57078 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57079 IMPLICIT INTEGER(I-N)
57080 INTEGER PYK,PYCHGE,PYCOMP
57082 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57083 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57084 SAVE /PYJETS/,/PYDAT1/
57086 DIMENSION IJOIN(2),INTAU(2)
57088 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57094 C...Loop through entries and pick up all final fermions/antifermions.
57098 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57100 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
57101 IF(K(I,2).GT.0) THEN
57105 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
57111 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
57117 C...Check that event is arranged according to conventions.
57118 IF(I1.EQ.0.OR.I2.EQ.0) THEN
57119 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
57122 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
57125 C...Check whether fermion pair is quarks or leptons.
57126 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
57128 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
57131 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
57134 C...Decide whether to allow or not photon radiation in showers.
57136 IF(IRAD.EQ.0) MSTJ(41)=1
57138 C...Do colour joining and parton showers.
57141 IF(IQL12.EQ.1) THEN
57144 CALL PYJOIN(2,IJOIN)
57146 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
57147 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
57148 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
57149 if(parj(200).ne.1.) CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57150 if(parj(200).eq.1.) CALL PYSHOWQ(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57153 C...Do fragmentation and decays. Possibly except tau decay.
57157 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
57171 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57179 C*********************************************************************
57182 C...An interface from a four-fermion generator to include
57183 C...parton showers and hadronization.
57185 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
57187 C...Double precision and integer declarations.
57188 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57189 IMPLICIT INTEGER(I-N)
57190 INTEGER PYK,PYCHGE,PYCOMP
57192 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57193 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57194 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
57195 COMMON/PYINT1/MINT(400),VINT(400)
57196 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
57198 DIMENSION IJOIN(2),INTAU(4)
57200 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57206 C...Loop through entries and pick up all final fermions/antifermions.
57212 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57214 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
57215 IF(K(I,2).GT.0) THEN
57218 ELSEIF(I3.EQ.0) THEN
57221 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
57226 ELSEIF(I4.EQ.0) THEN
57229 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
57235 C...Check that event is arranged according to conventions.
57236 IF(I3.EQ.0.OR.I4.EQ.0) THEN
57237 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
57239 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
57240 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
57243 C...Check which fermion pairs are quarks and which leptons.
57244 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
57246 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
57249 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
57251 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
57253 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
57256 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
57259 C...Decide whether to allow or not photon radiation in showers.
57261 IF(IRAD.EQ.0) MSTJ(41)=1
57263 C...Decide on dipole pairing.
57268 IF(IQL12.EQ.IQL34) THEN
57271 DELTA=ATOTSQ-A1SQ-A2SQ
57272 IF(ISTRAT.EQ.1) THEN
57273 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
57274 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
57275 ELSEIF(ISTRAT.EQ.2) THEN
57276 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
57277 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
57279 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
57285 C...If colour reconnection then bookkeep W+W- or Z0Z0
57286 C...and copy q qbar q qbar consecutively.
57287 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
57296 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
57300 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
57314 P(N+1,J)=P(IP1,J)+P(IP2,J)
57315 P(N+2,J)=P(IP3,J)+P(IP4,J)
57327 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
57329 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
57335 C...Remove original q qbar q qbar and update counters.
57336 K(IP1,1)=K(IP1,1)+10
57337 K(IP2,1)=K(IP2,1)+10
57338 K(IP3,1)=K(IP3,1)+10
57339 K(IP4,1)=K(IP4,1)+10
57350 C...Do colour joinings and parton showers.
57351 IF(IQL12.EQ.1) THEN
57354 CALL PYJOIN(2,IJOIN)
57356 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
57357 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
57358 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
57359 if(parj(200).ne.1.) CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57360 if(parj(200).eq.1.) CALL PYSHOWQ(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57363 IF(IQL34.EQ.1) THEN
57366 CALL PYJOIN(2,IJOIN)
57368 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
57369 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
57370 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
57371 if(parj(200).ne.1.) CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
57372 if(parj(200).eq.1.) CALL PYSHOWQ(IP3,IP4,SQRT(MAX(0D0,PM34S)))
57375 C...Optionally do colour reconnection.
57378 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
57379 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
57383 C...Do fragmentation and decays. Possibly except tau decay.
57387 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
57401 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57409 C*********************************************************************
57412 C...An interface from a six-fermion generator to include
57413 C...parton showers and hadronization.
57415 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
57417 C...Double precision and integer declarations.
57418 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57419 IMPLICIT INTEGER(I-N)
57420 INTEGER PYK,PYCHGE,PYCOMP
57422 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57423 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57424 SAVE /PYJETS/,/PYDAT1/
57426 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
57428 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57434 C...Loop through entries and pick up all final fermions/antifermions.
57442 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57444 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
57445 IF(K(I,2).GT.0) THEN
57448 ELSEIF(I3.EQ.0) THEN
57450 ELSEIF(I5.EQ.0) THEN
57453 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
57458 ELSEIF(I4.EQ.0) THEN
57460 ELSEIF(I6.EQ.0) THEN
57463 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
57469 C...Check that event is arranged according to conventions.
57470 IF(I5.EQ.0.OR.I6.EQ.0) THEN
57471 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
57473 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
57474 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
57477 C...Check which fermion pairs are quarks and which leptons.
57478 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
57480 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
57483 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
57485 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
57487 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
57490 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
57492 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
57494 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
57497 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
57500 C...Decide whether to allow or not photon radiation in showers.
57502 IF(IRAD.EQ.0) MSTJ(41)=1
57504 C...Allow dipole pairings only among leptons and quarks separately.
57507 IF(IQL34.EQ.IQL56) P13D=P13
57509 IF(IQL12.EQ.IQL34) P21D=P21
57511 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
57513 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
57515 IF(IQL12.EQ.IQL56) P32D=P32
57517 C...Decide whether t+tbar.
57519 IF(PYR(0).LT.PTOP) THEN
57522 C...If t+tbar: reconstruct t's.
57528 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
57529 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
57537 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
57539 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
57543 C...If t+tbar: colour join t's and let them shower.
57546 CALL PYJOIN(2,IJOIN)
57547 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
57548 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
57549 if(parj(200).ne.1.) CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
57550 if(parj(200).eq.1.) CALL PYSHOWQ(IT,ITB,SQRT(MAX(0D0,PMTTS)))
57551 C...If t+tbar: pick up the t's after shower.
57555 IF(K(I,2).EQ.6) ITNEW=I
57556 IF(K(I,2).EQ.-6) ITBNEW=I
57559 C...If t+tbar: loop over two top systems.
57574 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
57575 & '(PY6FRM:) not b in t decay')
57577 C...If t+tbar: find boost from original to new top frame.
57579 BETAO(J)=P(ITO,J)/P(ITO,4)
57580 BETAN(J)=P(ITN,J)/P(ITN,4)
57583 C...If t+tbar: boost copy of b by t shower and connect it in colour.
57593 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
57594 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
57595 K(IB,4)=MSTU(5)*ITN
57596 K(IB,5)=MSTU(5)*ITN
57597 K(ITN,4)=K(ITN,4)+IB
57598 K(ITN,5)=K(ITN,5)+IB
57599 K(ITN,1)=K(ITN,1)+10
57600 K(IBO,1)=K(IBO,1)+10
57602 C...If t+tbar: construct W recoiling against b.
57610 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
57611 IF(IABS(KCHW).EQ.3) THEN
57612 K(IW,2)=ISIGN(24,KCHW)
57614 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
57618 C...If t+tbar: construct W momentum, including boost by t shower.
57620 P(IW,J)=P(IW1,J)+P(IW2,J)
57622 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
57624 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
57625 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
57627 C...If t+tbar: boost b and W to top rest frame.
57629 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
57631 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57632 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57634 C...If t+tbar: let b shower and pick up modified W.
57635 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
57636 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
57637 if(parj(200).ne.1.) CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
57638 if(parj(200).eq.1.) CALL PYSHOWQ(IB,IW,SQRT(MAX(0D0,PMTS)))
57640 IF(IABS(K(I,2)).EQ.24) IWM=I
57643 C...If t+tbar: take copy of W decay products.
57652 K(IW1,1)=K(IW1,1)+10
57653 K(IW2,1)=K(IW2,1)+10
57654 K(IWM,1)=K(IWM,1)+10
57668 C...If t+tbar: boost W decay products, first by effects of t shower,
57669 C...then by those of b shower. b and its shower simple boost back.
57670 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
57671 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
57672 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57673 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
57674 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
57675 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
57676 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
57677 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
57678 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
57682 C...Decide on dipole pairing.
57686 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
57687 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
57691 ELSEIF(PRN.LT.P12D+P13D) THEN
57695 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
57699 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
57703 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
57713 C...Do colour joinings and parton showers
57714 C...(except ones already made for t+tbar).
57716 IF(IQL12.EQ.1) THEN
57719 CALL PYJOIN(2,IJOIN)
57721 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
57722 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
57723 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
57724 if(parj(200).ne.1.) CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57725 if(parj(200).eq.1.) CALL PYSHOWQ(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57728 IF(IQL34.EQ.1) THEN
57731 CALL PYJOIN(2,IJOIN)
57733 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
57734 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
57735 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
57736 if(parj(200).ne.1.) CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
57737 if(parj(200).eq.1.) CALL PYSHOWQ(IP3,IP4,SQRT(MAX(0D0,PM34S)))
57739 IF(IQL56.EQ.1) THEN
57742 CALL PYJOIN(2,IJOIN)
57744 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
57745 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
57746 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
57747 if(parj(200).ne.1.) CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
57748 if(parj(200).eq.1.) CALL PYSHOWQ(IP5,IP6,SQRT(MAX(0D0,PM56S)))
57751 C...Do fragmentation and decays. Possibly except tau decay.
57755 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
57769 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57777 C*********************************************************************
57780 C...An interface from a four-parton generator to include
57781 C...parton showers and hadronization.
57783 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
57785 C...Double precision and integer declarations.
57786 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57787 IMPLICIT INTEGER(I-N)
57788 INTEGER PYK,PYCHGE,PYCOMP
57790 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57791 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57792 SAVE /PYJETS/,/PYDAT1/
57794 DIMENSION IJOIN(2),PTOT(4),BETA(3)
57796 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57802 C...Loop through entries and pick up all final partons.
57808 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57810 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
57811 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
57814 ELSEIF(I3.EQ.0) THEN
57817 CALL PYERRM(16,'(PY4JET:) more than two quarks')
57819 ELSEIF(K(I,2).LT.0) THEN
57822 ELSEIF(I4.EQ.0) THEN
57825 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
57830 ELSEIF(I4.EQ.0) THEN
57833 CALL PYERRM(16,'(PY4JET:) more than two gluons')
57839 C...Check that event is arranged according to conventions.
57840 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
57841 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
57843 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
57844 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
57847 C...Check whether second pair are quarks or gluons.
57848 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
57850 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
57853 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
57856 C...Boost partons to their cm frame.
57858 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
57860 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
57862 BETA(J)=PTOT(J)/PTOT(4)
57864 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57865 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57866 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57867 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57870 C...Decide and set up shower history for q qbar q' qbar' events.
57871 IF(IQG34.EQ.1) THEN
57872 W1=PY4JTW(0,I1,I3,I4)
57873 W2=PY4JTW(0,I2,I3,I4)
57874 IF(W1.GT.PYR(0)*(W1+W2)) THEN
57875 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
57877 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
57880 C...Decide and set up shower history for q qbar g g events.
57882 W1=PY4JTW(I1,I3,I2,I4)
57883 W2=PY4JTW(I1,I4,I2,I3)
57884 W3=PY4JTW(0,I3,I1,I4)
57885 W4=PY4JTW(0,I4,I1,I3)
57886 W5=PY4JTW(0,I3,I2,I4)
57887 W6=PY4JTW(0,I4,I2,I3)
57888 W7=PY4JTW(0,I1,I3,I4)
57889 W8=PY4JTW(0,I2,I3,I4)
57890 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
57892 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
57893 ELSEIF(W1+W2.GT.WR) THEN
57894 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
57895 ELSEIF(W1+W2+W3.GT.WR) THEN
57896 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
57897 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
57898 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
57899 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
57900 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
57901 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
57902 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
57903 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
57904 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
57906 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
57910 C...Boost back original partons and mark them as deleted.
57911 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
57912 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
57913 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
57914 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
57920 C...Rotate shower initiating partons to be along z axis.
57921 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
57922 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
57923 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
57924 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
57926 C...Set up copy of shower initiating partons as on mass shell.
57936 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
57947 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
57948 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
57950 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
57952 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
57955 C...Decide whether to allow or not photon radiation in showers.
57956 C...Connect up colours.
57958 IF(IRAD.EQ.0) MSTJ(41)=1
57961 CALL PYJOIN(2,IJOIN)
57963 C...Decide on maximum virtuality and do parton shower.
57964 IF(PMAX.LT.PARJ(82)) THEN
57969 if(parj(200).ne.1.) CALL PYSHOW(NSAV+1,-100,PQMAX)
57970 if(parj(200).eq.1.) CALL PYSHOWQ(NSAV+1,-100,PQMAX)
57972 C...Rotate and boost back system.
57973 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
57975 C...Do fragmentation and decays.
57978 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57987 C*********************************************************************
57990 C...Auxiliary to PY4JET, to evaluate weight of configuration.
57992 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
57994 C...Double precision and integer declarations.
57995 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57996 IMPLICIT INTEGER(I-N)
57997 INTEGER PYK,PYCHGE,PYCOMP
57999 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58002 C...First case: when both original partons radiate.
58003 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
58006 P(N+1,J)=P(IA1,J)+P(IA2,J)
58007 P(N+2,J)=P(IA3,J)+P(IA4,J)
58009 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58011 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
58013 Z1=P(IA1,4)/P(N+1,4)
58014 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
58015 Z2=P(IA3,4)/P(N+2,4)
58016 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
58018 C...Second case: when one original parton radiates to three.
58019 C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
58022 P(N+2,J)=P(IA3,J)+P(IA4,J)
58023 P(N+1,J)=P(N+2,J)+P(IA2,J)
58025 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58027 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
58029 IF(K(IA2,2).EQ.21) THEN
58030 Z1=P(N+2,4)/P(N+1,4)
58031 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
58034 Z1=P(IA2,4)/P(N+1,4)
58035 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
58038 Z2=P(IA3,4)/P(N+2,4)
58039 IF(K(IA2,2).EQ.21) THEN
58040 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
58042 ELSEIF(K(IA3,2).EQ.21) THEN
58043 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
58045 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
58055 C*********************************************************************
58058 C...Auxiliary to PY4JET, to set up chosen configuration.
58060 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
58062 C...Double precision and integer declarations.
58063 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58064 IMPLICIT INTEGER(I-N)
58065 INTEGER PYK,PYCHGE,PYCOMP
58067 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58079 C...First case: when both original partons radiate.
58080 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
58083 C...Set up flavour and history pointers for new partons.
58101 C...Set up momenta for new partons.
58103 P(N+1,J)=P(IA1,J)+P(IA2,J)
58104 P(N+2,J)=P(IA3,J)+P(IA4,J)
58110 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58112 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
58114 QMAX=MIN(P(N+1,5),P(N+2,5))
58116 C...Second case: q radiates twice.
58117 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
58118 C...IA5=N+2 does not radiate.
58119 ELSEIF(K(IA2,2).EQ.21) THEN
58121 C...Set up flavour and history pointers for new partons.
58139 C...Set up momenta for new partons.
58141 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
58143 P(N+3,J)=P(IA3,J)+P(IA4,J)
58148 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58150 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
58154 C...Third case: q radiates g, g branches.
58155 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
58156 C...IA5=N+2 does not radiate.
58159 C...Set up flavour and history pointers for new partons.
58177 C...Set up momenta for new partons.
58179 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
58182 P(N+4,J)=P(IA3,J)+P(IA4,J)
58186 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58188 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
58198 C*********************************************************************
58201 C...Connects a sequence of partons with colour flow indices,
58202 C...as required for subsequent shower evolution (or other operations).
58204 SUBROUTINE PYJOIN(NJOIN,IJOIN)
58206 C...Double precision and integer declarations.
58207 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58208 IMPLICIT INTEGER(I-N)
58209 INTEGER PYK,PYCHGE,PYCOMP
58211 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58212 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58213 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58214 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58218 C...Check that partons are of right types to be connected.
58219 IF(NJOIN.LT.2) GOTO 120
58223 IF(I.LE.0.OR.I.GT.N) GOTO 120
58224 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
58226 IF(KC.EQ.0) GOTO 120
58227 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
58228 IF(KQ.EQ.0) GOTO 120
58229 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
58230 IF(KQ.NE.2) KQSUM=KQSUM+KQ
58231 IF(IJN.EQ.1) KQS=KQ
58233 IF(KQSUM.NE.0) GOTO 120
58235 C...Connect the partons sequentially (closing for gluon loop).
58237 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
58241 IF(IJN.NE.1) IP=IJOIN(IJN-1)
58242 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
58243 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
58244 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
58245 K(I,KCS)=MSTU(5)*IN
58246 K(I,9-KCS)=MSTU(5)*IP
58247 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
58248 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
58251 C...Error exit: no action taken.
58253 120 CALL PYERRM(12,
58254 &'(PYJOIN:) given entries can not be joined by one string')
58259 C*********************************************************************
58262 C...Sets values of commonblock variables.
58264 SUBROUTINE PYGIVE(CHIN)
58266 C...Double precision and integer declarations.
58267 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58268 IMPLICIT INTEGER(I-N)
58269 INTEGER PYK,PYCHGE,PYCOMP
58271 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58272 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58273 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58274 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
58275 COMMON/PYDAT4/CHAF(500,2)
58277 COMMON/PYDATR/MRPY(6),RRPY(100)
58278 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
58279 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
58280 COMMON/PYINT1/MINT(400),VINT(400)
58281 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
58282 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
58283 COMMON/PYINT4/MWID(500),WIDS(500,5)
58284 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
58285 COMMON/PYINT6/PROC(0:500)
58287 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
58288 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
58290 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
58291 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
58292 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
58293 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
58294 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
58295 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/
58296 C...Local arrays and character variables.
58297 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
58298 &CHNEW2*28,CHNAM*6,CHVAR(54)*6,CHALP(2)*26,CHIND*8,CHINI*10,
58300 DIMENSION MSVAR(54,8)
58302 C...For each variable to be translated give: name,
58303 C...integer/real/character, no. of indices, lower&upper index bounds.
58304 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
58305 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
58306 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
58307 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
58308 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
58309 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
58311 DATA ((MSVAR(I,J),J=1,8),I=1,54)/ 1,7*0, 1,2,1,4000,1,5,2*0,
58312 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
58313 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
58314 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
58315 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
58316 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
58317 &1,1,1,6,4*0, 2,1,1,100,4*0,
58318 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
58319 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
58320 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
58321 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
58322 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
58323 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
58324 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
58325 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
58326 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
58327 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
58328 &1,1,0,99,4*0, 2,1,0,99,4*0/
58329 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
58330 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
58332 C...Length of character variable. Subdivide it into instructions.
58333 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
58334 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
58338 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
58341 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
58343 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
58348 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
58350 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
58352 C...Send off decay-mode on/off commands to PYONOF.
58355 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
58357 IF(IONOF.EQ.1) THEN
58362 C...Peel off any text following exclamation mark.
58364 DO 140 LLOW2=LHIG2,1,-1
58365 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
58367 IF(LBIT.EQ.0) RETURN
58369 C...Identify commonblock variable.
58372 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
58373 &LNAM.LE.6) GOTO 150
58374 CHNAM=CHBIT(1:LNAM-1)//' '
58375 DO 170 LCOM=1,LNAM-1
58377 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
58378 & CHALP(2)(LALP:LALP)
58383 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
58386 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
58388 IF(LLOW.LT.LTOT) GOTO 120
58392 C...Identify any indices.
58397 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
58400 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
58402 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
58403 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
58404 & IVAR.EQ.37)) THEN
58405 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
58406 READ(CHIND,'(I8)') KF
58408 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
58410 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
58413 IF(LLOW.LT.LTOT) GOTO 120
58416 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
58417 READ(CHIND,'(I8)') I1
58420 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
58423 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
58426 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
58428 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
58429 READ(CHIND,'(I8)') I2
58431 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
58434 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
58437 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
58439 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
58440 READ(CHIND,'(I8)') I3
58445 C...Check that indices allowed.
58447 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
58448 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
58450 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
58452 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
58454 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
58456 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
58459 IF(LLOW.LT.LTOT) GOTO 120
58463 C...Save old value of variable.
58466 ELSEIF(IVAR.EQ.2) THEN
58468 ELSEIF(IVAR.EQ.3) THEN
58470 ELSEIF(IVAR.EQ.4) THEN
58472 ELSEIF(IVAR.EQ.5) THEN
58474 ELSEIF(IVAR.EQ.6) THEN
58476 ELSEIF(IVAR.EQ.7) THEN
58478 ELSEIF(IVAR.EQ.8) THEN
58480 ELSEIF(IVAR.EQ.9) THEN
58482 ELSEIF(IVAR.EQ.10) THEN
58484 ELSEIF(IVAR.EQ.11) THEN
58486 ELSEIF(IVAR.EQ.12) THEN
58488 ELSEIF(IVAR.EQ.13) THEN
58490 ELSEIF(IVAR.EQ.14) THEN
58492 ELSEIF(IVAR.EQ.15) THEN
58494 ELSEIF(IVAR.EQ.16) THEN
58496 ELSEIF(IVAR.EQ.17) THEN
58497 CHOLD=CHAF(I1,I2)(1:8)
58498 ELSEIF(IVAR.EQ.18) THEN
58500 ELSEIF(IVAR.EQ.19) THEN
58502 ELSEIF(IVAR.EQ.20) THEN
58504 ELSEIF(IVAR.EQ.21) THEN
58506 ELSEIF(IVAR.EQ.22) THEN
58508 ELSEIF(IVAR.EQ.23) THEN
58510 ELSEIF(IVAR.EQ.24) THEN
58512 ELSEIF(IVAR.EQ.25) THEN
58514 ELSEIF(IVAR.EQ.26) THEN
58516 ELSEIF(IVAR.EQ.27) THEN
58518 ELSEIF(IVAR.EQ.28) THEN
58520 ELSEIF(IVAR.EQ.29) THEN
58522 ELSEIF(IVAR.EQ.30) THEN
58524 ELSEIF(IVAR.EQ.31) THEN
58526 ELSEIF(IVAR.EQ.32) THEN
58528 ELSEIF(IVAR.EQ.33) THEN
58529 IOLD=ICOL(I1,I2,I3)
58530 ELSEIF(IVAR.EQ.34) THEN
58532 ELSEIF(IVAR.EQ.35) THEN
58534 ELSEIF(IVAR.EQ.36) THEN
58536 ELSEIF(IVAR.EQ.37) THEN
58538 ELSEIF(IVAR.EQ.38) THEN
58540 ELSEIF(IVAR.EQ.39) THEN
58542 ELSEIF(IVAR.EQ.40) THEN
58544 ELSEIF(IVAR.EQ.41) THEN
58546 ELSEIF(IVAR.EQ.42) THEN
58547 ROLD=SIGT(I1,I2,I3)
58548 ELSEIF(IVAR.EQ.43) THEN
58550 ELSEIF(IVAR.EQ.44) THEN
58552 ELSEIF(IVAR.EQ.45) THEN
58554 ELSEIF(IVAR.EQ.46) THEN
58556 ELSEIF(IVAR.EQ.47) THEN
58558 ELSEIF(IVAR.EQ.48) THEN
58560 ELSEIF(IVAR.EQ.49) THEN
58562 ELSEIF(IVAR.EQ.50) THEN
58563 ROLD=RVLAM(I1,I2,I3)
58564 ELSEIF(IVAR.EQ.51) THEN
58565 ROLD=RVLAMP(I1,I2,I3)
58566 ELSEIF(IVAR.EQ.52) THEN
58567 ROLD=RVLAMB(I1,I2,I3)
58568 ELSEIF(IVAR.EQ.53) THEN
58570 ELSEIF(IVAR.EQ.54) THEN
58574 C...Print current value of variable. Loop back.
58575 IF(LNAM.GE.LBIT) THEN
58577 CHBIT(15:60)=' has the value '
58578 IF(MSVAR(IVAR,1).EQ.1) THEN
58579 WRITE(CHBIT(51:60),'(I10)') IOLD
58580 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
58581 WRITE(CHBIT(47:60),'(F14.5)') ROLD
58582 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
58587 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58589 IF(LLOW.LT.LTOT) GOTO 120
58593 C...Read in new variable value.
58594 IF(MSVAR(IVAR,1).EQ.1) THEN
58596 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
58597 READ(CHINI,'(I10)') INEW
58598 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
58600 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
58602 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
58603 CHNEW=CHBIT(LNAM+1:LBIT)//' '
58605 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
58608 C...Store new variable value.
58611 ELSEIF(IVAR.EQ.2) THEN
58613 ELSEIF(IVAR.EQ.3) THEN
58615 ELSEIF(IVAR.EQ.4) THEN
58617 ELSEIF(IVAR.EQ.5) THEN
58619 ELSEIF(IVAR.EQ.6) THEN
58621 ELSEIF(IVAR.EQ.7) THEN
58623 ELSEIF(IVAR.EQ.8) THEN
58625 ELSEIF(IVAR.EQ.9) THEN
58627 ELSEIF(IVAR.EQ.10) THEN
58629 ELSEIF(IVAR.EQ.11) THEN
58631 ELSEIF(IVAR.EQ.12) THEN
58633 ELSEIF(IVAR.EQ.13) THEN
58635 ELSEIF(IVAR.EQ.14) THEN
58637 ELSEIF(IVAR.EQ.15) THEN
58639 ELSEIF(IVAR.EQ.16) THEN
58641 ELSEIF(IVAR.EQ.17) THEN
58643 ELSEIF(IVAR.EQ.18) THEN
58645 ELSEIF(IVAR.EQ.19) THEN
58647 ELSEIF(IVAR.EQ.20) THEN
58649 ELSEIF(IVAR.EQ.21) THEN
58651 ELSEIF(IVAR.EQ.22) THEN
58653 ELSEIF(IVAR.EQ.23) THEN
58655 ELSEIF(IVAR.EQ.24) THEN
58657 ELSEIF(IVAR.EQ.25) THEN
58659 ELSEIF(IVAR.EQ.26) THEN
58661 ELSEIF(IVAR.EQ.27) THEN
58663 ELSEIF(IVAR.EQ.28) THEN
58665 ELSEIF(IVAR.EQ.29) THEN
58667 ELSEIF(IVAR.EQ.30) THEN
58669 ELSEIF(IVAR.EQ.31) THEN
58671 ELSEIF(IVAR.EQ.32) THEN
58673 ELSEIF(IVAR.EQ.33) THEN
58674 ICOL(I1,I2,I3)=INEW
58675 ELSEIF(IVAR.EQ.34) THEN
58677 ELSEIF(IVAR.EQ.35) THEN
58679 ELSEIF(IVAR.EQ.36) THEN
58681 ELSEIF(IVAR.EQ.37) THEN
58683 ELSEIF(IVAR.EQ.38) THEN
58685 ELSEIF(IVAR.EQ.39) THEN
58687 ELSEIF(IVAR.EQ.40) THEN
58689 ELSEIF(IVAR.EQ.41) THEN
58691 ELSEIF(IVAR.EQ.42) THEN
58692 SIGT(I1,I2,I3)=RNEW
58693 ELSEIF(IVAR.EQ.43) THEN
58695 ELSEIF(IVAR.EQ.44) THEN
58697 ELSEIF(IVAR.EQ.45) THEN
58699 ELSEIF(IVAR.EQ.46) THEN
58701 ELSEIF(IVAR.EQ.47) THEN
58703 ELSEIF(IVAR.EQ.48) THEN
58705 ELSEIF(IVAR.EQ.49) THEN
58707 ELSEIF(IVAR.EQ.50) THEN
58708 RVLAM(I1,I2,I3)=RNEW
58709 ELSEIF(IVAR.EQ.51) THEN
58710 RVLAMP(I1,I2,I3)=RNEW
58711 ELSEIF(IVAR.EQ.52) THEN
58712 RVLAMB(I1,I2,I3)=RNEW
58713 ELSEIF(IVAR.EQ.53) THEN
58715 ELSEIF(IVAR.EQ.54) THEN
58719 C...Write old and new value. Loop back.
58721 CHBIT(15:60)=' changed from to '
58722 IF(MSVAR(IVAR,1).EQ.1) THEN
58723 WRITE(CHBIT(33:42),'(I10)') IOLD
58724 WRITE(CHBIT(51:60),'(I10)') INEW
58725 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58726 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
58727 WRITE(CHBIT(29:42),'(F14.5)') ROLD
58728 WRITE(CHBIT(47:60),'(F14.5)') RNEW
58729 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58730 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
58733 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58735 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
58736 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
58739 IF(LLOW.LT.LTOT) GOTO 120
58741 C...Format statement for output on unit MSTU(11) (by default 6).
58742 5000 FORMAT(5X,A60)
58743 5100 FORMAT(5X,A88)
58748 C*********************************************************************
58751 C...Switches on and off decay channel by search for match.
58753 SUBROUTINE PYONOF(CHIN)
58755 C...Double precision and integer declarations.
58756 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58757 IMPLICIT INTEGER(I-N)
58758 INTEGER PYK,PYCHGE,PYCOMP
58760 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58761 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
58762 SAVE /PYDAT1/,/PYDAT3/
58763 C...Local arrays and character variables.
58764 INTEGER KFCMP(10),KFTMP(10)
58765 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
58767 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
58768 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
58770 C...Determine length of character variable.
58774 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
58777 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
58779 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
58781 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
58783 C...Find colon separator and particle code.
58785 120 LCOLON=LCOLON+1
58786 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
58788 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
58789 READ(CHCODE,'(I8)',ERR=300) KF
58792 C...Done if unknown code or no decay channels.
58794 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
58799 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
58800 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
58804 C...Find command name up to blank or equal sign.
58807 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
58808 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
58810 LMODE=LSEP-LCOLON-1
58811 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
58813 C...Convert to uppercase.
58814 DO 150 LCOM=1,LMODE
58816 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
58817 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
58821 C...Identify command. Failed if not identified.
58823 IF(CHMODE.EQ.'ALLOFF') MODE=1
58824 IF(CHMODE.EQ.'ALLON') MODE=2
58825 IF(CHMODE.EQ.'OFFIFANY') MODE=3
58826 IF(CHMODE.EQ.'ONIFANY') MODE=4
58827 IF(CHMODE.EQ.'OFFIFALL') MODE=5
58828 IF(CHMODE.EQ.'ONIFALL') MODE=6
58829 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
58830 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
58832 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
58836 C...Simple cases when all on or all off.
58837 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
58838 WRITE(MSTU(11),1000) KF,CHMODE
58839 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
58840 IF(MDME(IDC,1).LT.0) GOTO 160
58846 C...Identify matching list.
58850 IF(LBEG.GT.LEN) GOTO 190
58851 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
58852 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
58855 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
58856 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
58857 IF(LEND.LT.LEN) LEND=LEND-1
58859 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
58860 READ(CHCODE,'(I8)',ERR=300) KFREAD
58862 KFCMP(NCMP)=IABS(KFREAD)
58864 IF(NCMP.LT.10) GOTO 170
58866 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
58868 C...Only one matching required.
58869 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
58870 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
58871 IF(MDME(IDC,1).LT.0) GOTO 220
58873 KFNOW=IABS(KFDP(IDC,IKF))
58874 IF(KFNOW.EQ.0) GOTO 210
58876 IF(KFCMP(ICMP).EQ.KFNOW) THEN
58886 C...Multiple matchings required.
58887 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
58888 IF(MDME(IDC,1).LT.0) GOTO 260
58891 KFTMP(ITMP)=KFCMP(ITMP)
58895 KFNOW=IABS(KFDP(IDC,IKF))
58896 IF(KFNOW.EQ.0) GOTO 250
58899 IF(KFTMP(ITMP).EQ.KFNOW) THEN
58900 KFTMP(ITMP)=KFTMP(NTMP)
58906 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
58907 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
58908 & MDME(IDC,1)=MODE-7
58912 C...Error exit for impossible read of particle code.
58913 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
58916 C...Formats for output.
58917 1000 FORMAT(' Decays for',I8,' set ',A10)
58918 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
58922 C*********************************************************************
58925 C...Presets for a few specific underlying-event and min-bias tunes
58926 C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
58927 C...others require particular versions of pythia (e.g. the SCI and GAL
58928 C...models). See below for details.
58929 SUBROUTINE PYTUNE(ITUNE)
58931 C ITUNE NAME (detailed descriptions below)
58932 C 0 Default : No settings changed => linked Pythia version's defaults.
58933 C ====== Old UE, Q2-ordered showers ==========================================
58934 C 100 A : Rick Field's CDF Tune A
58935 C 101 AW : Rick Field's CDF Tune AW
58936 C 102 BW : Rick Field's CDF Tune BW
58937 C 103 DW : Rick Field's CDF Tune DW
58938 C 104 DWT : Rick Field's CDF Tune DW with slower UE energy scaling
58939 C 105 QW : Rick Field's CDF Tune QW (NB: needs CTEQ6.1M pdfs externally)
58940 C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune (ATLAS DC2 / Rome)
58941 C 107 ACR : Tune A modified with annealing CR
58942 C 108 D6 : Rick Field's CDF Tune D6 (NB: needs CTEQ6L pdfs externally)
58943 C 109 D6T : Rick Field's CDF Tune D6T (NB: needs CTEQ6L pdfs externally)
58944 C ====== Intermediate Models =================================================
58945 C 200 IM 1 : Intermediate model: new UE, Q2-ordered showers, annealing CR
58946 C 201 APT : Tune A modified to use pT-ordered final-state showers
58947 C ====== New UE, interleaved pT-ordered showers, annealing CR ================
58948 C 300 S0 : Sandhoff-Skands Tune 0
58949 C 301 S1 : Sandhoff-Skands Tune 1
58950 C 302 S2 : Sandhoff-Skands Tune 2
58951 C 303 S0A : S0 with "Tune A" UE energy scaling
58952 C 304 NOCR : New UE "best try" without colour reconnections
58953 C 305 Old : New UE, original (primitive) colour reconnections
58954 C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune (needs CTEQ6L externally)
58955 C ======= The Uppsala models =================================================
58956 C ( NB! must be run with special modified Pythia 6.215 version )
58957 C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
58958 C 400 GAL 0 : Generalized area-law model. Old parameters
58959 C 401 SCI 0 : Soft-Colour-Interaction model. Old parameters
58960 C 402 GAL 1 : Generalized area-law model. Tevatron MB retuned (Skands)
58961 C 403 SCI 1 : Soft-Colour-Interaction model. Tevatron MB retuned (Skands)
58965 C Quick Dictionary:
58966 C BE : Bose-Einstein
58967 C BR : Beam Remnants
58968 C CR : Colour Reconnections
58969 C HAD: Hadronization
58970 C ISR/FSR: Initial-State Radiation / Final-State Radiation
58971 C FSI: Final-State Interactions (=CR+BE)
58972 C MB : Minimum-bias
58973 C MI : Multiple Interactions
58974 C UE : Underlying Event
58976 C A (100) and AW (101). Old UE model, Q2-ordered showers.
58977 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58978 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58979 C...Key feature: extensively compared to CDF data (R.D. Field).
58980 C...* Large starting scale for ISR (PARP(67)=4)
58981 C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
58982 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
58984 C BW (102). Old UE model, Q2-ordered showers.
58985 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58986 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58987 C...Key feature: extensively compared to CDF data (R.D. Field).
58988 C...NB: Can also be run with Pythia 6.2 or 6.312+
58989 C...* Small starting scale for ISR (PARP(67)=1)
58990 C...* BW has more radiation due to smaller mu_R choice in alpha_s.
58991 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
58993 C DW (103) and DWT (104). Old UE model, Q2-ordered showers.
58994 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58995 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58996 C...Key feature: extensively compared to CDF data (R.D. Field).
58997 C...NB: Can also be run with Pythia 6.2 or 6.312+
58998 C...* Intermediate starting scale for ISR (PARP(67)=2.5)
58999 C...* DWT has a different reference energy, the same as the "S" models
59000 C... below, leading to more UE activity at the LHC, but less at RHIC.
59001 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
59003 C QW (105). Old UE model, Q2-ordered showers.
59004 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
59005 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
59006 C...Key feature: uses CTEQ61 (external pdf library must be linked)
59008 C ATLAS-DC2 (106). Old UE model, Q2-ordered showers.
59009 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
59010 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
59011 C...Key feature: tune used by the ATLAS collaboration.
59013 C ACR (107). Old UE model, Q2-ordered showers, annealing CR.
59014 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
59015 C...Key feature: Tune A modified to use annealing CR.
59016 C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
59018 C D6 (108) and D6T (109). Old UE model, Q2-ordered showers, CTEQ6L PDF.
59019 C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
59021 C...IM1 (200). Intermediate model, Q2-ordered showers.
59022 C...Key feature: new UE model with Q2-ordered showers and no interleaving.
59023 C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
59024 C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
59026 C...APT (201). Old UE model, pT-ordered final-state showers
59027 C...Key feature: Rick Field's Tune A, but with new final-state showers
59029 C S0 (300) and S0A (303). New UE model, pT-ordered showers.
59030 C...Key feature: large amount of multiple interactions
59031 C...* Somewhat faster than the other colour annealing scenarios.
59032 C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
59033 C... from Tune A, leading to less UE at the LHC, but more at RHIC.
59034 C...* Small amount of radiation.
59035 C...* Large amount of low-pT MI
59036 C...* Low degree of proton lumpiness (broad matter dist.)
59037 C...* CR Type S (driven by free triplets), of medium strength.
59038 C...* See: Pythia6402 update notes or later.
59040 C S1 (301). New UE model, pT-ordered showers.
59041 C...Key feature: large amount of radiation.
59042 C...* Large amount of low-pT perturbative ISR
59043 C...* Large amount of FSR off ISR partons
59044 C...* Small amount of low-pT multiple interactions
59045 C...* Moderate degree of proton lumpiness
59046 C...* Least aggressive CR type (S+S Type I), but with large strength
59047 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
59049 C S2 (302). New UE model, pT-ordered showers.
59050 C...Key feature: very lumpy proton + gg string cluster formation allowed
59051 C...* Small amount of radiation
59052 C...* Moderate amount of low-pT MI
59053 C...* High degree of proton lumpiness (more spiky matter distribution)
59054 C...* Most aggressive CR type (S+S Type II), but with small strength
59055 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
59057 C NOCR (304). New UE model, pT-ordered showers.
59058 C...Key feature: no colour reconnections (NB: "Best fit" only).
59059 C...* NB: <pT>(Nch) problematic in this tune.
59060 C...* Small amount of radiation
59061 C...* Small amount of low-pT MI
59062 C...* Low degree of proton lumpiness
59063 C...* Large BR composite x enhancement factor
59064 C...* Most clever colour flow without CR ("Lambda ordering")
59066 C ATLAS-CSC (306). New UE mode, pT-ordered showers, CTEQ6L.
59067 C...Key feature: 11-parameter ATLAS tune of the new framework.
59068 C...* Old (pre-annealing) colour reconnections a la 305.
59069 C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
59071 C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
59072 C...with an unmodified Pythia distribution.
59073 C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
59075 C ::: + Future improvements?
59076 C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
59077 C (problem: K-factor affects everything so only works as
59078 C intended for min-bias, not for UE ... probably need a
59079 C better long-term solution to handle UE as well. Anyway,
59080 C Mark uses MSTP(33) and PARP(31)-PARP(33).)
59082 C...Global statements
59083 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59084 INTEGER PYK,PYCHGE,PYCOMP
59087 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59088 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59090 C...SCI and GAL Commonblocks
59091 COMMON /SCIPAR/MSWI(2),PARSCI(2)
59093 C...Internal parameters
59094 PARAMETER(MXTUNS=500)
59095 CHARACTER*8 CHVERS, CHDOC
59096 PARAMETER (CHVERS='1.012 ',CHDOC='Sep 2007')
59097 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
59098 CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
59099 & CHPARJ(41:100), CH40
59102 DATA (CHNAMS(I),I=0,1)/'Default',' '/
59103 DATA (CHNAMS(I),I=100,110)/
59104 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
59105 & 'ATLAS Tune','Tune ACR','Tune D6','Tune D6T',' '/
59106 DATA (CHNAMS(I),I=300,310)/
59107 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
59108 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',2*' '/
59109 DATA (CHNAMS(I),I=200,210)/
59110 & 'IM Tune 1','Tune APT',9*' '/
59111 DATA (CHNAMS(I),I=400,410)/
59112 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',7*' '/
59113 DATA (CHMSTJ(I),I=11,20)/
59114 & 'HAD choice of fragmentation function(s)',4*' ',
59115 & 'HAD treatment of small-mass systems',4*' '/
59116 DATA (CHMSTJ(I),I=41,50)/
59117 & 'FSR type (Q2 or pT) for old framework',9*' '/
59118 DATA (CHMSTP(I),I=51,100)/
59119 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
59120 6 'ISR master switch',6*' ',
59121 6 'ISR phase space choice & ME corrections',' ',
59122 7 'ISR IR regularization scheme',' ',
59123 7 'ISR scheme for FSR off ISR',8*' ',
59125 8 'UE hadron transverse mass distribution',5*' ',
59126 8 'BR composite scheme','BR colour scheme',
59127 9 'BR primordial kT compensation',
59128 9 'BR primordial kT distribution',
59129 9 'BR energy partitioning scheme',2*' ',
59130 9 'FSI colour (re-)connection model',5*' '/
59131 DATA (CHPARP(I),I=61,100)/
59132 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
59133 6 2*' ','ISR Q2max factor',3*' ',
59134 7 'FSR Q2max factor for non-s-channel procs',5*' ',
59135 7 'FSI colour reconnection turnoff scale',
59136 7 'FSI colour reconnection strength',
59137 7 'BR composite x enhancement','BR breakup suppression',
59138 8 2*'UE IR cutoff at reference ecm',
59139 8 2*'UE mass distribution parameter',
59140 8 'UE gg colour correlated fraction','UE total gg fraction',
59142 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
59143 9 'BR primordial kT width <|kT|>',' ',
59144 9 'BR primordial kT UV cutoff',7*' '/
59145 DATA (CHPARJ(I),I=41,90)/
59146 4 ' ','HAD string parameter b',8*' ',
59147 5 3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
59149 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
59150 SAVE /PYDAT1/,/PYPARS/
59153 C...1) Shorthand notation
59156 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
59157 CHNAME=CHNAMS(ITUNE)
59158 IF (ITUNE.EQ.0) GOTO 9999
59160 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
59165 IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
59167 C...3) Tune parameters
59169 C=============================================================================
59170 C...Tunes S0, S1, S2, S0A, NOCR, and RAP (by P. Skands)
59171 IF (ITUNE.GE.300.AND.ITUNE.LE.305) THEN
59172 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
59173 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
59174 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59183 C...UE on, new model.
59185 C...Slow IR cutoff energy scaling by default
59188 C...Switch off trial joinings
59190 C...Primordial kT cutoff
59193 C...S0 (300), S0A (303)
59194 IF (ITUNE.EQ.300.OR.ITUNE.EQ.303) THEN
59196 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
59197 WRITE(M11,5030) CH60
59198 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
59199 WRITE(M11,5030) CH60
59200 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59201 WRITE(M11,5030) CH60
59203 C...Smooth ISR, low FSR
59208 C...Transverse density profile.
59211 C...Colour Reconnections
59215 C... Reference energy for pT0 and energy scaling pace.
59216 IF (ITUNE.EQ.303) PARP(90)=0.25D0
59217 C...Lambda_FSR scale.
59221 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59228 ELSEIF(ITUNE.EQ.301) 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...Sharp ISR, high FSR
59240 C...Colour Reconnections
59243 C...Transverse density profile.
59246 C...Lambda_FSR scale.
59250 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59257 ELSEIF(ITUNE.EQ.302) THEN
59259 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
59260 WRITE(M11,5030) CH60
59261 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59262 WRITE(M11,5030) CH60
59264 C...Smooth ISR, low FSR
59269 C...Transverse density profile.
59272 C...Colour Reconnections
59275 C...Lambda_FSR scale.
59279 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59286 ELSEIF(ITUNE.EQ.304) THEN
59288 CH60='"best try" without colour reconnections'
59289 WRITE(M11,5030) CH60
59290 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
59291 WRITE(M11,5030) CH60
59292 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59293 WRITE(M11,5030) CH60
59295 C...Smooth ISR, low FSR
59300 C...Transverse density profile.
59303 C...Colour Reconnections
59305 C...Lambda_FSR scale.
59309 C...Lambda order, Valence qq, large qq x enhc, BR-g-BR supp
59315 C..."Lo FSR" retune (305)
59316 ELSEIF(ITUNE.EQ.305) THEN
59318 CH60='"Lo FSR retune" with primitive colour reconnections'
59319 WRITE(M11,5030) CH60
59320 CH60='see T. Sjostrand & P. Skands, EPJC39(2005)129'
59321 WRITE(M11,5030) CH60
59323 C...Smooth ISR, low FSR
59328 C...Transverse density profile.
59331 C...Colour Reconnections
59334 C...Lambda_FSR scale.
59338 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59346 WRITE(M11,5030) ' '
59347 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59348 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59349 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59350 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59351 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59352 WRITE(M11,5030) CH60
59353 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
59354 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
59355 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59356 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59357 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59358 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59359 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59360 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59361 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59362 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59363 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
59364 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
59365 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
59366 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
59367 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59368 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59369 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59372 C=============================================================================
59373 C...ATLAS-CSC 11-parameter tune (By A. Moraes)
59374 ELSEIF (ITUNE.EQ.306) THEN
59375 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
59376 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
59377 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59390 C...UE on, new model.
59395 C...Switch off trial joinings
59397 C...Primordial kT cutoff
59400 CH60='see presentations by A. Moraes (ATLAS),'
59401 WRITE(M11,5030) CH60
59402 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59403 WRITE(M11,5030) CH60
59404 WRITE(M11,5030) ' '
59405 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
59406 & 'externally linked and'
59407 WRITE(M11,5035) CH70
59408 CH70='MSTP(51) should be set manually according to '//
59409 & 'the library used'
59410 WRITE(M11,5035) CH70
59412 C...Smooth ISR, low FSR
59417 C...Transverse density profile.
59421 C...ISR & FSR in interactions after the first (default)
59424 C...No double-counting (default)
59426 C...Companion quark parent gluon (1-x) power
59428 C...Primordial kT compensation along chaings (default = 0 : uniform)
59430 C...Colour Reconnections
59433 C...Lambda_FSR scale.
59435 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59440 C...Peterson charm frag, and c and b hadr parameters
59446 WRITE(M11,5030) ' '
59447 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59448 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59449 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59450 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59451 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59452 WRITE(M11,5030) CH60
59453 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
59454 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
59455 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59456 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59457 CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
59458 WRITE(M11,5030) CH60
59459 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59460 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59461 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59462 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59463 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59464 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59465 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59466 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
59467 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
59468 WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
59469 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
59470 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
59471 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59472 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59473 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59474 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59475 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59476 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59479 C=============================================================================
59480 C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
59481 C...(100-105,108-109) and ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
59482 ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
59483 & ITUNE.EQ.109) THEN
59484 IF (M13.GE.1.AND.ITUNE.NE.106) THEN
59485 WRITE(M11,5010) ITUNE, CHNAME
59486 CH60='see R.D. Field (CDF), in hep-ph/0610012'
59487 WRITE(M11,5030) CH60
59488 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59489 WRITE(M11,5030) CH60
59491 C...Multiple interactions on, old framework
59493 C...Fast IR cutoff energy scaling by default
59496 C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
59499 IF (ITUNE.EQ.105) THEN
59502 ELSEIF(ITUNE.EQ.108.OR.ITUNE.EQ.109) THEN
59510 C...Double Gaussian matter distribution.
59516 C...Lambda_FSR scale.
59518 C...Fragmentation functions and c and b parameters
59524 IF(ITUNE.EQ.100.OR.ITUNE.EQ.101) THEN
59527 c...String drawing almost completely minimizes string length.
59530 C...ISR cutoff, muR scale factor, and phase space size
59534 C...Intrinsic kT, size, and max
59538 C...AW : higher ISR IR cutoff, but also larger alpha_s and more intrinsic kT.
59539 IF (ITUNE.EQ.101) THEN
59546 C...Tune BW (larger alpha_s, more intrinsic kT. Smaller ISR phase space.)
59547 ELSEIF (ITUNE.EQ.102) THEN
59550 c...String drawing completely minimizes string length.
59553 C...ISR cutoff, muR scale factor, and phase space size
59557 C...Intrinsic kT, size, and max
59563 ELSEIF (ITUNE.EQ.103) THEN
59566 c...String drawing completely minimizes string length.
59569 C...ISR cutoff, muR scale factor, and phase space size
59573 C...Intrinsic kT, size, and max
59579 ELSEIF (ITUNE.EQ.104) THEN
59582 C...Run II ref scale and slow scaling
59585 c...String drawing completely minimizes string length.
59588 C...ISR cutoff, muR scale factor, and phase space size
59592 C...Intrinsic kT, size, and max
59598 ELSEIF(ITUNE.EQ.105) THEN
59600 WRITE(M11,5030) ' '
59601 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
59602 & 'externally linked and'
59603 WRITE(M11,5035) CH70
59604 CH70='MSTP(51) should be set manually according to '//
59605 & 'the library used'
59606 WRITE(M11,5035) CH70
59610 c...String drawing completely minimizes string length.
59613 C...ISR cutoff, muR scale factor, and phase space size
59617 C...Intrinsic kT, size, and max
59622 C...Tune D6 and D6T
59623 ELSEIF(ITUNE.EQ.108.OR.ITUNE.EQ.109) THEN
59625 WRITE(M11,5030) ' '
59626 CH70='NB! This tune requires CTEQ6L pdfs to be '//
59627 & 'externally linked and'
59628 WRITE(M11,5035) CH70
59629 CH70='MSTP(51) should be set manually according to '//
59630 & 'the library used'
59631 WRITE(M11,5035) CH70
59633 C...The "Rick" proton, double gauss with 0.5/0.4
59637 c...String drawing completely minimizes string length.
59640 IF (ITUNE.EQ.108) THEN
59641 C...D6: pT0, Run I ref scale, and fast energy scaling
59646 C...D6T: pT0, Run II ref scale, and slow energy scaling
59651 C...ISR cutoff, muR scale factor, and phase space size
59655 C...Intrinsic kT, size, and max
59660 C...Old ATLAS-DC2 5-parameter tune
59661 ELSEIF(ITUNE.EQ.106) THEN
59663 WRITE(M11,5010) ITUNE, CHNAME
59664 CH60='see A. Moraes et al., SN-ATLAS-2006-057'
59665 WRITE(M11,5030) CH60
59666 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59667 WRITE(M11,5030) CH60
59671 C... Different ref and rescaling pacee
59674 C... Parameters of mass distribution
59677 C... Old default string drawing
59680 C... ISR, phase space equivalent to Tune B
59695 WRITE(M11,5030) ' '
59696 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59697 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59698 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59699 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59700 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59701 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59702 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59703 WRITE(M11,5030) CH60
59704 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59705 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59706 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59707 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59708 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59709 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59710 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59711 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59712 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59713 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
59714 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
59715 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
59716 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
59717 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59718 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59719 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59720 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59723 C=============================================================================
59724 C... ACR, tune A with new CR (107)
59725 ELSEIF(ITUNE.EQ.107) THEN
59727 WRITE(M11,5010) ITUNE, CHNAME
59728 CH60='Tune A modified with new colour reconnections'
59729 WRITE(M11,5030) CH60
59730 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
59731 WRITE(M11,5030) CH60
59732 CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
59733 WRITE(M11,5030) CH60
59734 CH60='R.D. Field (CDF), in hep-ph/0610012 (Tune A)'
59735 WRITE(M11,5030) CH60
59736 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59737 WRITE(M11,5030) CH60
59739 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
59740 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59741 & ' with tune. Using defaults.')
59765 C...Fragmentation functions and c and b parameters
59771 WRITE(M11,5030) ' '
59772 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59773 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59774 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59775 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59776 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59777 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59778 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59779 WRITE(M11,5030) CH60
59780 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59781 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59782 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59783 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59784 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59785 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59786 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59787 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59788 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59789 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
59790 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
59791 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
59792 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
59793 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59794 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59795 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59796 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59797 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59798 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59801 C=============================================================================
59802 C... Intermediate model. Rap tune (retuned to post-6.406 IR factorization)
59803 ELSEIF(ITUNE.EQ.200) THEN
59805 WRITE(M11,5010) ITUNE, CHNAME
59806 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
59807 WRITE(M11,5030) CH60
59809 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
59810 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59828 C... ExpOfPow(1.8) overlap profile
59835 C... Default diquark, BR-g-BR supp
59838 C... Final state reconnect.
59841 C...Fragmentation functions and c and b parameters
59847 WRITE(M11,5030) ' '
59848 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59849 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59850 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59851 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59852 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59853 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59854 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59855 WRITE(M11,5030) CH60
59856 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59857 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59858 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59859 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59860 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59861 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59862 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59863 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59864 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
59865 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
59866 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
59867 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
59868 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59869 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59870 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59871 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59872 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59873 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59876 C...APT. Tune A modified to use new pT-ordered FSR.
59877 ELSEIF(ITUNE.EQ.201) THEN
59879 WRITE(M11,5010) ITUNE, CHNAME
59880 CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
59881 WRITE(M11,5030) CH60
59882 CH60='R.D. Field (CDF), in hep-ph/0610012 (Tune A)'
59883 WRITE(M11,5030) CH60
59884 CH60='T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59885 WRITE(M11,5030) CH60
59886 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59887 WRITE(M11,5030) CH60
59889 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
59890 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59893 C...First set as if Pythia tune A
59894 C...Multiple interactions on, old framework
59896 C...Fast IR cutoff energy scaling by default
59899 C...Default CTEQ5L (internal)
59902 C...Double Gaussian matter distribution.
59908 c...String drawing almost completely minimizes string length.
59911 C...ISR cutoff, muR scale factor, and phase space size
59915 C...Intrinsic kT, size, and max
59919 C...Use pT-ordered FSR
59921 C...Lambda_FSR scale for pT-ordering
59925 C...Fragmentation functions and c and b parameters
59932 WRITE(M11,5030) ' '
59933 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59934 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59935 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59936 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59937 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59938 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59939 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59940 WRITE(M11,5030) CH60
59941 WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
59942 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59943 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59944 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59945 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59946 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59947 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59948 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59949 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59950 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59951 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
59952 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
59953 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
59954 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
59955 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59956 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59957 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59958 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59961 C=============================================================================
59962 C...Uppsala models: Generalized Area Law and Soft Colour Interactions
59963 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
59965 WRITE(M11,5010) ITUNE, CHNAME
59966 CH60='see J. Rathsman, PLB452(1999)364'
59967 WRITE(M11,5030) CH60
59968 C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
59969 C ? WRITE(M11,5030)
59970 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59971 WRITE(M11,5030) CH60
59972 WRITE(M11,5030) ' '
59973 CH70='NB! The GAL model must be run with modified '//
59975 WRITE(M11,5035) CH70
59976 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
59977 WRITE(M11,5035) CH70
59978 WRITE(M11,5030) ' '
59980 C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
59993 IF(CHNAME.EQ.'GAL Tune 1') THEN
59994 C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
60000 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
60001 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
60002 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
60003 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
60004 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
60008 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
60009 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
60010 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
60015 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
60016 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
60017 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
60018 CH40='FSI SCI/GAL selection'
60019 WRITE(M11,6040) 1, MSWI(1), CH40
60020 CH40='FSI SCI/GAL sea quark treatment'
60021 WRITE(M11,6040) 2, MSWI(2), CH40
60022 CH40='FSI SCI/GAL sea quark treatment parm'
60023 WRITE(M11,6050) 1, PARSCI(1), CH40
60024 CH40='FSI SCI/GAL string reco probability R_0'
60025 WRITE(M11,6050) 2, PARSCI(2), CH40
60026 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
60027 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
60029 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
60031 WRITE(M11,5010) ITUNE, CHNAME
60032 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
60033 WRITE(M11,5030) CH60
60034 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
60035 WRITE(M11,5030) CH60
60036 WRITE(M11,5030) ' '
60037 CH70='NB! The SCI model must be run with modified '//
60039 WRITE(M11,5035) CH70
60040 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
60041 WRITE(M11,5035) CH70
60042 WRITE(M11,5030) ' '
60044 C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
60054 IF (CHNAME.EQ.'SCI Tune 1') THEN
60055 C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
60063 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
60064 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
60065 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
60066 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
60067 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
60071 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
60072 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
60073 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
60078 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
60079 CH40='FSI SCI/GAL selection'
60080 WRITE(M11,6040) 1, MSWI(1), CH40
60081 CH40='FSI SCI/GAL sea quark treatment'
60082 WRITE(M11,6040) 2, MSWI(2), CH40
60083 CH40='FSI SCI/GAL sea quark treatment parm'
60084 WRITE(M11,6050) 1, PARSCI(1), CH40
60085 CH40='FSI SCI/GAL string reco probability R_0'
60086 WRITE(M11,6050) 2, PARSCI(2), CH40
60087 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
60091 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
60095 9998 IF (MSTU(13).GE.1) WRITE(M11,6000)
60099 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
60100 & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
60101 & 20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
60102 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
60103 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
60104 5030 FORMAT(' *',3x,10x,A60,3x,'*')
60105 5035 FORMAT(' *',3x,A70,3x,'*')
60106 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
60107 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
60108 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
60109 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
60110 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
60111 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
60112 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
60113 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
60114 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
60118 C*********************************************************************
60121 C...Administrates the fragmentation and decay chain.
60125 C...Double precision and integer declarations.
60126 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60127 IMPLICIT INTEGER(I-N)
60128 INTEGER PYK,PYCHGE,PYCOMP
60130 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60131 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60132 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60133 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60134 COMMON/PYINT1/MINT(400),VINT(400)
60135 COMMON/PYINT4/MWID(500),WIDS(500,5)
60136 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
60138 DIMENSION PS(2,6),IJOIN(100)
60140 C...Initialize and reset.
60142 IF(MSTU(12).NE.12345) CALL PYLIST(0)
60144 MSTU(31)=MSTU(31)+1
60148 IF(MSTU(17).LE.0) MSTU(90)=0
60151 C...Sum up momentum, energy and charge for starting entries.
60159 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
60161 PS(1,J)=PS(1,J)+P(I,J)
60163 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
60167 C...Start by all decays of coloured resonances involved in shower.
60170 IF(K(I,1).EQ.3) THEN
60172 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
60176 C...Prepare system for subsequent fragmentation/decay.
60178 IF(MINT(51).NE.0) RETURN
60180 C...Loop through jet fragmentation and particle decays.
60186 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
60189 C...Deal with any remaining undecayed resonance
60190 C...(normally the task of PYEVNT, so seldom used).
60191 ELSEIF(MWID(KC).NE.0) THEN
60193 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
60196 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
60197 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
60200 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
60201 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
60204 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
60212 IF(MINT(51).NE.0) RETURN
60214 C...Particle decay if unstable and allowed. Save long-lived particle
60215 C...decays until second pass after Bose-Einstein effects.
60216 ELSEIF(KCHG(KC,2).EQ.0) THEN
60217 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
60218 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
60221 C...Decay products may develop a shower.
60222 IF(MSTJ(92).GT.0) THEN
60224 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
60225 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
60227 if(parj(200).ne.1.) CALL PYSHOW(IP1,IP1+1,QMAX)
60228 if(parj(200).eq.1.) CALL PYSHOWQ(IP1,IP1+1,QMAX)
60230 IF(MINT(51).NE.0) RETURN
60232 ELSEIF(MSTJ(92).LT.0) THEN
60235 if(parj(200).ne.1.) CALL PYSHOW(IP1,-3,P(IP,5))
60236 if(parj(200).eq.1.) CALL PYSHOWQ(IP1,-3,P(IP,5))
60238 IF(MINT(51).NE.0) RETURN
60242 C...Jet fragmentation: string or independent fragmentation.
60243 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
60245 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
60246 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
60247 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
60248 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
60249 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
60252 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
60253 IF(MFRAG.EQ.2) CALL PYINDF(IP)
60254 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
60255 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
60258 C...Loop back if enough space left in PYJETS and no error abort.
60259 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
60260 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
60262 ELSEIF(IP.LT.N) THEN
60263 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
60266 C...Include simple Bose-Einstein effect parametrization if desired.
60267 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
60272 C...Check that momentum, energy and charge were conserved.
60274 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
60276 PS(2,J)=PS(2,J)+P(I,J)
60278 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
60280 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
60281 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
60282 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
60283 &'(PYEXEC:) four-momentum was not conserved')
60284 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
60285 &'(PYEXEC:) charge was not conserved')
60290 C*********************************************************************
60293 C...Rearranges partons along strings.
60294 C...Special considerations for systems with junctions, with
60295 C...possibility of junction-antijunction annihilation.
60296 C...Allows small systems to collapse into one or two particles.
60297 C...Checks flavours and colour singlet invariant masses.
60299 SUBROUTINE PYPREP(IP)
60301 C...Double precision and integer declarations.
60302 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60303 INTEGER PYK,PYCHGE,PYCOMP
60305 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60306 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60307 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60308 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60309 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60310 COMMON/PYINT1/MINT(400),VINT(400)
60311 C...The common block of colour tags.
60312 COMMON/PYCTAG/NCT,MCT(4000,2)
60313 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
60318 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
60319 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
60320 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
60321 &IJCP(0:6),TJUOLD(5)
60324 C...Function to give four-product.
60325 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)
60327 C...Rearrange parton shower product listing along strings: begin loop.
60335 DO 100 I=MAX(1,IP),N
60336 C...First store junction positions.
60337 IF(K(I,1).EQ.42) THEN
60345 DO 240 I=MAX(1,IP),N
60346 C...Special treatment for junctions
60347 IF (K(I,1).LE.0) GOTO 240
60348 IF(K(I,1).EQ.42) THEN
60349 C...MQGST=2: Look for junction-junction strings (not detected in the
60350 C...main search below).
60351 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
60352 IF (NJJSTR.EQ.0) THEN
60353 NJJSTR = (3*NJUNC-NPIECE)/2
60355 C...Check how many already identified strings end on this junction
60358 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
60360 C...If less than 3, remaining must be to another junction
60363 C...Multiple j-j connections not handled yet.
60365 & '(PYPREP:) Too many junction-junction strings.')
60369 C...The colour information in the junction is unreadable for the
60370 C...colour space search further down in this routine, so we must
60371 C...start on the colour mother of this junction and then "artificially"
60372 C...prevent the colour mother from connecting here again.
60373 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
60375 IF (MOD(ITJUNC,2).EQ.0) KCS=5
60376 C...Switch colour if the junction-junction leg is presumably a
60377 C...junction mother leg rather than a junction daughter leg.
60378 IF (ITJUNC.GE.3) KCS=9-KCS
60379 IF (MINT(33).EQ.0) THEN
60380 C...Find the unconnected leg and reorder junction daughter pointers so
60381 C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
60383 IA=MOD(K(I,4),MSTU(5))
60384 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
60385 ITMP=MOD(K(I,5),MSTU(5))
60386 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
60387 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
60388 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
60390 K(I,5)=K(I,5)+(IA-ITMP)
60392 K(I,4)=K(I,4)+(ITMP-IA)
60395 IF (ITJUNC.LE.2) THEN
60396 C...Beam baryon junction
60397 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
60398 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
60399 C...Else 1 -> 2 decay junction
60401 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
60402 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
60407 C...Alternatively use colour tag information.
60409 C...Find a final state parton with appropriate dangling colour tag.
60413 DO 140 J1=MAX(1,IP),N
60414 IF (K(J1,1).NE.3) GOTO 140
60415 C...Check for matching final-state colour tag
60417 DO 120 J2=MAX(1,IP),N
60418 IF (K(J2,1).NE.3) GOTO 120
60419 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
60421 IF (IMATCH.EQ.1) GOTO 140
60422 C...Check whether this colour tag belongs to the present junction
60423 C...by seeing whether any parton with this colour tag has the same
60424 C...mother as the junction.
60427 DO 130 J2=MINT(84)+1,N
60429 C...First scattering partons have IMO1 = 3 and 4.
60430 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
60432 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
60435 IF (IMATCH.EQ.0) GOTO 140
60438 C...Check for junction-junction strings without intermediate final state
60439 C...glue (not detected above).
60443 IF (IJU2.EQ.I) GOTO 160
60444 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
60445 C...Only opposite types of junctions can connect to each other.
60446 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
60449 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
60451 IF (IS.EQ.3) GOTO 160
60456 C...Switch to other side of adjacent parton and step from there.
60462 ELSE IF (ILC.NE.3) THEN
60467 C...Look for coloured string endpoint, or (later) leftover gluon.
60468 IF(K(I,1).NE.3) GOTO 240
60470 IF(KC.EQ.0) GOTO 240
60472 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
60474 C...Pick up loose string end.
60476 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
60482 IF(NSTP.GT.4*N) THEN
60483 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
60488 C...Copy undecayed parton. Finished if reached string endpoint.
60489 IF(K(IA,1).EQ.3) THEN
60490 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
60491 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
60498 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
60508 IF(K(I1,1).EQ.1) GOTO 240
60511 C...Also finished (for now) if reached junction; then copy to end.
60512 IF(K(IA,1).EQ.42) THEN
60514 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
60515 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
60520 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
60521 DO 200 ICOPY=1,NCOPY
60523 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
60524 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
60525 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
60529 C...For junction-junction strings, find end leg and reorder junction
60530 C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
60531 C...junction-junction string piece.
60532 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
60533 ITMP=MOD(K(IA,4),MSTU(5))
60534 IF (ITMP.NE.IB) THEN
60535 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
60536 K(IA,5)=K(IA,5)+(ITMP-IB)
60538 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
60540 K(IA,4)=K(IA,4)+(IB-ITMP)
60545 C...0: endpoint in original ER
60548 C...3: Parton immediately next to junction
60551 IPIECE(NPIECE,1)=MSTU32+1
60552 IPIECE(NPIECE,2)=MSTU32+NCOPY
60553 IPIECE(NPIECE,3)=IB
60554 IPIECE(NPIECE,4)=IA
60555 MSTU32=MSTU32+NCOPY
60560 C...GOTO next parton in colour space.
60562 IF (MINT(33).EQ.0) THEN
60563 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
60565 IA=MOD(K(IB,KCS),MSTU(5))
60566 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
60569 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
60570 & MSTU(5)).EQ.0) KCS=9-KCS
60571 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
60572 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
60575 IF(IA.LE.0.OR.IA.GT.N) THEN
60576 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
60577 IF(NERRPR.LT.5) THEN
60579 WRITE(MSTU(11),*) 'started at:', I
60580 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
60581 WRITE(MSTU(11),*) 'MQGST =',MQGST
60587 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
60588 & ,MSTU(5)).EQ.IB) THEN
60589 IF(MREV.EQ.1) KCS=9-KCS
60590 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
60591 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
60593 IF(MREV.EQ.0) KCS=9-KCS
60594 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
60595 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
60597 IF(IA.NE.I) GOTO 170
60598 C...Use colour tag information
60600 C...First create colour tags starting on IB if none already present.
60601 IF (MCT(IB,KCS-3).EQ.0) THEN
60602 CALL PYCTTR(IB,KCS,IB)
60603 IF(MINT(51).NE.0) RETURN
60607 C...Find final state tag partner
60608 DO 210 IT=MAX(1,IP),N
60609 IF (IT.EQ.IB) GOTO 210
60610 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
60616 C...Just copy and goto next if exactly one partner found.
60617 IF (IFOUND.EQ.1) THEN
60619 C...When no match found, match is presumably junction.
60620 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
60621 C...Check whether this colour tag matches a junction
60622 C...by seeing whether any parton with this colour tag has the same
60623 C...mother as a junction.
60624 C...NB: Only type 1 and 2 junctions handled presently.
60626 IJUMO=K(IJUNC(IJU,0),3)
60627 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
60628 C...Colours only connect to junctions, anti-colours to antijunctions:
60629 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
60631 DO 220 J1=MAX(1,IP),N
60632 IF (K(J1,1).LE.0) GOTO 220
60633 C...First scattering partons have IMO1 = 3 and 4.
60635 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
60637 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
60638 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
60640 C...Attempt at handling type > 3 junctions also. Not tested.
60641 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
60644 IF (IMATCH.EQ.0) GOTO 230
60649 IF (IFOUND.EQ.1) THEN
60651 ELSEIF (IFOUND.EQ.0) THEN
60653 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
60655 IF(NERRPR.LT.5) THEN
60662 ELSEIF (IFOUND.GE.2) THEN
60665 & ,'(PYPREP:) too many occurences of colour line: '//
60667 IF(NERRPR.LT.5) THEN
60679 C...Junction systems remain.
60685 260 IJUCNT=IJUCNT+1
60686 IF (IJUCNT.LE.NJUNC) THEN
60687 C...If we are not processing a j-j string, treat this junction as new.
60688 IF (IJJSTR.EQ.0) THEN
60689 IJU=IJUNC(IJUCNT,0)
60691 C...If junction has already been read, ignore it.
60692 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
60693 C...If we are on a j-j string, goto second j-j junction.
60698 C...Mark selected junction read.
60700 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
60702 C...Determine junction type
60703 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
60704 C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
60705 C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
60706 C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
60707 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
60710 C...Find which quarks belong to given junction.
60712 DO 290 IPC=1,NPIECE
60713 IF (IPIECE(IPC,4).EQ.IJU) THEN
60715 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
60717 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
60719 C...IHK = 3 is special. Either normal string piece, or j-j string.
60721 IF (MREV.NE.1) THEN
60722 DO 300 IPC=1,NPIECE
60723 C...If there is a j-j string starting on the present junction which has
60724 C...zero length, insert next junction immediately.
60725 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
60726 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
60732 C...If MREV is 1 and IHK is 3 we are finished with this system.
60739 C...If we've gotten this far, then either IHK < 3, or
60740 C...an interjunction string exists, or just a third normal string.
60741 IJUNC(IJUCNT,IHK)=0
60743 C..Order pieces belonging to this junction. Also look for j-j.
60744 DO 310 IPC=1,NPIECE
60745 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
60746 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
60747 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
60748 IJUNC(IJUCNT,IHK)=IPC
60753 C...Copy back chains in proper order. MREV=0/1 : descending/ascending
60754 IPC=IJUNC(IJUCNT,IHK)
60755 C...Temporary solution to cover for bug.
60757 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
60761 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
60764 K(I1,J)=K(MSTU(4)-ICP,J)
60765 P(I1,J)=P(MSTU(4)-ICP,J)
60766 V(I1,J)=V(MSTU(4)-ICP,J)
60770 C...Mark last quark.
60771 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
60772 C...Do not insert junctions at wrong places.
60773 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
60774 C...Insert junction.
60777 C...Shift to end junction if a j-j string has been processed.
60778 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
60788 K(IJUS,1)=K(IJUS,1)+10
60791 360 IF (IHK.LT.3) GOTO 280
60793 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
60797 IF (IJUCNT.NE.NJUNC) GOTO 260
60801 C...Rearrange three strings from junction, e.g. in case one has been
60802 C...shortened by shower, so the last is the largest-energy one.
60803 IF(NJUNC.GE.1) THEN
60804 C...Find systems with exactly one junction.
60808 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
60809 ELSEIF(K(I,1).EQ.41) THEN
60811 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
60816 C...Sum up energy-momentum in each junction string.
60823 DO 390 I1=NBEG,NEND
60824 IF(K(I1,2).NE.21) THEN
60829 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
60832 C...Find which of them has highest energy (minus mass) in rest frame.
60834 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
60836 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
60839 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
60840 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
60842 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
60843 C...Decide how to rearrange so that new last has highest energy.
60844 IF(PJU(1,6).LT.PJU(2,6)) THEN
60846 IRNG(1,2)=IJUR(2)-1
60848 IRNG(2,2)=IJUR(3)+1
60849 IRNG(4,1)=IJUR(3)-1
60853 IRNG(1,2)=IJUR(3)+1
60855 IRNG(2,2)=IJUR(3)-1
60856 IRNG(4,1)=IJUR(2)-1
60861 C...Copy in correct order below bottom of current event record.
60864 DO 430 I1=IRNG(II,1),IRNG(II,2),
60865 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
60867 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
60869 & '(PYPREP:) no more memory left in PYJETS')
60879 IF(K(I2,1).EQ.1) K(I2,1)=2
60883 C...Copy back up, overwriting but now in correct order.
60884 DO 460 I1=NBEG,NEND
60898 C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
60899 C...to two q-qbar systems.
60900 C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
60901 IF (MSTJ(19).NE.1) THEN
60905 C...Force collapse when MSTJ(19)=2.
60906 IF (MSTJ(19).EQ.2) THEN
60910 C...Find systems with exactly two junctions.
60912 C...Count junctions
60913 IF (K(I,1).EQ.41) THEN
60915 C...Check for interjunction gluons
60916 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
60919 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
60920 C...If end of system reached with either zero or one junction, restart
60921 C...with next system.
60925 ELSEIF(K(I,1).EQ.1) THEN
60926 C...If end of system reached with exactly two junctions, compute string
60927 C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
60928 C...length measure for the (q-qbar)(q-qbar) topology.
60930 C...Loop down through chain.
60932 DO 480 I1=NBEG,NEND
60933 C...Store string piece division locations in event record
60934 IF (K(I1,2).NE.21) THEN
60939 C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
60941 IF (PYR(0).LT.0.5D0) ISW=1
60942 C...Randomly choose which qqbar string gets the jj gluons.
60944 IF (PYR(0).GT.0.5D0) IGS=2
60945 C...Only compute string lengths when no topology forced.
60946 IF (MSTJ(19).EQ.0) THEN
60947 C...Repeat following for each junction
60949 C...Initialize iterative procedure for finding JRF
60955 C...Start iteration. Sum up momenta in string pieces
60957 C...JD=-1 for first junction, +1 for second junction.
60958 C...Find out where piece starts and ends and which direction to go.
60961 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
60962 IB = IJCP((IJU-1)*7 - JD*IJS)
60963 ELSEIF (IJS.EQ.3) THEN
60965 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
60966 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
60968 C...Initialize junction pull 4-vector.
60972 C...Initialize weight
60975 C...Sum up (weighted) momenta along each string piece
60976 DO 530 ISP=IA,IB,JD
60977 C...If present parton not last in chain
60978 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
60979 C...If last parton was a junction, store present weight
60980 IF (K(ISP-JD,2).EQ.88) THEN
60982 C...If last parton was a quark, reset to stored weight.
60983 ELSEIF (K(ISP-JD,2).NE.21) THEN
60987 C...Skip next parton if weight already large
60988 IF (PWT.GT.10D0) GOTO 530
60989 C...Compute momentum in TJUOLD frame:
60990 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
60992 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
60994 TMP=P(ISP,J)+TJUOLD(J)*BFC
60995 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
60998 TMP=TJUOLD(4)*P(ISP,4)+TDP
60999 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
61001 PWT=PWT+TMP/PARJ(48)
61002 C...Put |p| rather than m in 5th slot
61003 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
61010 C...Combine new boost (T) with old boost (TJUOLD)
61011 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
61013 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
61016 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
61018 C...If last boost small, accept JRF, else iterate.
61019 C...Also prevent possibility of infinite loop.
61020 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
61021 & IJRFIT.LT.MSTJ(18))THEN
61023 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
61024 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
61026 C...Store final boost, with change of sign since TJJ motion vector.
61028 TJJ(IJU,IX)=-TJUOLD(IX)
61030 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
61033 C...String length measure for (q-qbar)(q-qbar) topology.
61034 C...Note only momenta of nearest partons used (since rest of system
61036 IF (JJGLUE.EQ.0) THEN
61037 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
61038 & -1,IJCP(5-ISW)+1)
61040 C...Put jj gluons on selected string (IGS selected randomly above).
61042 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
61043 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
61045 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
61046 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
61050 C...String length measure for q-q-j-j-q-q topology.
61059 C...Note only momenta of nearest partons used (since rest of system
61062 IF (IX.EQ.4) ISGN=1
61063 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
61064 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
61065 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
61066 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
61067 IF (JJGLUE.EQ.0) THEN
61068 C...Junction motion vector dot product gives length when inter-junction
61070 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
61072 C...Junction motion vector dot products with gluon momenta give length
61073 C...when inter-junction gluons present.
61074 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
61075 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
61078 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
61079 IF (JJGLUE.EQ.0) THEN
61080 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
61082 DELMJJ=DELMJJ*4D0*T1G1*T2G2
61085 C...If delmjj > delmqq collapse string system to q-qbar q-qbar
61086 C...(Always the case for MSTJ(19)=2 due to initialization above)
61087 IF (DELMJJ.GT.DELMQQ) THEN
61088 C...Put new system at end of event record
61091 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
61094 P(NCOP,IX)=P(ICOP,IX)
61095 K(NCOP,IX)=K(ICOP,IX)
61098 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
61099 C...Insert inter-junction gluon string piece (reversed)
61101 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
61105 P(NCOP,IX)=P(ICOP,IX)
61106 K(NCOP,IX)=K(ICOP,IX)
61111 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
61114 P(NCOP,IX)=P(ICOP,IX)
61115 K(NCOP,IX)=K(ICOP,IX)
61120 C...Copy system back in right order
61121 DO 670 ICOP=NBEG,NEND-2
61123 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
61124 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
61127 C...Shift down rest of event record
61128 DO 690 ICOP=NEND+1,N
61130 P(ICOP-2,IX)=P(ICOP,IX)
61131 K(ICOP-2,IX)=K(ICOP,IX)
61134 C...Update length of event record.
61144 C...Done if no checks on small-mass systems.
61145 IF(MSTJ(14).LT.0) RETURN
61146 IF(MSTJ(14).EQ.0) GOTO 1140
61148 C...Find lowest-mass colour singlet jet system.
61153 DO 770 I=MAX(1,IP),N
61154 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
61155 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
61162 DPS(5)=PYMASS(K(I,2))
61163 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
61165 DPS(J)=DPS(J)+P(I,J)
61168 DPS(5)=DPS(5)+PYMASS(K(I,2))
61169 ELSEIF(K(I,1).EQ.2) THEN
61171 DPS(J)=DPS(J)+P(I,J)
61173 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
61175 DPS(J)=DPS(J)+P(I,J)
61178 DPS(5)=DPS(5)+PYMASS(K(I,2))
61179 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
61181 IF(PD.LT.PDMIN) THEN
61195 C...Done if lowest-mass system above threshold for string frag.
61196 IF(PDMIN.GE.PARJ(32)) GOTO 1140
61198 C...Fill small-mass system as cluster.
61200 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
61210 C...Set up history, assuming cluster -> 2 hadrons.
61216 IF(MSTU(16).NE.2) THEN
61231 C...Find total flavour content - complicated by presence of junctions.
61235 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
61238 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
61242 C...If several diquarks, split up one to give even number of flavours.
61243 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
61245 IF(IABS(KFQ(3)).LT.1000) I1=1
61246 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
61247 KFQ(I1)=KFQ(I1)/1000
61252 C...If four quark ends, join two to diquark.
61253 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
61256 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
61257 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
61258 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
61259 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
61260 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
61261 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
61267 C...If two quark ends, plus quark or diquark, join quarks to diquark.
61271 IF(IABS(KFQ(I1)).GT.1000) I1=3
61272 IF(IABS(KFQ(I2)).GT.1000) I2=3
61273 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
61274 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
61275 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
61276 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
61282 C...Form two particles from flavours of lowest-mass system, if feasible.
61284 790 NTRY = NTRY + 1
61286 C...Open string with two specified endpoint flavours.
61290 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
61291 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
61292 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
61293 IF(KQ1+KQ2.NE.0) GOTO 1140
61294 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
61296 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
61298 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
61299 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
61300 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
61302 C...Open string with four specified flavours.
61303 ELSEIF(NQ.EQ.4) THEN
61308 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
61309 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
61310 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
61311 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
61312 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
61313 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
61314 C...Combine flavours pairwise to form two hadrons.
61317 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
61318 & IABS(KFQ(2)).GT.1000)) I2=3
61319 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
61320 & IABS(KFQ(3)).GT.1000))) I2=4
61324 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
61325 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
61326 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
61330 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
61331 C...No room for popcorn mesons in closed string -> 2 hadrons.
61333 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
61334 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
61335 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
61336 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
61338 P(N+2,5)=PYMASS(K(N+2,2))
61339 P(N+3,5)=PYMASS(K(N+3,2))
61341 C...If it does not work: try again (a number of times), give up (if no
61342 C...place to shuffle momentum or too many flavours), or form one hadron.
61343 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
61344 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
61346 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
61353 C...Perform two-particle decay of jet system.
61354 C...First step: find reference axis in decaying system rest frame.
61355 C...(Borrow slot N+2 for temporary direction.)
61359 DO 850 I=IC1+1,IC2-1
61360 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
61361 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
61362 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
61364 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
61368 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
61370 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
61371 PHI1=PYANGL(P(N+2,1),P(N+2,2))
61373 C...Second step: generate isotropic/anisotropic decay.
61374 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
61375 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
61377 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
61378 PT2=(1D0-UE(3)**2)*PA**2
61379 IF(MSTJ(16).LE.0) THEN
61382 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
61383 PR1=P(N+2,5)**2+PT2
61384 PR2=P(N+3,5)**2+PT2
61385 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
61387 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
61388 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
61390 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
61392 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
61393 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
61398 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
61399 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
61401 C...Third step: move back to event frame and set production vertex.
61402 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
61412 C...Else form one particle, if possible.
61420 C...Select hadron flavour from available quark flavours.
61421 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
61423 ELSEIF(NQ.EQ.2) THEN
61424 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
61426 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
61427 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
61429 IF(K(N+2,2).EQ.0) GOTO 910
61430 P(N+2,5)=PYMASS(K(N+2,2))
61432 C...Use old algorithm for E/p conservation? (EN)
61433 IF (MSTJ(16).LE.0) GOTO 1080
61435 C...Find the string piece closest to the cluster by a loop
61436 C...over the undecayed partons not in present cluster. (EN)
61441 DO 940 I1=MAX(1,IP),N-1
61442 IF(K(I1,1).EQ.1) NJUNC=0
61443 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
61444 IF(K(I1,1).EQ.41) GOTO 940
61445 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
61447 ELSEIF(K(I1,1).EQ.2) THEN
61451 IF(K(I2,1).EQ.41) GOTO 940
61452 IF(K(I2,1).GT.10) GOTO 920
61453 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
61454 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
61455 & NJUNC.EQ.0) GOTO 940
61456 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
61457 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
61458 & K(I2,1).NE.1)) GOTO 940
61460 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
61462 E1(J)=P(I1,J)/P(I1,4)
61463 E2(J)=P(I2,J)/P(I2,4)
61464 ECL(J)=P(N+1,J)/P(N+1,4)
61469 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
61470 E3S=E3(1)**2+E3(2)**2+E3(3)**2
61471 E4S=E4(1)**2+E4(2)**2+E4(3)**2
61472 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
61473 IF(E34.LE.0D0) THEN
61475 ELSEIF(E34.LT.E3S) THEN
61476 DDMIN=E4S-E34**2/E3S
61478 DDMIN=E4S-2D0*E34+E3S
61481 C...Is this the smallest so far?
61482 IF(DDMIN.LT.DGLOMI) THEN
61487 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
61492 C... Check if there are any strings to connect to the new gluon. (EN)
61493 IF (IBEG.EQ.0) GOTO 1080
61495 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
61496 IF (P(N+1,5).GE.P(N+2,5)) THEN
61498 C...Construct 'gluon' that is needed to put hadron on the mass shell.
61499 FRAC=P(N+2,5)/P(N+1,5)
61501 P(N+2,J)=FRAC*P(N+1,J)
61502 PG(J)=(1D0-FRAC)*P(N+1,J)
61505 C... Copy string with new gluon put in.
61509 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
61510 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
61531 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
61534 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
61535 C...from string piece endpoints.
61538 C...Begin by copying string that should give energy to cluster.
61542 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
61543 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
61555 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
61558 C...Set initial Phad.
61560 P(NSAV+2,J)=P(NSAV+1,J)
61563 C...Calculate Pg, a part of which will be added to Phad later. (EN)
61564 1020 IF(MSTJ(16).EQ.1) THEN
61568 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
61569 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
61572 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
61574 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
61576 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
61577 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
61579 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
61580 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
61581 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
61583 C...If all gluon energy eaten, zero it and take a step back.
61585 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
61588 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
61594 IF(K(I1,1).EQ.41) ITER=-1
61596 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
61599 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
61605 IF(K(I2,1).EQ.41) ITER=-1
61607 IF(ITER.EQ.1) GOTO 1020
61609 C...If also all endpoint energy eaten, revert to old procedure.
61610 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
61611 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
61622 C... Construct the collapsed hadron and modified string partons.
61624 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
61625 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
61626 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
61628 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
61629 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
61631 C...Finished with string collapse in new scheme.
61635 C... Use old algorithm; by choice or when in trouble.
61637 C...Find parton/particle which combines to largest extra mass.
61642 IF(IR.NE.0) GOTO 1100
61643 DO 1090 I=MAX(1,IP),N
61644 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
61645 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
61646 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
61647 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
61648 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
61649 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
61651 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
61652 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
61653 IF(HSR.GT.HSM) THEN
61661 C...Shuffle energy and momentum to put new particle on mass shell.
61666 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
61667 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
61668 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
61670 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
61671 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
61675 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
61679 C...Mark collapsed system and store daughter pointers. Iterate.
61680 1120 DO 1130 I=IC1,IC2
61681 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
61682 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
61684 IF(MSTU(16).NE.2) THEN
61689 K(I,5)=NSAV+1+NBODY
61692 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
61694 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
61696 C...Check flavours and invariant masses in parton systems.
61704 DO 1180 I=MAX(1,IP),N
61705 IF(K(I,1).EQ.41) NJU=NJU+1
61706 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
61708 IF(KC.EQ.0) GOTO 1180
61709 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
61710 IF(KQ.EQ.0) GOTO 1180
61716 DPS(5)=DPS(5)+PYMASS(K(I,2))
61719 DPS(J)=DPS(J)+P(I,J)
61721 IF(K(I,1).EQ.1) THEN
61723 IF(NJU.EQ.0.AND.NP.NE.1) THEN
61724 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
61725 ELSEIF(NJU.EQ.1) THEN
61726 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
61727 ELSEIF(NJU.EQ.2) THEN
61728 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
61729 ELSEIF(NJU.GE.3) THEN
61732 IF(NFERR.EQ.1) THEN
61733 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
61737 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
61738 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
61739 & '(PYPREP:) too small mass in jet system')
61753 C*********************************************************************
61756 C...Handles the fragmentation of an arbitrary colour singlet
61757 C...jet system according to the Lund string fragmentation model.
61759 SUBROUTINE PYSTRF(IP)
61761 C...Double precision and integer declarations.
61762 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61763 IMPLICIT INTEGER(I-N)
61764 INTEGER PYK,PYCHGE,PYCOMP
61766 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
61767 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61768 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
61769 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
61770 C...Local arrays. All MOPS variables ends with MO
61771 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
61772 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
61773 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
61774 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
61775 &PBST(3,5),TJUOLD(5)
61777 C...Function: four-product of two vectors.
61778 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)
61779 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
61782 C...Reset counters.
61797 C...Identify parton system.
61800 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
61801 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
61802 IF(MSTU(21).GE.1) RETURN
61804 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
61806 IF(KC.EQ.0) GOTO 110
61807 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
61808 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
61809 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
61810 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
61811 IF(MSTU(21).GE.1) RETURN
61814 C...Take copy of partons to be considered. Check flavour sum.
61819 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
61821 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
61823 IF(KQ.NE.2) KQSUM=KQSUM+KQ
61824 IF(K(I,1).EQ.41) THEN
61825 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
61833 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
61834 IF(MOD(KQSUM,3).NE.0) THEN
61835 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
61836 IF(MSTU(21).GE.1) RETURN
61838 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
61840 C...Boost copied system to CM frame (for better numerical precision).
61841 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
61844 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
61848 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
61850 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
61851 IF(P(I,3).GT.0D0) THEN
61852 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
61853 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
61854 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
61856 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
61857 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
61858 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
61863 C...Search for very nearby partons that may be recombined.
61872 IF(MJU(1).GT.0) NRMIN=NRMIN+2
61873 IF(MJU(2).GT.0) NRMIN=NRMIN+2
61874 140 IF(NR.GT.NRMIN) THEN
61877 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
61879 IF(I.EQ.N+NR) I1=N+1
61880 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
61881 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
61883 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
61885 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
61886 & P(I1,2)**2+P(I1,3)**2))
61887 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
61888 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
61889 IF(PDR.LT.PDRMIN) THEN
61895 C...Recombine very nearby partons to avoid machine precision problems.
61896 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
61898 P(N+1,J)=P(N+1,J)+P(N+NR,J)
61900 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
61904 ELSEIF(PDRMIN.LT.PARU12) THEN
61906 P(IR,J)=P(IR,J)+P(IR+1,J)
61908 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
61910 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
61911 DO 190 I=IR+1,N+NR-1
61918 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
61920 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
61921 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
61927 C...Reset particle counter. Skip ahead if no junctions are present;
61928 C...this is usually the case!
61929 NRS=MAX(5*NR+11,NP)
61932 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
61936 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
61937 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
61938 IF(MSTU(21).GE.1) RETURN
61942 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
61943 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
61944 & ' junction strings not handled by MSTJ(12)>3 options')
61947 IF(MJU(JT).EQ.0) GOTO 640
61951 C...Find and sum up momentum on three sides of junction.
61952 C...Begin with previous boost = zero.
61959 C...Beginning and end of string system in event record.
61960 I1BEG=N+1+(JT-1)*(NR-1)
61961 I1END=N+NR+(JT-1)*(1-NR)
61962 C...Look for junction string piece end points
61963 DO 230 I1=I1BEG,I1END,JS
61964 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
61965 C...Store junction string piece end points.
61966 C 1-junction systems 2-junction systems
61967 C IU : 1 2 3 4 1 2 3 4 5 6
61968 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
61972 C...Sum over momenta, from junction outwards.
61976 C...Initialize junction drag and string piece 4-vectors.
61981 C...First two branches. Inwards out means opposite direction to JS.
61982 C...(JS is 1 for JT=1, -1 for JT=2)
61987 C...Last branch (gq or gjgqgq). Direction now reversed.
61993 DO 270 I1=I1A,I1B,IDIR
61994 C...Sum up momentum directions with exponential suppression
61995 C...for use in finding junction rest frame below.
61996 IF (K(I1,2).EQ.88) THEN
61997 C...gjgqgq type system encountered. Use current PWT as start
61998 C...for both strings.
62001 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
62002 C...Sum up string piece (boosted) 4-momenta.
62004 PJU(IU,J)=PJU(IU,J)+P(I1,J)
62006 C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
62007 C...boost is zero, see above). Skip parton if suppression factor large.
62008 IF (PWT.GT.10D0) GOTO 270
62009 C...Compute momentum in current frame:
62010 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
62011 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
62013 PTMP=P(I1,J)+TJUOLD(J)*BFC
62014 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
62017 PTMP=TJUOLD(4)*P(I1,4)+TDP
62018 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
62019 PWT=PWT+PTMP/PARJ(48)
62022 C...Put |p| rather than m in 5th slot.
62023 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
62024 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
62027 C...Calculate boost from present frame to next JRF candidate.
62029 CALL PYJURF(PBST,TJU)
62031 C...After some iterations do not take full step in new direction.
62032 IF(IJRFIT.GT.5) THEN
62033 REDUCE=0.8D0**(IJRFIT-5)
62034 TJU(1)=REDUCE*TJU(1)
62035 TJU(2)=REDUCE*TJU(2)
62036 TJU(3)=REDUCE*TJU(3)
62037 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
62040 C...Combine new boost (TJU) with old boost (TJUOLD)
62041 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
62043 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
62045 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
62047 C...If last boost small, accept JRF, else iterate.
62048 C...Also prevent possibility of infinite loop.
62049 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
62050 & IJRFIT.LT.MSTJ(18)) THEN
62052 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
62053 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
62056 C...Now store total boost in TJU and change perception.
62057 C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
62058 C...TJU = junction motion vector in string CM, so the sign changes.
62062 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
62066 C...Calculate string piece energies in junction rest frame.
62068 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
62070 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
62071 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
62074 C...Start preparing for fragmentation of two strings from junction.
62077 320 NTRYER=NTRYER+1
62080 NS=IABS(IJU(IU+1)-IJU(IU))
62082 C...Junction strings: find longitudinal string directions.
62084 IS1=IJU(IU)+JS*(IS-1)
62087 DP(1,J)=0.5D0*P(IS1,J)
62088 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
62089 DP(2,J)=0.5D0*P(IS2,J)
62090 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
62091 & (PJU(IU,5)/PBST(IU,5))
62093 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
62094 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
62098 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
62099 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62100 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62105 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
62106 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
62107 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
62109 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
62111 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
62112 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
62116 C...Junction strings: initialize flavour, momentum and starting pos.
62120 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
62124 ELSEIF(NTRY.GT.100) THEN
62125 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
62126 IF(MSTU(21).GE.1) RETURN
62131 IE(1)=K(N+1+(JT/2)*(NP-1),3)
62132 IF (MOD(JT+IU,2).NE.0) THEN
62134 IF (NP-NR.NE.0) THEN
62135 C...If gluons have disappeared. Original IJU must be used.
62139 IF (K(IT,2).NE.21) THEN
62142 IF (NE.EQ.IU+4*(JT-1)) THEN
62144 ELSEIF (IT.LE.IP+NP) THEN
62147 CALL PYERRM(14,'(PYSTRF:) '//
62148 & 'Original IJU could not be reconstructed!')
62156 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
62162 KFL(1)=K(IJU(IU),2)
62170 C...Junction strings: find initial transverse directions.
62173 DP(2,J)=P(IN(4)+1,J)
62177 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62178 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62179 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62180 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62181 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62182 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62183 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62184 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62185 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62187 DHCX1=DFOUR(3,1)/DHC12
62188 DHCX2=DFOUR(3,2)/DHC12
62189 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62190 DHCY1=DFOUR(4,1)/DHC12
62191 DHCY2=DFOUR(4,2)/DHC12
62192 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62193 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62195 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62197 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62201 C...Junction strings: produce new particle, origin.
62203 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
62204 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
62205 IF(MSTU(21).GE.1) RETURN
62213 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
62214 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
62215 IF(K(I,2).EQ.0) GOTO 360
62216 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
62217 & IABS(KFL(3)).GT.10) THEN
62218 IF(PYR(0).GT.PARJ(19)) GOTO 440
62220 P(I,5)=PYMASS(K(I,2))
62221 CALL PYPTDI(KFL(1),PX(3),PY(3))
62222 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
62223 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
62224 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
62225 & MSTU(90).LT.8) THEN
62226 MSTU(90)=MSTU(90)+1
62227 MSTU(90+MSTU(90))=I
62228 PARU(90+MSTU(90))=Z
62230 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
62235 C...Junction strings: stepping within 'low' string region.
62236 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
62237 & P(IN(1),5)**2.GE.PR(1)) THEN
62238 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
62239 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
62241 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
62244 C...Has used up energy of junction string, i.e. no more hadrons in it.
62245 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
62250 C...Stepping from 'low' string region
62251 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
62252 P(IN(2)+2,4)=P(IN(2)+2,3)
62255 IF(IN(2).GT.N+NR+4*NS) GOTO 360
62256 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62257 P(IN(1)+2,4)=P(IN(1)+2,3)
62263 C...Junction strings: find new transverse directions.
62264 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
62265 & IN(1).GT.IN(2)) GOTO 360
62266 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
62273 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62274 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62276 IF(DHC12.LE.1D-2) THEN
62277 P(IN(1)+2,4)=P(IN(1)+2,3)
62283 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62284 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62285 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62286 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62287 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62288 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62289 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62290 DHCX1=DFOUR(3,1)/DHC12
62291 DHCX2=DFOUR(3,2)/DHC12
62292 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62293 DHCY1=DFOUR(4,1)/DHC12
62294 DHCY2=DFOUR(4,2)/DHC12
62295 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62296 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62298 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62300 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62303 C...Express pT with respect to new axes, if sensible.
62304 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
62305 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
62306 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
62312 C...Junction strings: sum up known four-momentum, coefficients for m2.
62315 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
62316 & PY(3)*P(IN(3)+1,J)
62317 DO 510 IN1=IN(4),IN(1)-4,4
62318 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
62320 DO 520 IN2=IN(5),IN(2)-4,4
62321 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
62325 DHM(2)=2D0*FOUR(I,IN(1))
62326 DHM(3)=2D0*FOUR(I,IN(2))
62327 DHM(4)=2D0*FOUR(IN(1),IN(2))
62329 C...Junction strings: find coefficients for Gamma expression.
62330 DO 550 IN2=IN(1)+1,IN(2),4
62331 DO 540 IN1=IN(1),IN2-1,4
62332 DHC=2D0*FOUR(IN1,IN2)
62333 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
62334 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
62335 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
62336 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
62340 C...Junction strings: solve (m2, Gamma) equation system for energies.
62341 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
62342 IF(ABS(DHS1).LT.1D-4) GOTO 360
62343 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
62344 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
62345 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
62346 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
62347 & ABS(DHS1)-DHS2/DHS1)
62348 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
62349 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
62350 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
62352 C...Junction strings: step to new region if necessary.
62353 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
62354 P(IN(2)+2,4)=P(IN(2)+2,3)
62357 IF(IN(2).GT.N+NR+4*NS) GOTO 360
62358 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62359 P(IN(1)+2,4)=P(IN(1)+2,3)
62364 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
62365 P(IN(1)+2,4)=P(IN(1)+2,3)
62371 C...Junction strings: particle four-momentum, remainder, loop back.
62373 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
62374 & P(IN(2)+2,4)*P(IN(2),J)
62375 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
62377 IF(P(I,4).LT.P(I,5)) GOTO 360
62378 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
62379 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
62380 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
62385 IF(IN(3).NE.IN(6)) THEN
62387 P(IN(6),J)=P(IN(3),J)
62388 P(IN(6)+1,J)=P(IN(3)+1,J)
62393 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
62394 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
62399 C...Junction strings: save quantities left after each string.
62400 IF(IABS(KFL(1)).GT.10) GOTO 360
62404 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
62407 C...Junction strings: loopback if much unused energy in both strings.
62408 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
62409 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
62410 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
62412 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
62413 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
62414 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
62415 & .AND.NTRYER.LT.10) GOTO 320
62417 C...Junction strings: put together to new effective string endpoint.
62419 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
62420 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
62421 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
62422 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
62424 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
62425 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
62427 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
62432 C...Open versus closed strings. Choose breakup region for latter.
62433 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
62436 ELSEIF(MJU(1).NE.0) THEN
62439 ELSEIF(MJU(2).NE.0) THEN
62442 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
62449 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
62450 W2SUM=W2SUM+P(N+NR+IS,1)
62455 W2SUM=W2SUM-P(N+NR+NB,1)
62456 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
62459 C...Find longitudinal string directions (i.e. lightlike four-vectors).
62461 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
62462 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
62465 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
62466 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
62468 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
62469 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
62471 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
62472 & DP(1,2)**2-DP(1,3)**2))
62473 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
62474 & DP(2,2)**2-DP(2,3)**2))
62478 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
62479 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
62480 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
62481 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
62483 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
62485 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
62486 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
62490 C...Begin initialization: sum up energy, set starting position.
62494 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
62498 ELSEIF(NTRY.GT.100) THEN
62499 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
62500 IF(MSTU(21).GE.1) RETURN
62507 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
62512 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
62513 IF(NS.GT.NR) IRANK(JT)=1
62515 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
62516 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
62517 IN(3*JT+2)=IN(3*JT+1)+1
62518 IN(3*JT+3)=N+NR+4*NS+2*JT-1
62519 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
62526 C.. MOPS variables and switches
62532 C...Initialize flavour and pT variables for open string.
62536 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
62540 KFL(JT)=K(IE(JT),2)
62541 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
62542 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
62544 PMQ(JT)=PYMASS(KFL(JT))
62548 C...Closed string: random initial breakup flavour, pT and vertex.
62550 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
62552 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
62553 C.. Closed string: first vertex diq attempt => enforced second
62555 IF(IABS(KFL(1)).GT.10)THEN
62560 IF(IBMO.EQ.1) MSTU(121)=-1
62562 CALL PYPTDI(KFL(1),PX(1),PY(1))
62565 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
62566 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
62567 ZR=PR3/(Z*P(N+NR+1,5)**2)
62568 IF(ZR.GE.1D0) GOTO 780
62571 PMQ(JT)=PYMASS(KFL(JT))
62572 GAM(JT)=PR3*(1D0-Z)/Z
62573 IN1=N+NR+3+4*(JT/2)*(NS-1)
62576 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
62579 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
62585 PM2QMO(JT)=PMQ(JT)**2
62586 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
62589 C...Find initial transverse directions (i.e. spacelike four-vectors).
62591 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
62600 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62601 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62602 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62603 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62604 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62605 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62606 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62607 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62608 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62610 DHCX1=DFOUR(3,1)/DHC12
62611 DHCX2=DFOUR(3,2)/DHC12
62612 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62613 DHCY1=DFOUR(4,1)/DHC12
62614 DHCY2=DFOUR(4,2)/DHC12
62615 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62616 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62618 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62620 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62625 P(IN3+2,J)=P(IN3,J)
62626 P(IN3+3,J)=P(IN3+1,J)
62631 C...Remove energy used up in junction string fragmentation.
62632 IF(MJU(1)+MJU(2).GT.0) THEN
62634 IF(NJS(JT).EQ.0) GOTO 860
62636 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
62640 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
62641 WMIN=PARJST+PMQ(1)+PMQ(2)
62642 WREM2=FOUR(N+NRS,N+NRS)
62643 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
62645 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
62650 C...Produce new particle: side, origin.
62652 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
62653 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
62654 IF(MSTU(21).GE.1) RETURN
62656 C.. New side priority for popcorn systems
62657 IF(MSTU(121).LE.0)THEN
62659 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
62660 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
62664 IRANK(JT)=IRANK(JT)+1
62669 C...Generate flavour, hadron and pT.
62671 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
62672 IF(K(I,2).EQ.0) GOTO 710
62674 IF(MSTU(121).EQ.-1) GOTO 910
62675 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
62676 &IABS(KFL(3)).GT.10) THEN
62677 IF(PYR(0).GT.PARJ(19)) GOTO 880
62679 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62681 P(I,5)=PYMASS(K(I,2))
62682 CALL PYPTDI(KFL(JT),PX(3),PY(3))
62683 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
62685 C...Final hadrons for small invariant mass.
62687 PMQ(3)=PYMASS(KFL(3))
62689 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
62690 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
62691 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
62692 &WMIN-0.5D0*PARJ(36)*PMQ(3)
62693 WREM2=FOUR(N+NRS,N+NRS)
62694 IF(WREM2.LT.0.10D0) GOTO 710
62695 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
62696 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
62698 C...Choose z, which gives Gamma. Shift z for heavy flavours.
62699 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
62700 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
62701 &MSTU(90).LT.8) THEN
62702 MSTU(90)=MSTU(90)+1
62703 MSTU(90+MSTU(90))=I
62704 PARU(90+MSTU(90))=Z
62708 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
62709 &MOD(KFL2A/1000,10)).GE.4) THEN
62710 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
62711 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
62712 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
62713 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
62714 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
62716 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
62718 C.. MOPS baryon model modification
62719 XTMO3=(1D0-Z)*XTMO(JT)
62720 IF(IABS(KFL(3)).LE.10) NRVMO=0
62721 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
62725 IF(IABS(KFL(JT)).LE.10)THEN
62726 XBMO=MIN(XTMO3,1D0-(2D-10))
62729 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
62730 GTSTMO=1D0-PARF(192)**PGMO
62732 IF(IRANK(JT).EQ.1) THEN
62737 IF(XBMO.LT.1D0-(1D-10))THEN
62738 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
62739 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
62742 IF(MSTJ(12).GE.5)THEN
62743 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
62744 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
62745 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
62750 C.. MOPS Accepting popcorn system hadron.
62751 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
62752 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
62754 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
62756 & '(PYSTRF:) no more memory left in PYJETS')
62757 IF(MSTU(21).GE.1) RETURN
62769 DO 890 LINE=1,I-N-NR
62770 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
62771 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
62778 C..Reject popcorn system, flag=-1 if enforcing new one
62780 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
62785 C..Lift restoring string outside MOPS block
62786 910 IF(MSTU(121).LT.0) THEN
62787 IF(MSTU(121).EQ.-2) MSTU(121)=0
62790 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
62801 DO 920 LINE=1,I-N-NR
62802 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
62803 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
62811 C.. MOPS end of modification
62817 C...Stepping within or from 'low' string region easy.
62818 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
62819 &P(IN(1),5)**2.GE.PR(JT)) THEN
62820 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
62821 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
62823 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
62826 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
62827 P(IN(JR)+2,4)=P(IN(JR)+2,3)
62830 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
62831 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62832 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62838 C...Find new transverse directions (i.e. spacelike string vectors).
62839 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
62840 &IN(1).GT.IN(2)) GOTO 710
62841 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
62848 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62849 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62851 IF(DHC12.LE.1D-2) THEN
62852 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62858 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62859 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62860 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62861 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62862 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62863 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62864 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62865 DHCX1=DFOUR(3,1)/DHC12
62866 DHCX2=DFOUR(3,2)/DHC12
62867 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62868 DHCY1=DFOUR(4,1)/DHC12
62869 DHCY2=DFOUR(4,2)/DHC12
62870 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62871 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62873 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62875 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62878 C...Express pT with respect to new axes, if sensible.
62879 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
62880 & FOUR(IN(3*JT+3)+1,IN(3)))
62881 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
62882 & FOUR(IN(3*JT+3)+1,IN(3)+1))
62883 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
62889 C...Sum up known four-momentum. Gives coefficients for m2 expression.
62892 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
62893 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
62894 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
62895 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
62897 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
62898 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
62902 DHM(2)=2D0*FOUR(I,IN(1))
62903 DHM(3)=2D0*FOUR(I,IN(2))
62904 DHM(4)=2D0*FOUR(IN(1),IN(2))
62906 C...Find coefficients for Gamma expression.
62907 DO 1030 IN2=IN(1)+1,IN(2),4
62908 DO 1020 IN1=IN(1),IN2-1,4
62909 DHC=2D0*FOUR(IN1,IN2)
62910 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
62911 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
62912 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
62913 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
62917 C...Solve (m2, Gamma) equation system for energies taken.
62918 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
62919 IF(ABS(DHS1).LT.1D-4) GOTO 710
62920 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
62921 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
62922 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
62923 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
62924 &ABS(DHS1)-DHS2/DHS1)
62925 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
62926 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
62927 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
62929 C...Step to new region if necessary.
62930 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
62931 P(IN(JR)+2,4)=P(IN(JR)+2,3)
62934 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
62935 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62936 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62941 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
62942 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62948 C...Four-momentum of particle. Remaining quantities. Loop back.
62950 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
62951 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
62953 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
62954 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
62956 IF(P(I,4).LT.P(I,5)) GOTO 710
62962 IF(IN(3).NE.IN(3*JT+3)) THEN
62964 P(IN(3*JT+3),J)=P(IN(3),J)
62965 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
62970 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
62971 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
62973 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62977 C...Final hadron: side, flavour, hadron, mass.
62983 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
62984 IF(K(I,2).EQ.0) GOTO 710
62985 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
62987 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62989 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62991 P(I,5)=PYMASS(K(I,2))
62992 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
62994 C...Final two hadrons: find common setup of four-vectors.
62996 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
62997 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
62998 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
62999 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
63000 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
63001 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
63002 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
63003 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
63004 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
63005 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
63008 C...Solve kinematics for final two hadrons, if possible.
63009 WREM2=2D0*DHR1*DHR2*DHC12
63010 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
63011 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
63012 IF(FD.GE.1D0) GOTO 710
63013 FA=WREM2+PR(JT)-PR(JR)
63014 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
63016 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
63017 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
63018 FB=SIGN(FB,JS*(PYR(0)-PREV))
63021 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
63022 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
63023 &4D0*WREM2*PR(JT))),DBLE(JS))
63025 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
63026 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
63027 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
63028 P(I,J)=P(N+NRS,J)-P(I-1,J)
63030 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
63031 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
63032 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
63033 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
63035 IF(NTRYFN.LT.100) GOTO 140
63036 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
63039 C...Mark jets as fragmented and give daughter pointers.
63041 DO 1100 I=NSAV+1,NSAV+NP
63044 IF(MSTU(16).NE.2) THEN
63053 C...Document string system. Move up particles.
63064 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
63068 K(I,J)=K(I+NRS-1,J)
63069 P(I,J)=P(I+NRS-1,J)
63074 DO 1140 IZ=MSTU90+1,MSTU91
63075 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
63076 PARU9T(IZ)=PARU(90+IZ)
63080 C...Order particles in rank along the chain. Update mother pointer.
63083 K(I-NSAV+N,J)=K(I,J)
63084 P(I-NSAV+N,J)=P(I,J)
63088 DO 1190 I=N+1,2*N-NSAV
63089 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
63095 IF(MSTU(16).NE.2) K(I1,3)=NSAV
63096 DO 1180 IZ=MSTU90+1,MSTU91
63097 IF(MSTU9T(IZ).EQ.I) THEN
63098 MSTU(90)=MSTU(90)+1
63099 MSTU(90+MSTU(90))=I1
63100 PARU(90+MSTU(90))=PARU9T(IZ)
63104 DO 1220 I=2*N-NSAV,N+1,-1
63105 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
63111 IF(MSTU(16).NE.2) K(I1,3)=NSAV
63112 DO 1210 IZ=MSTU90+1,MSTU91
63113 IF(MSTU9T(IZ).EQ.I) THEN
63114 MSTU(90)=MSTU(90)+1
63115 MSTU(90+MSTU(90))=I1
63116 PARU(90+MSTU(90))=PARU9T(IZ)
63121 C...Boost back particle system. Set production vertices.
63124 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
63128 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
63129 IF(P(I,3).GT.0D0) THEN
63130 HHPEZ=(P(I,4)+P(I,3))*HHBZ
63131 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
63132 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
63134 HHPEZ=(P(I,4)-P(I,3))/HHBZ
63135 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
63136 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
63149 C*********************************************************************
63152 C...From three given input vectors in PJU the boost VJU from
63153 C...the "lab frame" to the junction rest frame is constructed.
63155 SUBROUTINE PYJURF(PJU,VJU)
63157 C...Double precision and integer declarations.
63158 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63159 IMPLICIT INTEGER(I-N)
63161 C...Input, output and local arrays.
63162 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
63163 DATA TWOPI/6.283186D0/
63165 C...Calculate masses and other invariants.
63167 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
63169 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
63170 PSUM(5)=SQRT(PSUM2)
63173 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
63174 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
63178 C...Pick I to be most massive parton and J to be the one closest to I.
63181 IF(A(2,2).GT.A(1,1)) I=2
63182 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
63186 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
63197 C...Trivial find new parton energies if all three partons are massless.
63198 IF(PMI2.LT.1D-4) THEN
63199 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
63200 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
63201 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
63203 C...Else find momentum range for parton I and values at extremes.
63209 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
63210 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
63211 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
63212 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
63213 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
63214 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
63215 HI=PEIMAX**2-0.25D0*PAIMAX**2
63216 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
63217 & 0.5D0*PAIMAX*AIJ)/HI
63218 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
63219 & 0.5D0*PAIMAX*AIK)/HI
63220 PEJMAX=SQRT(PAJMAX**2+PMJ2)
63221 PEKMAX=SQRT(PAKMAX**2+PMK2)
63222 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
63224 C...If unexpected values at upper endpoint then pick another parton.
63225 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
63227 IF(A(I1,I1).GE.1D-4) THEN
63233 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
63239 C..Start binary + linear search to find solution inside range.
63243 PAI=0.5D0*(PAIMIN+PAIMAX)
63246 C...Derive momentum of other two partons and distance to root.
63247 PEI=SQRT(PAI**2+PMI2)
63248 HI=PEI**2-0.25D0*PAI**2
63249 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
63250 PEJ=SQRT(PAJ**2+PMJ2)
63251 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
63252 PEK=SQRT(PAK**2+PMK2)
63253 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
63255 C...Pick next I momentum to explore, hopefully closer to root.
63256 IF(FNOW.GT.0D0) THEN
63265 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
63267 PAI=0.5D0*(PAIMIN+PAIMAX)
63269 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
63270 & ABS(FNOW).GT.1D-12*PSUM2) THEN
63271 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
63276 C...Now know energies in junction rest frame.
63281 C...Boost (copy of) partons to their rest frame.
63282 VXCM=-PSUM(1)/PSUM(5)
63283 VYCM=-PSUM(2)/PSUM(5)
63284 VZCM=-PSUM(3)/PSUM(5)
63285 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
63287 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
63288 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
63289 PCM(I,1)=PJU(I,1)+FAC2*VXCM
63290 PCM(I,2)=PJU(I,2)+FAC2*VYCM
63291 PCM(I,3)=PJU(I,3)+FAC2*VZCM
63292 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
63293 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
63296 C...Construct difference vectors and boost to junction rest frame.
63298 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
63299 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
63301 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
63302 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
63303 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
63304 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
63305 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
63306 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
63307 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
63308 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
63309 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
63310 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
63311 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
63313 C...Add two boosts, giving final result.
63314 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
63315 VJU(1)=VXJU+FCM*VXCM
63316 VJU(2)=VYJU+FCM*VYCM
63317 VJU(3)=VZJU+FCM*VZCM
63318 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
63321 C...In case of error in reconstruction: revert to CM frame of system.
63322 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
63323 &(PCM(1,5)*PCM(2,5))
63324 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
63325 &(PCM(1,5)*PCM(3,5))
63326 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
63327 &(PCM(2,5)*PCM(3,5))
63328 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
63329 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
63331 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
63332 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
63333 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
63334 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
63335 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
63336 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
63337 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
63339 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
63340 &(PCM(1,5)*PCM(2,5))
63341 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
63342 &(PCM(1,5)*PCM(3,5))
63343 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
63344 &(PCM(2,5)*PCM(3,5))
63345 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
63346 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
63347 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
63357 C*********************************************************************
63360 C...Handles the fragmentation of a jet system (or a single
63361 C...jet) according to independent fragmentation models.
63363 SUBROUTINE PYINDF(IP)
63365 C...Double precision and integer declarations.
63366 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63367 IMPLICIT INTEGER(I-N)
63368 INTEGER PYK,PYCHGE,PYCOMP
63370 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
63371 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63372 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63373 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
63375 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
63376 &KFLO(2),PXO(2),PYO(2),WO(2)
63378 C.. MOPS error message
63379 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
63380 &' are not treated as expected in independent fragmentation')
63382 C...Reset counters. Identify parton system and take copy. Check flavour.
63392 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
63393 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
63394 IF(MSTU(21).GE.1) RETURN
63396 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
63398 IF(KC.EQ.0) GOTO 110
63399 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
63400 IF(KQ.EQ.0) GOTO 110
63402 IF(KQ.NE.2) KQSUM=KQSUM+KQ
63404 K(NSAV+NJET,J)=K(I,J)
63405 P(NSAV+NJET,J)=P(I,J)
63406 DPS(J)=DPS(J)+P(I,J)
63409 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
63410 &K(I+1,1).EQ.2)) GOTO 110
63411 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
63412 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
63413 IF(MSTU(21).GE.1) RETURN
63416 C...Boost copied system to CM frame. Find CM energy and sum flavours.
63419 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
63420 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
63426 DO 140 I=NSAV+1,NSAV+NJET
63430 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
63431 ELSEIF(KFA.GT.1000) THEN
63432 KFLA=MOD(KFA/1000,10)
63433 KFLB=MOD(KFA/100,10)
63434 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
63435 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
63439 C...Loop over attempts made. Reset counters.
63442 IF(NTRY.GT.200) THEN
63443 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
63444 IF(MSTU(21).GE.1) RETURN
63454 C...Loop over jets to be fragmented.
63455 DO 230 IP1=NSAV+1,NSAV+NJET
63460 C...Initial flavour and momentum values. Jet along +z axis.
63461 KFLH=IABS(K(IP1,2))
63462 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
63464 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
63466 C...Initial values for quark or diquark jet.
63467 170 IF(IABS(K(IP1,2)).NE.21) THEN
63470 CALL PYPTDI(0,PXO(1),PYO(1))
63473 C...Initial values for gluon treated like random quark jet.
63474 ELSEIF(MSTJ(2).LE.2) THEN
63476 IF(MSTJ(2).EQ.2) MSTJ(91)=1
63477 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
63478 CALL PYPTDI(0,PXO(1),PYO(1))
63481 C...Initial values for gluon treated like quark-antiquark jet pair,
63482 C...sharing energy according to Altarelli-Parisi splitting function.
63485 IF(MSTJ(2).EQ.4) MSTJ(91)=1
63486 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
63488 CALL PYPTDI(0,PXO(1),PYO(1))
63491 WO(1)=WF*PYR(0)**(1D0/3D0)
63495 C...Initial values for rank, flavour, pT and W+.
63505 C...New hadron. Generate flavour and hadron species.
63507 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
63508 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
63509 IF(MSTU(21).GE.1) RETURN
63516 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
63517 IF(K(I,2).EQ.0) GOTO 180
63518 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
63519 IF(PYR(0).GT.PARJ(19)) GOTO 200
63522 C...Find hadron mass. Generate four-momentum.
63523 P(I,5)=PYMASS(K(I,2))
63524 CALL PYPTDI(KFL1,PX2,PY2)
63527 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
63528 CALL PYZDIS(KFL1,KFL2,PR,Z)
63530 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
63532 MSTU(90)=MSTU(90)+1
63533 MSTU(90+MSTU(90))=I
63534 PARU(90+MSTU(90))=Z
63536 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
63537 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
63538 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
63539 & P(I,3).LE.0.001D0) THEN
63540 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
63546 C...Remaining flavour and momentum.
63555 C...Check if pL acceptable. Go back for new hadron if enough energy.
63556 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
63558 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
63560 IF(W.GT.PARJ(31)) GOTO 190
63563 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
63564 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
63566 C...Rotate jet to new direction.
63567 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
63568 PHI=PYANGL(P(IP1,1),P(IP1,2))
63570 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
63571 K(K(IP1,3),4)=NSAV1+1
63574 C...End of jet generation loop. Skip conservation in some cases.
63576 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
63577 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
63579 C...Subtract off produced hadron flavours, finished if zero.
63580 DO 240 I=NSAV+NJET+1,N
63582 KFLA=MOD(KFA/1000,10)
63583 KFLB=MOD(KFA/100,10)
63584 KFLC=MOD(KFA/10,10)
63586 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
63587 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
63589 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
63590 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
63591 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,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.EQ.0) GOTO 320
63598 C...Take away flavour of low-momentum particles until enough freedom.
63602 DO 260 I=NSAV+NJET+1,N
63603 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
63604 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
63605 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
63607 IF(IREM.EQ.0) GOTO 150
63609 KFA=IABS(K(IREM,2))
63610 KFLA=MOD(KFA/1000,10)
63611 KFLB=MOD(KFA/100,10)
63612 KFLC=MOD(KFA/10,10)
63613 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
63614 IF(K(IREM,1).EQ.8) GOTO 250
63616 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
63617 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
63618 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
63620 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
63621 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
63622 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
63625 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
63626 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
63627 IF(NREQ.GT.NREM) GOTO 250
63628 DO 270 I=NSAV+NJET+1,N
63629 IF(K(I,1).EQ.8) K(I,1)=1
63632 C...Find combination of existing and new flavours for hadron.
63634 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
63635 IF(NREQ.LT.NREM) NFET=1
63636 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
63638 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
63639 KFLF(J)=ISIGN(1,NFL(1))
63640 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
63641 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
63643 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
63645 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
63646 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
63647 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
63648 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
63649 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
63650 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
63651 IF(NFET.LE.2) KFLF(3)=0
63652 IF(KFLF(3).NE.0) THEN
63653 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
63654 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
63655 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
63656 & KFLFC=KFLFC+ISIGN(2,KFLFC)
63660 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
63661 IF(KF.EQ.0) GOTO 280
63662 DO 300 J=1,MAX(2,NFET)
63663 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
63666 C...Store hadron at random among free positions.
63667 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
63668 DO 310 I=NSAV+NJET+1,N
63669 IF(K(I,1).EQ.7) NPOS=NPOS-1
63670 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
63673 P(I,5)=PYMASS(K(I,2))
63674 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63677 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
63678 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
63679 IF(NREM.GT.0) GOTO 280
63681 C...Compensate for missing momentum in global scheme (3 options).
63682 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
63685 DO 330 I=NSAV+NJET+1,N
63686 PSI(J)=PSI(J)+P(I,J)
63689 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
63691 DO 350 I=NSAV+NJET+1,N
63692 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
63693 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
63694 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
63695 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
63697 DO 370 I=NSAV+NJET+1,N
63698 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
63699 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
63700 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
63701 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
63703 P(I,J)=P(I,J)-PSI(J)*PW/PWS
63705 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63708 C...Compensate for missing momentum withing each jet separately.
63709 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
63710 DO 390 I=N+1,N+NJET
63716 DO 410 I=NSAV+NJET+1,N
63719 K(IR2,1)=K(IR2,1)+1
63720 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
63721 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
63723 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
63725 P(IR2,4)=P(IR2,4)+P(I,4)
63726 P(IR2,5)=P(IR2,5)+PLS
63729 DO 420 I=N+1,N+NJET
63730 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
63732 DO 440 I=NSAV+NJET+1,N
63735 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
63736 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
63738 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
63741 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63745 C...Scale momenta for energy conservation.
63746 IF(MOD(MSTJ(3),5).NE.0) THEN
63750 DO 450 I=NSAV+NJET+1,N
63753 PQS=PQS+P(I,5)**2/P(I,4)
63755 IF(PMS.GE.PECM) GOTO 150
63758 PFAC=(PECM-PQS)/(PES-PQS)
63761 DO 480 I=NSAV+NJET+1,N
63765 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63767 PQS=PQS+P(I,5)**2/P(I,4)
63769 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
63772 C...Origin of produced particles and parton daughter pointers.
63773 490 DO 500 I=NSAV+NJET+1,N
63774 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
63775 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
63777 DO 510 I=NSAV+1,NSAV+NJET
63780 IF(MSTU(16).NE.2) THEN
63784 K(I1,4)=K(I1,4)-NJET+1
63785 K(I1,5)=K(I1,5)-NJET+1
63786 IF(K(I1,5).LT.K(I1,4)) THEN
63793 C...Document independent fragmentation system. Remove copy of jets.
63804 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
63806 DO 540 I=NSAV+NJET,N
63808 K(I-NJET+1,J)=K(I,J)
63809 P(I-NJET+1,J)=P(I,J)
63810 V(I-NJET+1,J)=V(I,J)
63814 DO 550 IZ=MSTU90+1,MSTU(90)
63815 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
63818 C...Boost back particle system. Set production vertices.
63819 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
63820 &DPS(2)/DPS(4),DPS(3)/DPS(4))
63830 C*********************************************************************
63833 C...Handles the decay of unstable particles.
63835 SUBROUTINE PYDECY(IP)
63837 C...Double precision and integer declarations.
63838 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63839 IMPLICIT INTEGER(I-N)
63840 INTEGER PYK,PYCHGE,PYCOMP
63842 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
63843 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63844 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63845 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
63846 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
63848 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
63849 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
63851 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
63853 C...Functions: momentum in two-particle decays and four-product.
63854 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
63855 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)
63857 C...Initial values.
63861 KFS=ISIGN(1,K(IP,2))
63865 C...Choose lifetime and determine decay vertex.
63866 IF(K(IP,1).EQ.5) THEN
63868 ELSEIF(K(IP,1).NE.4) THEN
63869 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
63872 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
63875 C...Determine whether decay allowed or not.
63877 IF(MSTJ(22).EQ.2) THEN
63878 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
63879 ELSEIF(MSTJ(22).EQ.3) THEN
63880 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
63881 ELSEIF(MSTJ(22).EQ.4) THEN
63882 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
63883 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
63885 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
63890 C...Interface to external tau decay library (for tau polarization).
63891 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
63893 C...Starting values for pointers and momenta.
63897 PCMTAU(J)=P(ITAU,J)
63900 C...Iterate to find position and code of mother of tau.
63902 120 IMTAU=K(IMTAU,3)
63904 IF(IMTAU.EQ.0) THEN
63905 C...If no known origin then impossible to do anything further.
63909 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
63910 C...If tau -> tau + gamma then add gamma energy and loop.
63911 IF(K(K(IMTAU,4),2).EQ.22) THEN
63913 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
63915 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
63917 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
63922 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
63923 C...If coming from weak decay of hadron then W is not stored in record,
63924 C...but can be reconstructed by adding neutrino momentum.
63925 KFORIG=-ISIGN(24,K(ITAU,2))
63927 DO 160 II=K(IMTAU,4),K(IMTAU,5)
63928 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
63930 PCMTAU(J)=PCMTAU(J)+P(II,J)
63936 C...If coming from resonance decay then find latest copy of this
63937 C...resonance (may not completely agree).
63940 DO 170 II=IMTAU+1,IP-1
63941 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
63942 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
63945 PCMTAU(J)=P(IORIG,J)
63949 C...Boost tau to rest frame of production process (where known)
63950 C...and rotate it to sit along +z axis.
63952 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
63954 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
63955 & -DBETAU(2),-DBETAU(3))
63956 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
63957 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
63958 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
63959 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
63961 C...Call tau decay routine (if meaningful) and fill extra info.
63962 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
63963 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
63964 DO 200 II=NSAV+1,NSAV+NDECAY
63973 C...Boost back decay tau and decay products.
63977 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
63978 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
63979 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
63980 & DBETAU(2),DBETAU(3))
63982 C...Skip past ordinary tau decay treatment.
63990 C...B-Bbar mixing: flip sign of meson appropriately.
63992 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
63994 IF(KFA.EQ.531) XBBMIX=PARJ(77)
63995 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
63996 IF(MMIX.EQ.1) KFS=-KFS
63999 C...Check existence of decay channels. Particle/antiparticle rules.
64001 IF(MDCY(KC,2).GT.0) THEN
64002 MDMDCY=MDME(MDCY(KC,2),2)
64003 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
64005 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
64006 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
64009 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
64010 IF(KCHG(KC,3).EQ.0) THEN
64013 IF(PYR(0).GT.0.5D0) KFS=-KFS
64014 ELSEIF(KFS.GT.0) THEN
64022 C...Sum branching ratios of allowed decay channels.
64025 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
64026 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
64027 & KFSN*MDME(IDL,1).NE.3) GOTO 230
64028 IF(MDME(IDL,2).GT.100) GOTO 230
64030 BRSU=BRSU+BRAT(IDL)
64033 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
64037 C...Select decay channel among allowed ones.
64038 240 RBR=BRSU*PYR(0)
64041 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
64042 &KFSN*MDME(IDL,1).NE.3) THEN
64043 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
64044 ELSEIF(MDME(IDL,2).GT.100) THEN
64045 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
64049 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
64052 C...Start readout of decay channel: matrix element, reset counters.
64055 IF(MOD(NTRY,200).EQ.0) THEN
64056 WRITE(CIDC,'(I4)') IDC
64057 C...Do not print warning for some well-known special cases.
64058 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
64059 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
64063 IF(NTRY.GT.1000) THEN
64064 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
64065 IF(MSTU(21).GE.1) RETURN
64071 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
64074 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
64076 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
64082 IF(KFA.GT.80) MHADDY=1
64083 C.. Random flavour and popcorn system memory.
64089 C...Read out decay products. Convert to standard flavour code.
64091 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
64093 IF(JT.LE.5) KP=KFDP(IDC,JT)
64094 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
64095 IF(KP.EQ.0) GOTO 280
64098 IF(KPA.GT.80) MHADDY=1
64099 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
64101 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
64103 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
64104 KFP=-KFS*MOD(KFA/10,10)
64105 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
64106 KFP=KFS*(100*MOD(KFA/10,100)+3)
64107 ELSEIF(KPA.EQ.81) THEN
64108 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
64109 ELSEIF(KP.EQ.82) THEN
64110 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
64111 IF(KFP.EQ.0) GOTO 260
64115 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
64116 ELSEIF(KP.EQ.-82) THEN
64119 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
64121 C...Add decay product to event record or to quark flavour list.
64124 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
64127 C...set rndmflav popcorn system pointer
64128 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
64130 PSQ=PSQ+PYMASS(KFLO(NQ))
64131 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
64132 & MOD(NQ,2).EQ.1) THEN
64137 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
64138 IF(K(I,2).EQ.0) GOTO 260
64140 P(I,5)=PYMASS(K(I,2))
64145 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
64146 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
64148 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
64149 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
64159 C...Check masses for resonance decays.
64160 IF(MHADDY.EQ.0) THEN
64161 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
64164 C...Choose decay multiplicity in phase space model.
64165 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
64167 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
64168 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
64170 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
64171 IF(IRNDMO.EQ.0) THEN
64174 ELSEIF(IRNDMO.EQ.1) THEN
64179 IF(NTRY.GT.1000) THEN
64180 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
64181 IF(MSTU(21).GE.1) RETURN
64183 IF(MMAT.LE.20) THEN
64184 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
64185 & SIN(PARU(2)*PYR(0))
64186 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
64187 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
64188 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
64189 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
64190 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
64194 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
64196 IF(MSTU(121).GT.MSTU(125)) GOTO 300
64198 C...Form hadrons from flavour content.
64202 IF(ND.EQ.NP+NQ/2) GOTO 330
64203 DO 320 I=N+NP+1,N+ND-NQ/2
64204 C.. Stick to started popcorn system, else pick side at random
64206 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
64207 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
64208 IF(K(I,2).EQ.0) GOTO 300
64209 MSTU(125)=MSTU(125)-1
64211 IF(MSTU(121).GT.0) JTMO=JT
64217 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
64218 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
64219 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
64222 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
64223 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
64224 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
64225 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
64227 C...Check that sum of decay product masses not too large.
64229 DO 340 I=N+NP+1,N+ND
64234 P(I,5)=PYMASS(K(I,2))
64237 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
64239 C...Rescale energy to subtract off spectator quark mass.
64240 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
64241 & .AND.NP.GE.3) THEN
64243 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
64245 P(N+NP,J)=PQT*PV(1,J)
64246 PV(1,J)=(1D0-PQT)*PV(1,J)
64248 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
64252 C...Fully specified final state: check mass broadening effects.
64254 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
64258 C...Determine position of grandmother, number of sisters.
64264 IF(IM.LT.0.OR.IM.GE.IP) IM=0
64265 IF(IM.NE.0) KFAM=IABS(K(IM,2))
64267 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
64268 IF(K(IL,3).EQ.IM) NM=NM+1
64269 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
64271 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
64272 & MOD(KFAM/1000,10).NE.0) NM=0
64274 KFAS=IABS(K(ISIS,2))
64275 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
64276 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
64281 C...Kinematics of one-particle decays.
64289 C...Calculate maximum weight ND-particle decay.
64292 WTMAX=1D0/WTCOR(ND-2)
64293 PMAX=PV(1,5)-PS+P(N+ND,5)
64295 DO 380 IL=ND-1,1,-1
64296 PMAX=PMAX+P(N+IL,5)
64297 PMIN=PMIN+P(N+IL+1,5)
64298 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
64302 C...Find virtual gamma mass in Dalitz decay.
64303 390 IF(ND.EQ.2) THEN
64304 ELSEIF(MMAT.EQ.2) THEN
64305 PMES=4D0*PMAS(11,1)**2
64306 PMRHO2=PMAS(131,1)**2
64307 PGRHO2=PMAS(131,2)**2
64308 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
64309 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
64310 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
64311 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
64312 IF(WT.LT.PYR(0)) GOTO 400
64313 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
64315 C...M-generator gives weight. If rejected, try again.
64320 DO 420 IL2=IL1-1,1,-1
64321 IF(RSAV.LE.RORD(IL2)) GOTO 430
64322 RORD(IL2+1)=RORD(IL2)
64324 430 RORD(IL2+1)=RSAV
64328 DO 450 IL=ND-1,1,-1
64329 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
64331 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
64333 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
64336 C...Perform two-particle decays in respective CM frame.
64337 460 DO 480 IL=1,ND-1
64338 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
64339 UE(3)=2D0*PYR(0)-1D0
64341 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
64342 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
64345 PV(IL+1,J)=-PA*UE(J)
64347 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
64348 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
64351 C...Lorentz transform decay products to lab frame.
64355 DO 530 IL=ND-1,1,-1
64357 BE(J)=PV(IL,J)/PV(IL,4)
64359 GA=PV(IL,4)/PV(IL,5)
64361 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
64363 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
64365 P(I,4)=GA*(P(I,4)+BEP)
64369 C...Check that no infinite loop in matrix element weight.
64371 IF(NTRY.GT.800) GOTO 560
64373 C...Matrix elements for omega and phi decays.
64375 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
64376 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
64377 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
64378 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
64380 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
64381 ELSEIF(MMAT.EQ.2) THEN
64382 FOUR12=FOUR(N+1,N+2)
64383 FOUR13=FOUR(N+1,N+3)
64384 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
64385 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
64386 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
64388 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
64389 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
64390 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
64391 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
64393 FOUR12=FOUR(IP,N+1)
64394 FOUR02=FOUR(IM,N+1)
64398 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
64399 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
64400 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
64401 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
64402 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
64403 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
64405 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
64406 ELSEIF(MMAT.EQ.4) THEN
64407 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
64408 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
64409 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
64410 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
64411 & ((1D0-HX3)/(HX1*HX2))**2
64412 IF(WT.LT.2D0*PYR(0)) GOTO 390
64413 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
64416 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
64417 ELSEIF(MMAT.EQ.41) THEN
64418 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
64419 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
64420 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
64421 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
64423 C...Matrix elements for weak decays (only semileptonic for c and b)
64424 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
64425 & .AND.ND.EQ.3) THEN
64426 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
64427 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
64428 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
64429 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
64433 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
64436 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
64437 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
64438 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
64441 C...Scale back energy and reattach spectator.
64442 560 IF(MREM.EQ.1) THEN
64444 PV(1,J)=PV(1,J)/(1D0-PQT)
64450 C...Low invariant mass for system with spectator quark gives particle,
64451 C...not two jets. Readjust momenta accordingly.
64452 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
64454 PM2=PYMASS(K(N+2,2))
64456 PM3=PYMASS(K(N+3,2))
64457 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
64458 & (PARJ(32)+PM2+PM3)**2) GOTO 630
64461 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
64462 IF(K(N+2,2).EQ.0) GOTO 260
64463 P(N+2,5)=PYMASS(K(N+2,2))
64464 PS=P(N+1,5)+P(N+2,5)
64469 ELSEIF(MMAT.EQ.44) THEN
64471 PM3=PYMASS(K(N+3,2))
64473 PM4=PYMASS(K(N+4,2))
64474 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
64475 & (PARJ(32)+PM3+PM4)**2) GOTO 600
64478 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
64479 IF(K(N+3,2).EQ.0) GOTO 260
64480 P(N+3,5)=PYMASS(K(N+3,2))
64482 P(N+3,J)=P(N+3,J)+P(N+4,J)
64484 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)
64485 HA=P(N+1,4)**2-P(N+2,4)**2
64486 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
64487 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
64488 & (P(N+1,3)-P(N+2,3))**2
64489 HD=(PV(1,4)-P(N+3,4))**2
64490 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
64493 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
64495 PCOR=HH*(P(N+1,J)-P(N+2,J))
64496 P(N+1,J)=P(N+1,J)+PCOR
64497 P(N+2,J)=P(N+2,J)-PCOR
64499 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)
64500 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)
64504 C...Check invariant mass of W jets. May give one particle or start over.
64505 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
64506 &.AND.IABS(K(N+1,2)).LT.10) THEN
64507 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
64509 PM1=PYMASS(K(N+1,2))
64511 PM2=PYMASS(K(N+2,2))
64512 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
64513 KFLDUM=INT(1.5D0+PYR(0))
64514 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
64515 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
64516 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
64517 PSM=PYMASS(KF1)+PYMASS(KF2)
64518 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
64519 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
64520 IF(MMAT.EQ.48) GOTO 390
64521 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
64524 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
64525 IF(K(N+1,2).EQ.0) GOTO 260
64526 P(N+1,5)=PYMASS(K(N+1,2))
64529 PS=P(N+1,5)+P(N+2,5)
64530 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
64537 C...Phase space decay of partons from W decay.
64538 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
64544 PV(1,J)=P(N+1,J)+P(N+2,J)
64553 PSQ=PYMASS(KFLO(1))
64555 PSQ=PSQ+PYMASS(KFLO(2))
64560 C...Boost back for rapidly moving particle.
64564 BE(J)=P(IP,J)/P(IP,4)
64568 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
64570 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
64572 P(I,4)=GA*(P(I,4)+BEP)
64576 C...Fill in position of decay vertex.
64584 C...Set up for parton shower evolution from jets.
64585 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
64589 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
64590 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
64591 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
64592 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
64593 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
64594 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
64596 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
64599 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
64600 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
64601 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
64602 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
64604 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
64605 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
64608 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
64609 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
64610 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
64611 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
64613 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
64614 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
64616 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
64621 KCP=PYCOMP(K(NSAV+1,2))
64622 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
64624 IF(KQP.LT.0) JCON=5
64625 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
64626 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
64627 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
64628 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
64630 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
64633 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
64634 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
64635 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
64636 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
64640 C...Mark decayed particle; special option for B-Bbar mixing.
64641 IF(K(IP,1).EQ.5) K(IP,1)=15
64642 IF(K(IP,1).LE.10) K(IP,1)=11
64643 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
64651 C*********************************************************************
64654 C...Handles flavour production in the decay of unstable particles
64655 C...and small string clusters.
64657 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
64659 C...Double precision and integer declarations.
64660 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64661 IMPLICIT INTEGER(I-N)
64662 INTEGER PYK,PYCHGE,PYCOMP
64664 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64665 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64666 SAVE /PYDAT1/,/PYDAT2/
64669 C.. Call PYKFDI directly if no popcorn option is on
64670 IF(MSTJ(12).LT.2) THEN
64671 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
64678 IF(KFL1.EQ.0) RETURN
64683 NMAX=MIN(MSTU(125),10)
64685 C.. Identify rank 0 cluster qq
64687 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
64690 C.. Join jets: Fails if store not empty
64691 IF(MSTU(121).GT.0) THEN
64695 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
64696 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
64697 C.. Pick popcorn meson from store, return same qq, decrease store
64698 KF=MSTU(NSTO+MSTU(121))
64700 MSTU(121)=MSTU(121)-1
64702 C.. Generate new flavour. Then done if no diquark is generated
64703 100 CALL PYKFDI(KFL1,0,KFL3,KF)
64704 IF(MSTU(121).EQ.-1) GOTO 100
64706 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
64708 C.. Simple case if no dynamical popcorn suppressions are considered
64709 IF(MSTJ(12).LT.4) THEN
64710 IF(MSTU(121).EQ.0) RETURN
64713 CALL PYKFDI(KFPREV,0,KFL3,KFM)
64714 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
64715 IF(IABS(KFL3).LE.10)THEN
64722 C test output qq against fake Gamma, then return if no popcorn.
64725 CALL PYZDIS(1,2103,5D0,Z)
64727 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
64732 IF(MSTU(121).EQ.0) RETURN
64734 C..Set store size memory. Pick fake dynamical variables of qq.
64736 CALL PYPTDI(1,PX3,PY3)
64742 C.. Pick next popcorn meson, test with fake dynamical variables
64746 CALL PYKFDI(KFPREV,0,KFL3,KFM)
64747 IF(MSTU(121).EQ.-1) GOTO 100
64748 CALL PYPTDI(KFL3,PX3,PY3)
64749 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
64750 CALL PYZDIS(KFPREV,KFL3,PM,Z)
64757 IF(MSTJ(12).GT.4)THEN
64758 POPMN=SQRT((1D0-X)*(G/X-GB))
64759 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
64760 PTST=EXP((POPM-POPMN)*PARF(193))
64765 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
64768 IF(RTST.GT.PTST*GTST)THEN
64770 IF(RTST.GT.PTST) MSTU(121)=-1
64775 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
64776 IF(MSTU(121).GT.0) GOTO 110
64778 C.. Test accepted system size. If OK set global popcorn size variable.
64779 IF(NMES.GT.NMAX)THEN
64790 C********************************************************************
64793 C...Generates a new flavour pair and combines off a hadron
64795 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
64797 C...Double precision and integer declarations.
64798 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64799 IMPLICIT INTEGER(I-N)
64800 INTEGER PYK,PYCHGE,PYCOMP
64802 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64803 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64804 SAVE /PYDAT1/,/PYDAT2/
64808 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
64810 C...Default flavour values. Input consistency checks.
64815 IF(KF1A.EQ.0) RETURN
64817 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
64818 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
64819 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
64822 C...Check if tabulated flavour probabilities are to be used.
64823 IF(MSTJ(15).EQ.1) THEN
64824 IF(MSTJ(12).GE.5) CALL PYERRM(29,
64825 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
64826 & ' together with MSTJ(12)>=5 modification')
64828 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
64829 KFL1A=MOD(KF1A/1000,10)
64830 KFL1B=MOD(KF1A/100,10)
64832 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
64833 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
64834 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
64835 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
64839 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
64840 KFL2A=MOD(KF2A/1000,10)
64841 KFL2B=MOD(KF2A/100,10)
64843 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
64844 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
64845 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
64847 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
64850 C.. Recognize rank 0 diquark case
64852 KFDIQ=MAX(KF1A,KF2A)
64853 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
64855 C.. Join two flavours to meson or baryon. Test for popcorn.
64858 IF(KFDIQ.GT.10) THEN
64859 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
64860 & CALL PYNMES(KFDIQ)
64861 IF(MSTU(121).NE.0) THEN
64872 C.. Separate incoming flavours, curtain flavour consistency check
64878 KFL1A=MOD(KF1A/1000,10)
64879 KFL1B=MOD(KF1A/100,10)
64882 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
64883 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
64884 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
64886 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
64890 KFQOLD=KFL1A+KFL1B-KFQPOP
64893 C...Meson/baryon choice. Set number of mesons if starting a popcorn
64896 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
64897 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
64901 ELSEIF(KF1A.GT.10)THEN
64903 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
64904 IF(MSTU(121).GT.0) MBARY=-1
64907 C..x->H+q: Choose single vertex quark. Jump to form hadron.
64908 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
64909 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
64910 KFL3=ISIGN(KFQVER,-KFIN)
64914 C..x->H+qq: (IDW=proper PARF position for diquark weights)
64917 IF(MSTU(121).EQ.0) IDW=150
64919 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
64920 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
64921 C.. Shift to s-curtain parameters if needed
64922 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
64923 PARF(194)=PARF(138)*PARF(139)
64924 PARF(193)=PARJ(8)+PARJ(9)
64928 C.. x->H+qq: Get vertex quark
64929 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
64931 MSTU(121)=MSTU(121)-1
64932 IF(IDW.EQ.170) THEN
64933 IF(MSTU(121).EQ.0)THEN
64934 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
64936 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
64939 IF(MSTU(121).EQ.0)THEN
64940 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
64942 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
64948 RMES=PYR(0)*PARF(194)
64950 RMES=RMES-PARF(IPOS+IMES)
64951 IF(IMES.EQ.30) THEN
64956 IF(RMES.GT.0D0) GOTO 120
64959 IF(KMUL.EQ.2) KFJ=10003
64960 IF(KMUL.EQ.3) KFJ=10001
64961 IF(KMUL.EQ.4) KFJ=20003
64962 IF(KMUL.EQ.5) KFJ=5
64964 KFQVER=MOD(IMES,5)+1
64965 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
64966 IF(KFQVER.GT.3)THEN
64971 IF(MBARY.EQ.-1) IDW=170
64973 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
64974 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
64975 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
64976 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
64978 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
64982 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
64984 IF(KFQPOP.NE.KFQVER)THEN
64986 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
64987 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
64988 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
64990 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
64992 KFL3=ISIGN(KFDIQ,KFIN)
64994 C..x->M+y: flavour for meson.
64995 130 IF(MBARY.LE.0)THEN
64996 KFLA=MAX(KFQOLD,KFQVER)
64997 KFLB=MIN(KFQOLD,KFQVER)
64999 IF(KFLA.NE.KFQOLD) KFS=-KFS
65000 C... Form meson, with spin and flavour mixing for diagonal states.
65001 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
65002 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
65003 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
65006 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
65007 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
65008 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
65009 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
65010 IF(PYR(0).LT.PARJ(14)) KMUL=2
65011 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
65013 IF(RMUL.LT.PARJ(15)) KMUL=3
65014 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
65015 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
65018 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
65019 IF(KMUL.EQ.5) KFLS=5
65020 IF(KFLA.NE.KFLB)THEN
65021 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
65024 IMIX=2*KFLA+10*KMUL
65025 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
65026 & INT(RMIX+PARF(IMIX)))+KFLS
65027 IF(KFLA.GE.4) KF=110*KFLA+KFLS
65029 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
65030 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
65032 C..Optional extra suppression of eta and eta'.
65033 C..Allow shift to qq->B+q in old version (set IRANK to 0)
65034 IF(KF.EQ.221.OR.KF.EQ.331)THEN
65035 IF(PYR(0).GT.PARJ(25+KF/300))THEN
65036 IF(KF2A.GT.0) GOTO 130
65037 IF(MSTJ(12).LT.4) IRANK=0
65043 C.. x->B+y: Flavour for baryon
65046 IF(KF1A.LE.10) KFLA=KFQOLD
65047 KFLB=MOD(KFDIQ/1000,10)
65048 KFLC=MOD(KFDIQ/100,10)
65049 KFLDS=MOD(KFDIQ,10)
65050 KFLD=MAX(KFLA,KFLB,KFLC)
65051 KFLF=MIN(KFLA,KFLB,KFLC)
65052 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
65054 C... SU(6) factors for formation of baryon.
65058 IF(KFLB.NE.KFLC)THEN
65061 IF(KFLB.GT.2) KDMAX=KDMAX+2
65063 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
65068 SU6MAX=PARF(140+KDMAX)
65071 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
65076 SU6OCT=PARF(60+KBARY)
65077 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
65078 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
65079 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
65081 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
65083 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
65085 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
65086 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
65088 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
65092 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
65095 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
65096 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
65098 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
65100 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
65101 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
65105 C...Use tabulated probabilities to select new flavour and hadron.
65106 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
65109 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
65112 ELSEIF(KTAB2.EQ.0) THEN
65121 DO 150 KT3=KT3L,KT3U
65122 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
65128 DO 170 KT3=KT3L,KT3U
65130 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
65131 IF(RFL.LE.0D0) GOTO 190
65136 C...Reconstruct flavour of produced quark/diquark.
65137 IF(KTAB3.LE.6) THEN
65140 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
65143 IF(KTAB3.GE.8) KFL3A=2
65144 IF(KTAB3.GE.11) KFL3A=3
65145 IF(KTAB3.GE.16) KFL3A=4
65146 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
65147 KFL3=1000*KFL3A+100*KFL3B+1
65148 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
65150 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
65153 C...Reconstruct meson code.
65154 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
65156 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
65157 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
65159 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
65160 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
65161 & 25*KTABS)) KF=330+2*KTABS+1
65162 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
65163 KFLA=MAX(KTAB1,KTAB3)
65164 KFLB=MIN(KTAB1,KTAB3)
65166 IF(KFLA.NE.KF1A) KFS=-KFS
65167 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
65168 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
65170 IF(KFL1A.EQ.KFL3A) THEN
65171 KFLA=MAX(KFL1B,KFL3B)
65172 KFLB=MIN(KFL1B,KFL3B)
65173 IF(KFLA.NE.KFL1B) KFS=-KFS
65174 ELSEIF(KFL1A.EQ.KFL3B) THEN
65178 ELSEIF(KFL1B.EQ.KFL3A) THEN
65181 ELSEIF(KFL1B.EQ.KFL3B) THEN
65182 KFLA=MAX(KFL1A,KFL3A)
65183 KFLB=MIN(KFL1A,KFL3A)
65184 IF(KFLA.NE.KFL1A) KFS=-KFS
65186 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
65189 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
65191 C...Reconstruct baryon code.
65193 IF(KTAB1.GE.7) THEN
65202 KFLD=MAX(KFLA,KFLB,KFLC)
65203 KFLF=MIN(KFLA,KFLB,KFLC)
65204 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
65205 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
65206 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
65209 C...Check that constructed flavour code is an allowed one.
65210 IF(KFL2.NE.0) KFL3=0
65213 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
65221 C*********************************************************************
65224 C...Generates number of popcorn mesons and stores some relevant
65227 SUBROUTINE PYNMES(KFDIQ)
65229 C...Double precision and integer declarations.
65230 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65231 IMPLICIT INTEGER(I-N)
65232 INTEGER PYK,PYCHGE,PYCOMP
65234 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65235 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65236 SAVE /PYDAT1/,/PYDAT2/
65239 IF(MSTJ(12).LT.2) RETURN
65241 C..Old version: Get 1 or 0 popcorn mesons
65242 IF(MSTJ(12).LT.5)THEN
65244 IF(KFDIQ.NE.0) THEN
65246 KFA=MOD(KFDIQA/1000,10)
65247 KFB=MOD(KFDIQA/100,10)
65250 IF(KFA.EQ.3) POPWT=PARF(133)
65251 IF(KFB.EQ.3) POPWT=PARF(134)
65252 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
65254 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
65258 C..New version: Store popcorn- or rank 0 diquark parameters
65261 PARF(194)=PARF(139)
65262 IF(KFDIQ.NE.0) THEN
65265 PARF(194)=PARF(140)
65267 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
65268 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
65269 & '(PYNMES:) Neglecting too large popcorn possibility')
65273 C..New version: Get number of popcorn mesons
65276 110 MSTU(121)=MSTU(121)+1
65277 RTST=RTST/PARF(194)
65278 IF(RTST.LT.1D0) GOTO 110
65279 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
65280 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
65284 C***************************************************************
65287 C...Precalculates a set of diquark and popcorn weights.
65291 C...Double precision and integer declarations.
65292 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65293 IMPLICIT INTEGER(I-N)
65294 INTEGER PYK,PYCHGE,PYCOMP
65296 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65297 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65298 SAVE /PYDAT1/,/PYDAT2/
65300 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
65304 C..Diquark indices for dimensional variables
65313 C.. *** SU(6) factors **
65314 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
65316 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
65317 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
65318 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
65321 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
65323 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
65324 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
65326 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
65327 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
65330 C..SU(6)max q q' s,c,b
65331 SU6MUD =MAX(SU6(1) , SU6(8) )
65332 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
65333 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
65334 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
65335 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
65336 SU6M(IUS0)=SU6M(ISU0)
65337 SU6M(ISS1)=SU6M(IUU1)
65338 SU6M(IUS1)=SU6M(ISU1)
65340 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
65342 PARF(142)=SU6M(IUD1)
65343 PARF(143)=SU6M(ISU0)
65344 PARF(144)=SU6M(ISU1)
65345 PARF(145)=SU6M(ISS1)
65347 C..diquark SU(6) survival =
65348 C..sum over quark (quark tunnel weight)*(SU(6)).
65349 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
65350 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
65351 DMB(IUS0)=DMB(ISU0)
65352 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
65353 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
65354 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
65355 DMB(IUS1)=DMB(ISU1)
65356 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
65358 C.. *** Tunneling factors for Diquark production***
65359 C.. T: half a curtain pair = sqrt(curtain pair factor)
65360 IF(MSTJ(12).GE.5) THEN
65362 PMUD1=PYMASS(2103)-PMUD0
65363 PMUS0=PYMASS(3201)-PMUD0
65364 PMUS1=PYMASS(3203)-PMUS0-PMUD0
65365 PMSS1=PYMASS(3303)-PMUS0-PMUD0
65366 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
65367 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
65368 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
65369 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
65370 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
65371 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
65372 QBB(IUD1)=QBB(IUU1)
65374 PAR2M=SQRT(PARJ(2))
65375 PAR3M=SQRT(PARJ(3))
65376 PAR4M=SQRT(PARJ(4))
65377 QBB(ISU0)=PAR2M*PAR3M
65379 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
65381 QBB(ISU1)=PAR4M*QBB(ISU0)
65382 QBB(IUS1)=PAR4M*QBB(IUS0)
65386 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
65387 QBM(ISU0)=QBB(ISU0)
65388 QBM(IUS0)=PARJ(2)*QBB(IUS0)
65389 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
65390 QBM(IUU1)=6D0*QBB(IUU1)
65391 QBM(ISU1)=3D0*QBB(ISU1)
65392 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
65393 QBM(IUD1)=3D0*QBB(IUD1)
65395 C.. Combine T and tau to diquark weight for q-> B+B+..
65397 QBB(I)=QBB(I)*QBM(I)
65400 IF(MSTJ(12).GE.5)THEN
65401 C..New version: tau for rank 0 diquark.
65402 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
65403 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
65404 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
65405 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
65406 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
65407 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
65408 DMB(7+IUD1)=DMB(7+IUU1)/2D0
65410 C..New version: curtain flavour ratios.
65411 C.. s/u for q->B+M+...
65412 C.. s/u for rank 0 diquark: su -> ...M+B+...
65413 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
65414 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
65415 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
65416 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
65417 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
65418 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
65419 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
65421 C..Old version: reset unused rank 0 diquark weights and
65422 C.. unused diquark SU(6) survival weights
65424 IF(MSTJ(12).LT.3) DMB(I)=1D0
65428 C..Old version: Shuffle PARJ(7) into tau
65429 QBM(IUS0)=QBM(IUS0)*PARJ(7)
65430 QBM(ISS1)=QBM(ISS1)*PARJ(7)
65431 QBM(IUS1)=QBM(IUS1)*PARJ(7)
65433 C..Old version: curtain flavour ratios.
65434 C.. s/u for q->B+M+...
65435 C.. s/u for rank 0 diquark: su -> ...M+B+...
65436 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
65437 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
65438 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
65439 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
65440 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
65443 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
65444 C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
65446 DMB(7+I)=DMB(7+I)*DMB(I)
65447 DMB(I)=DMB(I)*QBM(I)
65448 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
65449 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
65452 C.. *** Popcorn factors ***
65454 IF(MSTJ(12).LT.5)THEN
65455 C.. Old version: Resulting popcorn weights.
65457 WS=PARF(135)*PARF(138)
65459 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
65461 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
65462 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
65463 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
65464 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
65465 & (1D0+QBB(IUD1)+QBB(IUU1)+
65466 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
65468 C..New version: Store weights for popcorn mesons,
65469 C..get prel. popcorn weights.
65470 DO 150 IPOS=201,1400
65479 IF(MR.EQ.7) PARF(193)=PARJ(10)
65480 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
65481 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
65482 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
65484 IF(NMES.EQ.1) SQWT=PARJ(2)
65486 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
65487 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
65488 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
65490 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
65491 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
65494 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
65496 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
65497 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
65503 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
65504 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
65505 IF(PJWT.LE.0D0) GOTO 190
65506 IF(PJWT.GT.1D0) PJWT=1D0
65508 IMIX=2*KFQOLD+10*KMUL
65510 IF(KMUL.EQ.2) KFJ=10003
65511 IF(KMUL.EQ.3) KFJ=10001
65512 IF(KMUL.EQ.4) KFJ=20003
65513 IF(KMUL.EQ.5) KFJ=5
65515 KFLA=MAX(KFQOLD,KFQVER)
65516 KFLB=MIN(KFQOLD,KFQVER)
65517 SWT=PARJ(11+KFLA/3+KFLA/4)
65518 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
65520 QWT=SQWT/(2D0+SQWT)
65521 IF(KFQVER.LT.3)THEN
65522 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
65523 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
65525 IF(KFQVER.NE.KFQOLD)THEN
65527 KFM=100*KFLA+10*KFLB+KFJ
65528 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
65529 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
65530 WTTOT=WTTOT+PARF(IPOS+IMES)
65533 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
65534 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
65535 IF(ID.EQ.5) DWT=PARF(IMIX)
65537 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
65538 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
65539 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
65540 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
65541 PARF(IPOS+5*KMUL+ID)=
65542 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
65544 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
65550 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
65552 IF(MR.EQ.7) PARF(140)=
65553 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
65554 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
65555 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
65561 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
65566 C..Recombine diquark weights to flavour and spin ratios
65567 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
65568 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
65569 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
65570 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
65571 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
65572 PARF(155)=QBB(ISU1)/QBB(ISU0)
65573 PARF(156)=QBB(IUS1)/QBB(IUS0)
65574 PARF(157)=QBB(IUD1)
65576 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
65577 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
65578 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
65579 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
65580 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
65581 PARF(165)=QBM(ISU1)/QBM(ISU0)
65582 PARF(166)=QBM(IUS1)/QBM(IUS0)
65583 PARF(167)=QBM(IUD1)
65585 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
65586 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
65587 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
65588 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
65589 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
65590 PARF(175)=DMB(ISU1)/DMB(ISU0)
65591 PARF(176)=DMB(IUS1)/DMB(IUS0)
65592 PARF(177)=DMB(IUD1)
65594 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
65595 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
65596 PARF(187)=DMB(7+IUD1)
65602 C*********************************************************************
65605 C...Generates transverse momentum according to a Gaussian.
65607 SUBROUTINE PYPTDI(KFL,PX,PY)
65609 C...Double precision and integer declarations.
65610 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65611 IMPLICIT INTEGER(I-N)
65612 INTEGER PYK,PYCHGE,PYCOMP
65614 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65617 C...Generate p_T and azimuthal angle, gives p_x and p_y.
65619 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
65620 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
65621 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
65622 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
65630 C*********************************************************************
65633 C...Generates the longitudinal splitting variable z.
65635 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
65637 C...Double precision and integer declarations.
65638 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65639 IMPLICIT INTEGER(I-N)
65640 INTEGER PYK,PYCHGE,PYCOMP
65642 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65643 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65644 SAVE /PYDAT1/,/PYDAT2/
65646 C...Check if heavy flavour fragmentation.
65650 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
65652 C...Lund symmetric scaling function: determine parameters of shape.
65653 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
65654 &MSTJ(11).GE.4) THEN
65656 IF(MSTJ(91).EQ.1) FA=PARJ(43)
65657 IF(KFLB.GE.10) FA=FA+PARJ(45)
65659 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
65662 IF(KFLA.GE.10) FC=FC-PARJ(45)
65663 IF(KFLB.GE.10) FC=FC+PARJ(45)
65664 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
65666 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
65667 FC=FC+FRED*FBB*PARF(100+KFLH)**2
65670 IF(ABS(FC-1D0).GT.0.01D0) MC=2
65672 C...Determine position of maximum. Special cases for a = 0 or a = c.
65673 IF(FA.LT.0.02D0) THEN
65676 IF(FC.GT.FB) ZMAX=FB/FC
65677 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
65682 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
65683 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
65686 C...Subdivide z range if distribution very peaked near endpoint.
65688 IF(ZMAX.LT.0.1D0) THEN
65694 ZDIVC=ZDIV**(1D0-FC)
65695 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
65697 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
65699 FSCB=SQRT(4D0+(FC/FB)**2)
65700 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
65701 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
65702 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
65703 FINT=1D0+FB*(1D0-ZDIV)
65706 C...Choice of z, preweighted for peaks at low or high z.
65710 IF(FINT*PYR(0).LE.1D0) THEN
65712 ELSEIF(MC.EQ.1) THEN
65716 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
65719 ELSEIF(MMAX.EQ.3) THEN
65720 IF(FINT*PYR(0).LE.1D0) THEN
65722 FPRE=EXP(FB*(Z-ZDIV))
65724 Z=ZDIV+Z*(1D0-ZDIV)
65728 C...Weighting according to correct formula.
65729 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
65730 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
65731 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
65732 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
65733 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
65735 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
65737 FC=PARJ(50+MAX(1,KFLH))
65738 IF(MSTJ(91).EQ.1) FC=PARJ(59)
65740 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
65741 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
65742 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
65743 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
65746 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
65747 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
65754 C*********************************************************************
65757 C...Generates timelike parton showers from given partons.
65759 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
65761 C...Double precision and integer declarations.
65762 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65763 IMPLICIT INTEGER(I-N)
65764 INTEGER PYK,PYCHGE,PYCOMP
65765 C...Parameter statement to help give large particle numbers.
65766 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
65767 &KEXCIT=4000000,KDIMEN=5000000)
65768 PARAMETER (MAXNUR=1000)
65770 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
65771 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65772 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65774 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
65775 COMMON/PYINT1/MINT(400),VINT(400)
65776 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
65778 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
65779 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
65780 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
65781 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
65784 C...Check that QMAX not too low.
65785 IF(MSTJ(41).LE.0) THEN
65787 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
65788 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
65790 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
65794 C...Store positions of shower initiating partons.
65796 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
65799 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
65804 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
65805 & .AND.IP2.GE.-80) THEN
65810 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
65818 & '(PYSHOW:) failed to reconstruct showering system')
65819 IF(MSTU(21).GE.1) RETURN
65822 C...Send off to PYPTFS for pT-ordered evolution if requested,
65823 C...if at least 2 partons, and without predefined shower branchings.
65824 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
65829 PTPART(II)=0.5D0*QMAX
65831 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
65835 C...Initialization of cutoff masses etc.
65843 PMTH(1,21)=PYMASS(21)
65844 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
65845 PMTH(3,21)=2D0*PMTH(2,21)
65846 PMTH(4,21)=PMTH(3,21)
65847 PMTH(5,21)=PMTH(3,21)
65848 PMTH(1,22)=PYMASS(22)
65849 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
65850 PMTH(3,22)=2D0*PMTH(2,22)
65851 PMTH(4,22)=PMTH(3,22)
65852 PMTH(5,22)=PMTH(3,22)
65854 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
65855 PMQT1E=MIN(PMQTH1,PARJ(90))
65857 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
65858 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
65861 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
65863 PMTH(1,IFL)=PYMASS(IFL)
65864 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
65865 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
65866 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
65867 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
65870 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
65871 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
65872 PMTH(1,IFL)=PYMASS(IFL)
65873 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
65874 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
65875 PMTH(4,IFL)=PMTH(3,IFL)
65876 PMTH(5,IFL)=PMTH(3,IFL)
65878 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
65880 ALFM=LOG(PT2MIN/ALAMS)
65882 C...Check on phase space available for emission.
65890 KFLA(I)=IABS(K(IPA(I),2))
65892 C...Special cutoff masses for initial partons (may be a heavy quark,
65893 C...squark, ..., and need not be on the mass shell).
65895 IF(NPA.LE.1) IREF(I)=IR
65896 IF(NPA.GE.2) IREF(I+1)=IR
65900 IF(KFLA(I).LE.8) THEN
65902 IF(MSTJ(41).GE.2) ISCHG(IR)=1
65903 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
65904 & KFLA(I).EQ.17) THEN
65905 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
65906 ELSEIF(KFLA(I).EQ.21) THEN
65908 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
65909 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
65911 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
65914 C...same for QQ~[3S18]
65915 ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
65916 & KFLA(I).EQ.9900553)) THEN
65920 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
65922 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
65923 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
65924 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
65925 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
65926 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
65927 ELSEIF(ISCOL(IR).EQ.1) THEN
65928 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
65929 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
65930 PMTH(4,IR)=PMTH(3,IR)
65931 PMTH(5,IR)=PMTH(3,IR)
65932 ELSEIF(ISCHG(IR).EQ.1) THEN
65933 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
65934 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
65935 PMTH(4,IR)=PMTH(3,IR)
65936 PMTH(5,IR)=PMTH(3,IR)
65938 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
65940 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
65942 PS(J)=PS(J)+P(IPA(I),J)
65945 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
65946 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
65947 IF(NPA.EQ.1) PS(5)=PS(4)
65948 IF(PS(5).LE.PM+PMQT1E) RETURN
65950 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
65953 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
65954 KFSRCE=IABS(K(K(IP1,3),2))
65956 IPAR1=MAX(1,K(IP1,3))
65957 IPAR2=MAX(1,K(IP2,3))
65958 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
65959 & KFSRCE=IABS(K(K(IPAR1,3),2))
65962 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
65963 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
65964 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
65965 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
65966 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
65967 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
65968 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
65969 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
65971 C...Identify two primary showerers.
65973 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
65974 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
65975 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
65976 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
65977 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
65978 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
65979 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
65980 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
65982 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
65983 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
65984 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
65985 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
65986 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
65987 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
65988 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
65989 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
65991 C...Order of showerers. Presence of gluino.
65992 ITYPMN=MIN(ITYPE1,ITYPE2)
65993 ITYPMX=MAX(ITYPE1,ITYPE2)
65995 IF(ITYPE1.GT.ITYPE2) IORD=2
65997 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
65999 C...Check if 3-jet matrix elements to be used.
66002 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
66003 IF(MSTJ(38).NE.0) THEN
66007 ELSEIF(MSTJ(47).GE.6) THEN
66013 C...Vector/axial vector -> q + qbar; q -> q + V.
66014 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
66015 & ITYPES.EQ.3)) THEN
66017 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
66019 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
66020 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
66021 C...gamma*/Z0: assume e+e- initial state if unknown.
66023 IF(KFSRCE.EQ.23) THEN
66024 IANNFL=K(K(IP1,3),3)
66025 IF(IANNFL.NE.0) THEN
66026 KANNFL=IABS(K(IANNFL,2))
66027 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
66030 AI=SIGN(1D0,EI+0.1D0)
66031 VI=AI-4D0*EI*PARU(102)
66032 EF=KCHG(KFLA(1),1)/3D0
66033 AF=SIGN(1D0,EF+0.1D0)
66034 VF=AF-4D0*EF*PARU(102)
66035 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
66038 SQWZ=PS(5)*PMAS(23,2)
66039 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
66040 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
66041 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
66042 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
66044 ALPHA=VECT/(VECT+AXIV)
66045 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
66048 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
66049 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
66051 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
66052 & ITYPES.EQ.1)) THEN
66055 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
66056 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
66058 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
66060 ELSEIF(KFSRCE.EQ.36) THEN
66063 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
66064 & ITYPES.EQ.1)) THEN
66067 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
66068 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
66069 & ITYPES.EQ.3)) THEN
66071 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
66072 & ITYPES.EQ.2)) THEN
66074 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
66076 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
66077 & ITYPES.EQ.2)) THEN
66080 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
66081 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
66082 & ITYPES.EQ.5)) THEN
66084 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
66085 & ITYPES.EQ.2)) THEN
66087 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
66088 & ITYPES.EQ.1)) THEN
66091 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
66092 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
66094 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
66095 & ITYPES.EQ.2)) THEN
66097 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
66098 & ITYPES.EQ.1)) THEN
66101 C...g -> ~g + ~g (eikonal approximation).
66102 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
66105 M3JC=5*ICLASS+ICOMBI
66109 C...Find if interference with initial state partons.
66111 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
66112 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
66113 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
66118 KCA=PYCOMP(KFLA(I))
66119 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
66121 IF(KCII(I).NE.0) THEN
66123 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
66124 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
66125 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
66127 IIIS(I,NIIS(I))=ICSI
66132 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
66135 C...Boost interfering initial partons to rest frame
66136 C...and reconstruct their polar and azimuthal angles.
66140 K(N+I,J)=K(IPA(I),J)
66141 P(N+I,J)=P(IPA(I),J)
66145 DO 230 I=3,2+NIIS(1)
66147 K(N+I,J)=K(IIIS(1,I-2),J)
66148 P(N+I,J)=P(IIIS(1,I-2),J)
66152 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
66154 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
66155 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
66159 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
66160 & -PS(2)/PS(4),-PS(3)/PS(4))
66161 PHI=PYANGL(P(N+1,1),P(N+1,2))
66162 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
66163 THE=PYANGL(P(N+1,3),P(N+1,1))
66164 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
66165 DO 260 I=3,2+NIIS(1)
66166 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
66167 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
66169 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
66170 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
66171 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
66172 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
66176 C...Boost 3 or more partons to their rest frame.
66177 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
66178 &-PS(2)/PS(4),-PS(3)/PS(4))
66180 C...Define imagined single initiator of shower for parton system.
66182 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
66183 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
66184 IF(MSTU(21).GE.1) RETURN
66203 C...Loop over partons that may branch.
66206 IF(NPA.EQ.1) IM=NS-1
66209 IF(IM.GT.N) GOTO 600
66212 IF(KSH(IR).EQ.0) GOTO 290
66213 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
66218 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
66219 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
66220 IF(MSTU(21).GE.1) RETURN
66223 C...Position of aunt (sister to branching parton).
66224 C...Origin and flavour of daughters.
66227 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
66228 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
66240 K(N+I,2)=K(IPA(I),2)
66242 ELSEIF(KFLM.NE.21) THEN
66245 IREF(N+1-NS)=IREF(IM-NS)
66246 IREF(N+2-NS)=IABS(K(N+2,2))
66247 ELSEIF(K(IM,5).EQ.21) THEN
66255 IREF(N+1-NS)=IABS(K(N+1,2))
66256 IREF(N+2-NS)=IABS(K(N+2,2))
66259 C...Reset flags on daughters and tries made.
66264 KFLD(IP)=IABS(K(N+IP,2))
66265 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
66269 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
66273 C...Maximum virtuality of daughters.
66276 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
66277 P(N+I,5)=MIN(QMAX,PS(5))
66279 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
66280 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
66283 IF(MSTJ(43).LE.2) PEM=V(IM,2)
66284 IF(MSTJ(43).GE.3) PEM=P(IM,4)
66285 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
66286 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
66287 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
66291 IF(ISI(I).EQ.1) THEN
66293 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
66295 V(N+I,5)=P(N+I,5)**2
66298 C...Choose one of the daughters for evolution.
66300 IF(NEP.EQ.1) INUM=1
66302 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
66305 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
66307 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
66313 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
66314 RPM=P(N+I,5)/PMSD(I)
66316 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
66324 C...Cancel choice of predetermined daughter already treated.
66327 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
66328 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
66329 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
66330 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
66331 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
66334 C...Store information on choice of evolving daughter.
66338 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
66341 KFL(I)=IABS(K(IEP(I),2))
66343 ITRY(INUM)=ITRY(INUM)+1
66344 IF(ITRY(INUM).GT.200) THEN
66345 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
66346 IF(MSTU(21).GE.1) RETURN
66350 IF(KSH(IR).EQ.0) GOTO 450
66351 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
66353 C...Check if evolution already predetermined for daughter.
66355 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
66356 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
66357 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
66358 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
66359 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
66361 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
66363 IF(IPSPD.NE.0) ISSET(INUM)=1
66366 C...Select side for interference with initial state partons.
66367 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
66370 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
66372 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
66373 IF(PYR(0).GT.0.5D0) ISII(III)=1
66374 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
66376 IF(PYR(0).GT.0.5D0) ISII(III)=2
66380 C...Calculate allowed z range.
66383 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
66386 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
66387 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
66389 IF(MOD(MSTJ(43),2).EQ.1) THEN
66391 ZCE=PMTH(2,22)/PMED
66392 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
66394 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
66395 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
66397 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
66398 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
66399 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
66402 ZCE=MIN(ZCE,0.49991D0)
66403 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
66404 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
66405 P(IEP(1),5)=PMTH(1,IR)
66406 V(IEP(1),5)=P(IEP(1),5)**2
66410 C...Integral of Altarelli-Parisi z kernel for QCD.
66411 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
66412 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
66413 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
66415 C...Evolution of QQ~[3S18] state if MSTP(148)=1.
66416 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
66417 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
66418 FBR=6D0*LOG((1D0-ZC)/ZC)
66420 ELSEIF(MSTJ(49).EQ.0) THEN
66421 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
66422 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
66424 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
66425 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
66426 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
66427 ELSEIF(MSTJ(49).EQ.1) THEN
66428 FBR=(1D0-2D0*ZC)/3D0
66429 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
66431 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
66432 ELSEIF(KFL(1).EQ.21) THEN
66433 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
66435 FBR=2D0*LOG((1D0-ZC)/ZC)
66438 C...Reset QCD probability for colourless.
66439 IF(ISCOL(IR).EQ.0) FBR=0D0
66441 C...Integral of Altarelli-Parisi kernel for photon emission.
66443 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
66444 IF(KFL(1).LE.18) THEN
66445 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
66447 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
66450 C...Inner veto algorithm starts. Find maximum mass for evolution.
66451 410 PMS=V(IEP(1),5)
66456 IRI=IREF(IEP(I)-NS)
66457 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
66460 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
66463 C...Select mass for daughter in QCD evolution.
66465 DO 430 IFF=4,MSTJ(45)
66466 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
66468 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
66469 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
66470 C...Already predetermined choice.
66471 IF(IPSPD.NE.0) THEN
66472 PMSQCD=P(IPSPD,5)**2
66473 ELSEIF(FBR.LT.1D-3) THEN
66475 ELSEIF(MSTJ(44).LE.0) THEN
66476 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
66477 ELSEIF(MSTJ(44).EQ.1) THEN
66478 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
66480 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
66482 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
66483 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
66484 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
66488 C...Select mass for daughter in QED evolution.
66489 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
66490 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
66491 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
66492 IF(FBRE.LT.1D-3) THEN
66495 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
66496 & (PARU(101)*FBRE)))
66498 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
66499 PMSQED=PMSQED+PMTH(1,IR)**2
66500 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
66502 IF(PMSQED.GT.PMSQCD) THEN
66508 C...Check whether daughter mass below cutoff.
66509 P(IEP(1),5)=SQRT(V(IEP(1),5))
66510 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
66511 P(IEP(1),5)=PMTH(1,IR)
66512 V(IEP(1),5)=P(IEP(1),5)**2
66516 C...Already predetermined choice of z, and flavour in g -> qqbar.
66517 IF(IPSPD.NE.0) THEN
66520 PMSGD1=P(IPSGD1,5)**2
66521 PMSGD2=P(IPSGD2,5)**2
66522 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
66523 & 4D0*PMSGD1*PMSGD2))
66524 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
66525 & PMSGD1+PMSGD2)/ALAMPS
66526 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
66527 IF(KFL(1).NE.21) THEN
66530 K(IEP(1),5)=IABS(K(IPSGD1,2))
66533 C...Select z value of branching: q -> qgamma.
66534 ELSEIF(MCE.EQ.2) THEN
66535 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
66536 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
66540 C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
66541 ELSEIF(MSTJ(49).EQ.0.AND.
66542 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
66543 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
66544 C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
66545 IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
66546 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
66550 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
66551 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
66552 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
66553 C...Only do z weighting when no ME correction afterwards.
66554 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
66556 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
66557 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
66558 IF(PYR(0).GT.0.5D0) Z=1D0-Z
66559 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
66561 ELSEIF(MSTJ(49).NE.1) THEN
66563 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
66564 KFLB=1+INT(MSTJ(45)*PYR(0))
66565 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
66566 IF(PMQ.GE.1D0) GOTO 410
66567 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
66568 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
66569 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
66570 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
66571 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
66573 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
66577 C...Ditto for scalar gluon model.
66578 ELSEIF(KFL(1).NE.21) THEN
66579 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
66581 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
66582 Z=ZC+(1D0-2D0*ZC)*PYR(0)
66585 Z=ZC+(1D0-2D0*ZC)*PYR(0)
66586 KFLB=1+INT(MSTJ(45)*PYR(0))
66587 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
66588 IF(PMQ.GE.1D0) GOTO 410
66592 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
66593 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
66594 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
66595 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66596 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
66598 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
66599 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
66600 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
66601 IF(PT2APP.LT.PT2MIN) GOTO 410
66602 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
66606 C...Check if z consistent with chosen m.
66607 IF(KFL(1).EQ.21) THEN
66608 IRGD1=IABS(K(IEP(1),5))
66612 IRGD2=IABS(K(IEP(1),5))
66616 ELSEIF(NEP.GE.3) THEN
66618 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
66619 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
66621 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
66622 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
66624 IF(MOD(MSTJ(43),2).EQ.1) THEN
66625 PMQTH3=0.5D0*PARJ(82)
66626 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
66627 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
66628 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
66629 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
66630 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
66634 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
66637 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
66638 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66639 ELSEIF(IPSPD.NE.0) THEN
66643 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
66645 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
66647 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
66649 C...Width suppression for q -> q + g.
66650 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
66652 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
66656 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
66657 IF(MSTJ(40).EQ.1) THEN
66658 IF(CHI.LT.PYR(0)) GOTO 410
66659 ELSEIF(MSTJ(40).EQ.2) THEN
66660 IF(1D0-CHI.LT.PYR(0)) GOTO 410
66664 C...Three-jet matrix element correction.
66669 C...QED matrix elements: only for massless case so far.
66670 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
66671 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
66672 X2=1D0-V(IEP(1),5)/V(NS+1,5)
66673 X3=(1D0-X1)+(1D0-X2)
66675 KI2=K(IPA(3-INUM),2)
66676 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
66677 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
66678 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
66679 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
66680 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
66681 ELSEIF(MCE.EQ.2) THEN
66683 C...QCD matrix elements, including mass effects.
66684 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
66688 IF(IR.GE.31.AND.IGM.EQ.0) THEN
66689 C...QCD ME: original parton, first branching.
66690 PM2ME=PMTH(1,63-IR)
66692 ELSEIF(IR.GE.31) THEN
66693 C...QCD ME: original parton, subsequent branchings.
66694 PM2ME=PMTH(1,63-IR)
66695 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
66696 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
66697 ELSEIF(K(IM,2).EQ.21) THEN
66698 C...QCD ME: secondary partons, first branching.
66701 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
66702 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
66703 & 4D0*PS1ME*PM2ME**2))
66704 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
66706 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
66709 C...QCD ME: secondary partons, subsequent branchings.
66711 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
66712 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
66715 C...Construct ME variables.
66718 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
66719 X2=1D0+R2ME**2-PS1ME/ECMME**2
66720 C...Call ME, with right order important for two inequivalent showerers.
66721 IF(IR.EQ.IORD+30) THEN
66722 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
66724 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
66726 C...Split up total ME when two radiating partons.
66728 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
66729 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
66730 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
66731 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
66732 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
66733 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
66734 & MAX(1D-10,2D0-X1-X2)
66735 C...Evaluate shower rate to be compared with.
66736 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
66737 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
66738 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
66739 ELSEIF(MSTJ(49).NE.1) THEN
66741 C...Toy model scalar theory matrix elements; no mass effects.
66743 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
66744 X2=1D0-V(IEP(1),5)/V(NS+1,5)
66745 X3=(1D0-X1)+(1D0-X2)
66746 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
66748 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
66752 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
66755 C...Impose angular ordering by rejection of nonordered emission.
66756 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
66757 PEMAO=V(IM,1)*P(IM,4)
66758 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
66759 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
66761 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
66762 & .OR.MSTJ(42).EQ.7)) THEN
66764 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
66765 & .OR.MSTJ(42).EQ.6)) THEN
66767 PMDAO=PMTH(2,K(IEP(1),5))
66768 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
66771 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
66772 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
66773 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
66777 440 IF(K(IAOM,5).EQ.22) THEN
66779 IF(K(IAOM,3).LE.NS) MAOM=0
66780 IF(MAOM.EQ.1) GOTO 440
66782 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
66783 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
66784 IF(THE2ID.LT.THE2IM) GOTO 410
66788 C...Impose user-defined maximum angle at first branching.
66789 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
66790 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
66791 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
66792 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
66793 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
66794 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
66795 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
66796 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
66797 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
66798 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
66802 C...Impose angular constraint in first branching from interference
66803 C...with initial state partons.
66804 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
66805 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
66806 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
66807 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
66808 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
66809 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
66813 C...End of inner veto algorithm. Check if only one leg evolved so far.
66817 IF(NEP.EQ.1) GOTO 490
66818 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
66821 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
66822 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
66826 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
66830 PMSUM=PMSUM+P(N+I,5)
66832 IF(PMSUM.GE.PS(5)) GOTO 350
66833 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
66836 IF(KSH(IRDA).EQ.0) GOTO 480
66837 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
66838 IF(IRDA.EQ.21) THEN
66839 IRGD1=IABS(K(I1,5))
66843 IRGD2=IABS(K(I1,5))
66846 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
66847 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
66849 IF(I1.EQ.N+1) ZM=V(IM,1)
66850 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
66851 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
66852 & 4D0*V(N+1,5)*V(N+2,5))
66853 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
66856 IF(MOD(MSTJ(43),2).EQ.1) THEN
66857 PMQTH3=0.5D0*PARJ(82)
66858 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
66859 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
66860 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
66861 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
66862 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
66866 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
66869 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
66870 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66874 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
66875 & ISSET(1).EQ.0) THEN
66877 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
66878 & ISSET(2).EQ.0) THEN
66882 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
66884 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
66886 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
66889 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
66890 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
66891 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
66892 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
66893 IF(ISL(1).EQ.1) ISL(2)=0
66894 IF(ISL(1).EQ.0) ISLM=1
66895 IF(ISL(2).EQ.0) ISLM=2
66897 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
66902 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
66903 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
66904 PMQ1=V(N+1,5)/V(IM,5)
66905 PMQ2=V(N+2,5)/V(IM,5)
66906 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
66911 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
66915 C...Accepted branch. Construct four-momentum for initial partons.
66921 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
66923 P(N+1,4)=P(IPA(1),4)
66925 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
66926 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
66929 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
66934 P(N+2,4)=P(IM,5)-PED1
66937 ELSEIF(NEP.GE.3) THEN
66938 C...Rescale all momenta for energy conservation.
66944 P(N+I,J)=P(IPA(I),J)
66947 PQS=PQS+P(N+I,5)**2/P(N+I,4)
66950 FAC=(PS(5)-PQS)/(PES-PQS)
66955 P(N+I,J)=FAC*P(N+I,J)
66957 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)
66960 PQS=PQS+P(N+I,5)**2/P(N+I,4)
66962 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
66964 C...Construct transverse momentum for ordinary branching in shower.
66968 550 LOOPPT=LOOPPT+1
66969 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
66970 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
66971 IF(PZM.LE.0D0) THEN
66973 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
66974 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66975 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
66976 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
66977 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
66978 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
66980 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
66982 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
66985 ELSEIF(PTS.LT.0D0) THEN
66988 PT=SQRT(MAX(0D0,PTS))
66990 C...Global statistics.
66991 MINT(353)=MINT(353)+1
66992 VINT(353)=VINT(353)+PT
66993 IF (MINT(353).EQ.1) VINT(358)=PT
66995 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
66997 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
66998 & .AND.IAU.NE.0) THEN
66999 IF(K(IGM,3).NE.0) MAZIP=1
67001 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
67002 IF(MAZIP.EQ.0) ZAU=0D0
67003 IF(K(IGM,2).NE.21) THEN
67004 HAZIP=2D0*ZAU/(1D0+ZAU**2)
67006 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
67008 IF(K(N+1,2).NE.21) THEN
67009 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
67011 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
67015 C...Find coefficient of azimuthal asymmetry due to soft gluon
67018 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
67019 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
67020 IF(K(IGM,3).NE.0) MAZIC=N+1
67021 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
67022 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
67023 & ZM.GT.0.5D0) MAZIC=N+2
67024 IF(K(IAU,2).EQ.22) MAZIC=0
67026 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
67028 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
67029 IF(MAZIC.EQ.0) ZGM=1D0
67030 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
67031 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
67032 HAZIC=MIN(0.95D0,HAZIC)
67036 C...Construct energies for ordinary branching in shower.
67037 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
67038 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
67039 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
67040 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
67041 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
67042 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
67043 P(N+1,4)=PEM*V(IM,1)
67045 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
67046 & SQRT(PMLS)*ZM)/V(IM,5)
67049 C...Already predetermined choice of phi angle or not
67051 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
67053 IF(K(IPSPD,4).GT.0) THEN
67055 IF(IM.EQ.NS+2) THEN
67056 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
67058 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
67061 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
67063 IF(K(IPSPD,4).GT.0) THEN
67065 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
67066 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
67067 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
67068 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
67069 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
67070 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
67074 C...Construct momenta for ordinary branching in shower.
67075 P(N+1,1)=PT*COS(PHI)
67076 P(N+1,2)=PT*SIN(PHI)
67077 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
67078 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
67079 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
67080 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
67081 ELSEIF(PZM.GT.0D0) THEN
67082 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
67083 & 2D0*PEM*P(N+1,4))/PZM
67089 P(N+2,3)=PZM-P(N+1,3)
67090 P(N+2,4)=PEM-P(N+1,4)
67091 IF(MSTJ(43).LE.2) THEN
67092 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
67093 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
67097 C...Rotate and boost daughters.
67099 IF(MSTJ(43).LE.2) THEN
67100 BEX=P(IGM,1)/P(IGM,4)
67101 BEY=P(IGM,2)/P(IGM,4)
67102 BEZ=P(IGM,3)/P(IGM,4)
67103 GA=P(IGM,4)/P(IGM,5)
67104 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
67113 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
67114 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
67115 IF(PTIMB.GT.1D-4) THEN
67116 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
67121 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
67122 & SIN(THE)*COS(PHI)*P(I,3)
67123 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
67124 & SIN(THE)*SIN(PHI)*P(I,3)
67125 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
67127 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
67128 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
67129 P(I,1)=DP(1)+DGABP*BEX
67130 P(I,2)=DP(2)+DGABP*BEY
67131 P(I,3)=DP(3)+DGABP*BEZ
67132 P(I,4)=GA*(DP(4)+DBP)
67136 C...Weight with azimuthal distribution, if required.
67137 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
67143 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
67144 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
67145 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
67147 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
67148 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
67150 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
67151 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
67152 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
67153 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
67154 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
67155 IF(MAZIP.NE.0) THEN
67156 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
67159 IF(MAZIC.NE.0) THEN
67160 IF(MAZIC.EQ.N+2) CAD=-CAD
67161 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
67162 & .LT.PYR(0)) GOTO 560
67167 C...Azimuthal anisotropy due to interference with initial state partons.
67168 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
67169 &K(N+2,2).EQ.21)) THEN
67171 IF(ISII(III).GE.1) THEN
67173 IF(K(N+1,2).NE.21) IAZIID=N+2
67174 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
67175 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
67176 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
67177 IF(III.EQ.2) THEIID=PARU(1)-THEIID
67178 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
67179 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
67180 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
67181 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
67182 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
67183 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
67184 & .LT.PYR(0)) GOTO 560
67188 C...Continue loop over partons that may branch, until none left.
67189 IF(IGM.GE.0) K(IM,1)=14
67192 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
67193 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
67194 IF(MSTU(21).GE.1) N=NS
67195 IF(MSTU(21).GE.1) RETURN
67199 C...Set information on imagined shower initiator.
67200 600 IF(NPA.GE.2) THEN
67204 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
67212 C...Reconstruct string drawing information.
67213 DO 610 I=NS+1+IIM,N
67214 KQ=KCHG(PYCOMP(K(I,2)),2)
67215 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
67217 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
67218 & IABS(K(I,2)).LE.18) THEN
67220 ELSEIF(K(I,1).LE.10) THEN
67221 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
67222 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
67223 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
67224 ID1=MOD(K(I,4),MSTU(5))
67225 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
67226 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
67227 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
67228 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
67229 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
67230 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
67231 K(ID1,4)=K(ID1,4)+MSTU(5)*I
67232 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
67233 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
67234 K(ID2,5)=K(ID2,5)+MSTU(5)*I
67236 ID1=MOD(K(I,4),MSTU(5))
67238 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
67239 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
67240 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
67241 K(ID1,4)=K(ID1,4)+MSTU(5)*I
67242 K(ID1,5)=K(ID1,5)+MSTU(5)*I
67252 C...Transformation from CM frame.
67254 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
67255 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
67257 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
67258 ELSEIF(NPA.EQ.2) THEN
67263 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
67264 & /(1D0+GA)-P(IPA(1),4))
67265 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
67266 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
67267 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
67269 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
67271 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
67274 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
67277 C...Decay vertex of shower.
67284 C...Delete trivial shower, else connect initiators.
67285 IF(N.LE.NS+NPA+IIM) THEN
67290 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
67291 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
67292 K(NS+IIM+IP,3)=IPA(IP)
67293 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
67294 IF(K(NS+IIM+IP,1).NE.1) THEN
67295 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
67296 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
67304 C*********************************************************************
67307 C...Generates pT-ordered timelike final-state parton showers.
67309 C...MODE defines how to find radiators and recoilers.
67310 C... = 0 : based on colour flow between undecayed partons.
67311 C... = 1 : for IPART <= NPARTD only consider primary partons,
67312 C... whether decayed or not; else as above.
67313 C... = 2 : based on common history, whether decayed or not.
67315 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
67317 C...Double precision and integer declarations.
67318 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67319 IMPLICIT INTEGER(I-N)
67320 INTEGER PYK,PYCHGE,PYCOMP
67321 C...Parameter statement to help give large particle numbers.
67322 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
67323 &KEXCIT=4000000,KDIMEN=5000000)
67324 C...Parameter statement for maximum size of showers.
67325 PARAMETER (MAXNUR=1000)
67327 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
67328 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
67329 COMMON/PYCTAG/NCT,MCT(4000,2)
67330 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67331 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67332 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
67333 COMMON/PYINT1/MINT(400),VINT(400)
67334 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
67337 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
67338 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
67339 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
67340 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
67341 C...Statement functions.
67342 SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
67343 &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
67345 C...Initial values. Check that valid system.
67347 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
67348 &MSTJ(41).NE.12) RETURN
67349 IF(NPART.LE.0) THEN
67350 CALL PYERRM(2,'(PYPTFS:) showering system too small')
67355 C...Mass thresholds and Lambda for QCD evolution.
67359 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
67360 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
67367 C...Cutoff scale for QCD evolution. Starting pT2.
67368 NFLAV=MAX(0,MIN(5,MSTJ(45)))
67369 PT0C=0.5D0*PARJ(82)
67370 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
67372 C...Parameters for QED evolution.
67373 AEM2PI=PARU(101)/PARU(2)
67374 PT0EQ=0.5D0*PARJ(83)
67375 PT0EL=0.5D0*PARJ(90)
67377 C...Reset. Remove irrelevant colour tags.
67382 DO 110 I=MINT(84)+1,N
67383 IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
67387 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
67394 C...Begin loop to set up showering partons. Sum four-momenta.
67397 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
67398 IF(K(I,1).GT.10) GOTO 210
67399 ELSEIF(K(I,3).GT.MINT(84)) THEN
67400 IF(K(I,3).GT.MINT(84)+2) GOTO 210
67402 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 210
67405 PSUM(J)=PSUM(J)+P(I,J)
67408 C...Find colour and charge, but skip diquarks.
67409 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 210
67410 KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
67411 KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
67413 C...Either colour or anticolour charge radiates; for gluon both.
67414 DO 160 JSGCOL=1,-1,-2
67415 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
67416 JCOL=4+(1-JSGCOL)/2
67419 C...Basic info about radiating parton.
67423 ISCOL(NEVOL)=JSGCOL
67425 PTSCA(NEVOL)=PTPART(IP)
67427 C...Begin search for colour recoiler when MODE = 0 or 1.
67429 C...Find sister with matching anticolour to the radiating parton.
67431 IRNEW=K(IROLD,JCOL)/MSTU(5)
67434 C...The following will add MCT colour tracing for unprepped events
67435 C...If not done, trace Les Houches colour tags for this dipole
67436 C IF (MCT(I,JCOL-3).EQ.0) THEN
67437 C CALL PYCTTR(I,JCOL,INEW)
67438 C...Clean up mother/daughter 'read' tags set by PYCTTR
67440 C K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
67441 C K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
67445 C...Skip radiation off loose colour ends.
67446 130 IF(IRNEW.EQ.0) THEN
67450 C...Optionally skip radiation on dipole to beam remnant.
67451 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
67455 C...For now always skip radiation on dipole to junction.
67456 ELSEIF(K(IRNEW,2).EQ.88) THEN
67460 C...For MODE=1: if reached primary then done.
67461 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
67462 & IRNEW.LE.NPARTD) THEN
67464 C...If sister stable and points back then done.
67465 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
67467 IF(K(IRNEW,1).LT.10) THEN
67469 C...If sister unstable then go to her daughter.
67472 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
67477 C...If found mother then look for aunt.
67478 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
67481 IRNEW=K(IROLD,JCOL)/MSTU(5)
67484 C...If daughter stable then done.
67485 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
67487 IF(K(IRNEW,1).LT.10) THEN
67489 C...If daughter unstable then go to granddaughter.
67492 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
67497 C...If daughter points to another daughter then done or move up.
67498 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
67500 IF(K(IRNEW,1).LT.10) THEN
67503 IRNEW=K(IRNEW,JCOL)/MSTU(5)
67509 C...Begin search for colour recoiler when MODE = 2.
67512 IRNEW=K(IROLD,JCOL)/MSTU(5)
67513 140 IF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
67514 C...Step up to mother if radiating parton already branched.
67515 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
67517 IRNEW=K(IROLD,JCOL)/MSTU(5)
67519 C...Pick sister by history if no anticolour available.
67521 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
67523 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
67526 C...Last resort: pick at random among other primaries.
67528 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
67529 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
67533 C...Trace down if sister branched.
67534 150 IF(K(IRNEW,1).GT.10) THEN
67535 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
67540 C...Now found other end of colour dipole.
67545 C...Also electrical charge may radiate; so far only quarks and leptons.
67546 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
67547 & IABS(K(I,2)).LE.18) THEN
67549 C...Basic info about radiating parton.
67555 PTSCA(NEVOL)=PTPART(IP)
67557 C...Pick nearest (= smallest invariant mass) charged particle
67558 C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
67562 DO 170 IP2=1,NPART+N-MINT(53)
67563 IF(IP2.EQ.IP) GOTO 170
67564 IF(IP2.LE.NPART) THEN
67566 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
67567 IF(K(I2,1).GT.10) GOTO 170
67568 ELSEIF(K(I2,3).GT.MINT(84)) THEN
67569 IF(K(I2,3).GT.MINT(84)+2) GOTO 170
67571 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 170
67574 I2=MINT(53)+IP2-NPART
67576 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 170
67577 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
67578 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
67579 IF(PM2INV.LT.PM2MIN) THEN
67584 IF(IRNEW.EQ.0) THEN
67589 C...Begin search for charge recoiler when MODE = 2.
67592 C...Pick sister by history; step up if parton already branched.
67593 180 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
67597 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
67599 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
67601 C...Last resort: pick at random among other primaries.
67603 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
67604 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
67606 C...Trace down if sister branched.
67607 190 IF(K(IRNEW,1).GT.10) THEN
67608 DO 200 IR=IRNEW+1,N
67609 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
67619 C...End loop to set up showering partons. System invariant mass.
67621 IF(NEVOL.LE.0) RETURN
67622 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
67624 C...Check if 3-jet matrix elements to be used.
67628 IF(MSTJ(47).GE.1) THEN
67630 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
67632 IPART1=K(IPART(1),3)
67633 IPART2=K(IPART(2),3)
67634 220 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
67635 KFSRCE=IABS(K(IPART1,2))
67636 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
67639 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
67644 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
67645 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
67646 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
67647 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
67648 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
67649 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
67650 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
67651 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
67653 C...Identify two primary showerers.
67654 KFLA1=IABS(K(IPART(1),2))
67656 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
67657 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
67658 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
67659 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
67660 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
67661 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
67662 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
67663 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
67664 KFLA2=IABS(K(IPART(2),2))
67666 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
67667 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
67668 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
67669 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
67670 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
67671 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
67672 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
67673 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
67675 C...Order of showerers. Presence of gluino.
67676 ITYPMN=MIN(ITYPE1,ITYPE2)
67677 ITYPMX=MAX(ITYPE1,ITYPE2)
67679 IF(ITYPE1.GT.ITYPE2) IORD=2
67681 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
67683 C...Require exactly two primary showerers for ME corrections.
67685 IF(IPART1.GT.0) THEN
67687 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
67690 IF(NPRIM.NE.2) THEN
67692 C...Predetermined and default matrix element kinds.
67693 ELSEIF(MSTJ(38).NE.0) THEN
67697 ELSEIF(MSTJ(47).GE.6) THEN
67703 C...Vector/axial vector -> q + qbar; q -> q + V.
67704 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
67705 & ITYPES.EQ.3)) THEN
67707 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
67709 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
67710 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
67711 C...gamma*/Z0: assume e+e- initial state if unknown.
67713 IF(KFSRCE.EQ.23) THEN
67715 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
67716 IF(IANNFL.GT.0) THEN
67717 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
67719 IF(IANNFL.NE.0) THEN
67720 KANNFL=IABS(K(IANNFL,2))
67721 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
67724 AI=SIGN(1D0,EI+0.1D0)
67725 VI=AI-4D0*EI*PARU(102)
67726 EF=KCHG(KFLA1,1)/3D0
67727 AF=SIGN(1D0,EF+0.1D0)
67728 VF=AF-4D0*EF*PARU(102)
67729 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
67732 SQWZ=PSUM(5)*PMAS(23,2)
67733 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
67734 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
67735 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
67736 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
67738 ALPHA=VECT/(VECT+AXIV)
67739 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
67742 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
67743 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
67745 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
67746 & ITYPES.EQ.1)) THEN
67749 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
67750 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
67752 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
67754 ELSEIF(KFSRCE.EQ.36) THEN
67757 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
67758 & ITYPES.EQ.1)) THEN
67761 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
67762 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
67763 & ITYPES.EQ.3)) THEN
67765 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
67766 & ITYPES.EQ.2)) THEN
67768 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
67770 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
67771 & ITYPES.EQ.2)) THEN
67774 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
67775 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
67776 & ITYPES.EQ.5)) THEN
67778 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
67779 & ITYPES.EQ.2)) THEN
67781 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
67782 & ITYPES.EQ.1)) THEN
67785 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
67786 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
67788 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
67789 & ITYPES.EQ.2)) THEN
67791 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
67792 & ITYPES.EQ.1)) THEN
67795 C...g -> ~g + ~g (eikonal approximation).
67796 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
67799 M3JC=5*ICLASS+ICOMBI
67802 C...Store pair that together define matrix element treatment.
67805 MESYS(NMESYS,0)=M3JC
67806 MESYS(NMESYS,1)=IPART(1)
67807 MESYS(NMESYS,2)=IPART(2)
67810 C...Store qqbar or l+l- pairs for QED radiation.
67811 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
67813 MESYS(NMESYS,0)=101
67814 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
67815 MESYS(NMESYS,1)=IPART(1)
67816 MESYS(NMESYS,2)=IPART(2)
67819 C...Store other qqbar/l+l- pairs from g/gamma branchings.
67821 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 270
67823 240 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
67827 C...Move up this check to avoid out-of-bounds.
67828 IF(I1M.EQ.0) GOTO 270
67829 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 270
67831 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 260
67833 250 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
67837 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
67843 MESYS(NMESYS,0)=102
67851 C..Loopback point for counting number of emissions.
67855 C...Begin loop to evolve all existing partons, if required.
67858 DO 360 IEVOL=1,NEVOL
67859 IF(IFLG(IEVOL).EQ.0) THEN
67861 C...Basic info on radiator and recoil.
67868 C...Invariant mass of "dipole".Starting value for pT evolution.
67869 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
67870 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
67872 C...Case of evolution by QCD branching.
67873 IF(ISCOL(IEVOL).NE.0) THEN
67875 C...Parton-by-parton maximum scale from initial conditions.
67876 IF(MSTP(72).EQ.0) THEN
67877 DO 300 IPRT=1,NPARTS
67878 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
67882 C...If kinematically impossible then do not evolve.
67883 IF(PT2.LT.PT2CMN) THEN
67888 C...Check if part of system for which ME corrections should be applied.
67890 DO 310 IME=1,NMESYS
67891 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
67892 & MESYS(IME,0).LT.100) IMESYS=IME
67895 C...Special flag for colour octet states.
67897 IF(K(I,2).EQ.21) MOCT=1
67898 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
67900 C...Upper estimate for matrix element weighting and colour factor.
67901 C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
67904 IF(MOCT.GE.1) COLFAC=3D0/2D0
67905 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
67906 WTPSQQ=0.5D0*0.5D0*NFLAV
67908 C...Determine overestimated z range: switch at c and b masses.
67913 IF(PT2.GT.1.01D0*PMCS) THEN
67919 IF(PT2.GT.1.01D0*PMBS) THEN
67925 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
67926 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
67928 C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
67929 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
67932 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
67933 EVCOEF=EVCOEF+EVEMQQ
67936 C...Pick pT2 (in overestimated z range).
67937 330 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
67939 C...Loopback if crossed c/b mass thresholds.
67940 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
67944 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
67949 C...Finish if below lower cutoff.
67950 IF(PT2.LT.PT2CMN) THEN
67955 C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
67957 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
67959 C...Pick z: dz/(1-z) or dz.
67960 IF(IFLAG.EQ.1) THEN
67961 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
67963 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
67966 C...Loopback if outside allowed range for given pT2.
67967 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
67968 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
67969 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 330
67970 PM2=PM2I+PT2/(Z*(1D0-Z))
67971 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 330
67973 C...No weighting for primary partons; to be done later on.
67974 IF(IMESYS.GT.0) THEN
67976 C...Weighting of q->qg/X->Xg branching.
67977 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
67978 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 330
67980 C...Weighting of g->gg branching.
67981 ELSEIF(IFLAG.EQ.1) THEN
67982 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 330
67984 C...Flavour choice and weighting of g->qqbar branching.
67986 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
67988 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
67989 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
67990 IF(WTME.LT.PYR(0)) GOTO 330
67994 C...Case of evolution by QED branching.
67995 ELSEIF(ISCHG(IEVOL).NE.0) THEN
67997 C...If kinematically impossible then do not evolve.
67999 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
68000 IF(PT2.LT.PT2EMN) THEN
68005 C...Check if part of system for which ME corrections should be applied.
68007 DO 340 IME=1,NMESYS
68008 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
68009 & MESYS(IME,0).GT.100) IMESYS=IME
68012 C...Charge. Matrix element weighting factor.
68013 CHG=ISCHG(IEVOL)/3D0
68016 C...Determine overestimated z range. Find evolution coefficient.
68017 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
68018 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
68019 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
68021 C...Pick pT2 (in overestimated z range).
68022 350 PT2=PT2*PYR(0)**(1D0/EVCOEF)
68024 C...Finish if below lower cutoff.
68025 IF(PT2.LT.PT2EMN) THEN
68030 C...Pick z: dz/(1-z).
68031 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
68033 C...Loopback if outside allowed range for given pT2.
68034 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
68035 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
68036 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
68037 PM2=PM2I+PT2/(Z*(1D0-Z))
68038 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
68040 C...Weighting by branching kernel, except if ME weighting later.
68041 IF(IMESYS.EQ.0) THEN
68042 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 350
68047 C...Save acceptable branching.
68049 IMESAV(IEVOL)=IMESYS
68055 C...Check if branching has highest pT.
68056 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
68058 PT2MX=PT2SAV(IEVOL)
68062 C...Finished if no more branchings to be done.
68063 IF(IMX.EQ.0) GOTO 480
68065 C...Restore info on hardest branching to be processed.
68076 PM2=PM2I+PT2/(Z*(1D0-Z))
68078 C...Special flag for colour octet states.
68080 IF(K(I,2).EQ.21) MOCT=1
68081 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
68083 C...Restore further info for g->qqbar branching.
68085 IF(IFLG(IMX).GT.10) THEN
68088 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
68091 C...For branching g include azimuthal asymmetries from polarization.
68093 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
68094 C...Trace grandmother via intermediate recoil copies.
68097 370 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
68098 & K(IM,3).GT.0) THEN
68100 IF(IM.GT.MINT(84)) GOTO 370
68103 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
68104 & KFGM=IABS(K(IGM,2))
68105 C...Define approximate energy sharing by identifying aunt.
68107 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
68108 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
68109 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
68110 C...Coefficient from gluon production.
68112 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
68114 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
68116 C...Coefficient from gluon decay.
68118 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
68120 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
68125 C...Create new slots for branching products and recoil.
68131 C...Set status, flavour and mother of new ones.
68134 IF(KCHA.NE.0) K(IGNEW,1)=1
68139 IF(KCHA.NE.0) K(IGNEW,2)=22
68141 K(INEW,2)=-ISIGN(KFQ,KCOL)
68142 K(IGNEW,2)=-K(INEW,2)
68149 C...Find rest frame and angles of branching+recoil.
68155 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
68156 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
68157 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
68158 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
68159 PHI=PYANGL(P(INEW,1),P(INEW,2))
68160 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
68162 C...Derive kinematics of branching: generics (like g->gg).
68167 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
68168 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
68169 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
68170 PTCOR=SQRT(MAX(0D0,PT2COR))
68171 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
68172 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
68173 C...Specific kinematics reduction for q->qg with m_q > 0.
68175 PTCOR=(1D0-PM2I/PM2)*PTCOR
68176 PZN=PZN+PM2I*PZG/PM2
68177 PZG=(1D0-PM2I/PM2)*PZG
68178 C...Specific kinematics reduction for g->qqbar with m_q > 0.
68179 ELSEIF(KFQ.NE.0) THEN
68183 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
68187 C...Pick phi and construct kinematics of branching.
68188 400 PHIROT=PARU(2)*PYR(0)
68189 P(INEW,1)=PTCOR*COS(PHIROT)
68190 P(INEW,2)=PTCOR*SIN(PHIROT)
68192 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
68193 P(IGNEW,1)=-P(INEW,1)
68194 P(IGNEW,2)=-P(INEW,2)
68196 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
68200 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
68202 C...Boost branching system to lab frame.
68203 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
68205 C...Renew choice of phi angle according to polarization asymmetry.
68206 IF(ABS(ASYPOL).GT.1D-3) THEN
68212 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
68213 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
68214 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
68216 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
68217 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
68219 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
68220 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
68221 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
68222 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
68223 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
68224 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
68229 C...Matrix element corrections for primary partons when requested.
68230 IF(IMESYS.GT.0) THEN
68231 M3JC=MESYS(IMESYS,0)
68233 C...Identify recoiling partner and set up three-body kinematics.
68234 IRP=MESYS(IMESYS,1)
68235 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
68236 IF(IRP.EQ.IR) IRP=IRNEW
68238 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
68240 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
68242 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
68243 & PSUM(3)*P(INEW,3))/PSUM(5)**2
68244 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
68245 & PSUM(3)*P(IRP,3))/PSUM(5)**2
68247 R1ME=P(INEW,5)/PSUM(5)
68248 R2ME=P(IRP,5)/PSUM(5)
68250 C...Matrix elements for gluon emission.
68251 IF(M3JC.LT.100) THEN
68253 C...Call ME, with right order important for two inequivalent showerers.
68254 IF(MESYS(IMESYS,IORD).EQ.I) THEN
68255 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
68257 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
68260 C...Split up total ME when two radiating partons.
68262 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
68263 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
68264 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
68265 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
68266 & MAX(1D-10,2D0-X1-X2)
68268 C...Evaluate shower rate.
68269 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
68270 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
68271 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
68273 C...Matrix elements for photon emission: still rather primitive.
68276 C...For generic charge combination currently only massless expression.
68277 IF(M3JC.EQ.101) THEN
68278 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
68279 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
68280 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
68281 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
68283 C...For flavour neutral system assume vector source and include masses.
68285 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
68286 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
68287 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
68288 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
68292 C...Perform weighting with W_ME/W_PS.
68293 IF(WME.LT.PYR(0)*WPS) THEN
68301 C...Now for sure accepted branching. Save highest pT.
68302 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
68304 C...Update status for obsolete ones. Bookkkep the moved original parton
68305 C...and new daughter (arbitrary choice for g->gg or g->qqbar).
68306 C...Do not bookkeep radiated photon, since it cannot radiate further.
68310 IF(IPART(IP).EQ.I) IPART(IP)=INEW
68311 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
68318 C...Initialize colour flow of branching.
68319 C...Use both old and new style colour tags for flexibility.
68333 C...Trivial colour flow for l->lgamma and q->qgamma.
68334 IF(IABS(KCHA).EQ.3) THEN
68337 ELSEIF(KCHA.NE.0) THEN
68338 IF(K(I,4).NE.0) THEN
68340 K(INEW,4)=MSTU(5)*I
68341 MCT(INEW,1)=MCT(I,1)
68343 IF(K(I,5).NE.0) THEN
68345 K(INEW,5)=MSTU(5)*I
68346 MCT(INEW,2)=MCT(I,2)
68349 C...Set colour flow for q->qg and g->gg.
68350 ELSEIF(KFQ.EQ.0) THEN
68351 K(I,JCOLP)=K(I,JCOLP)+IGNEW
68352 K(IGNEW,JCOLP)=MSTU(5)*I
68353 K(INEW,JCOLP)=MSTU(5)*IGNEW
68354 K(IGNEW,JCOLN)=MSTU(5)*INEW
68355 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
68357 MCT(INEW,JCOLP-3)=NCT
68358 MCT(IGNEW,JCOLN-3)=NCT
68360 K(I,JCOLN)=K(I,JCOLN)+INEW
68361 K(INEW,JCOLN)=MSTU(5)*I
68362 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
68365 C...Set colour flow for g->qqbar.
68367 K(I,JCOLN)=K(I,JCOLN)+INEW
68368 K(INEW,JCOLN)=MSTU(5)*I
68369 K(I,JCOLP)=K(I,JCOLP)+IGNEW
68370 K(IGNEW,JCOLP)=MSTU(5)*I
68371 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
68372 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
68375 C...Daughter info for colourless recoiling parton.
68376 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
68382 C...Colour of recoiling parton sails through unchanged.
68384 IF(K(IR,4).NE.0) THEN
68385 K(IR,4)=K(IR,4)+IRNEW
68386 K(IRNEW,4)=MSTU(5)*IR
68387 MCT(IRNEW,1)=MCT(IR,1)
68389 IF(K(IR,5).NE.0) THEN
68390 K(IR,5)=K(IR,5)+IRNEW
68391 K(IRNEW,5)=MSTU(5)*IR
68392 MCT(IRNEW,2)=MCT(IR,2)
68396 C...Vertex information trivial.
68403 C...Update list of old radiators.
68404 DO 460 IEVOL=1,NEVOL
68405 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
68407 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
68410 ELSEIF(IPOS(IEVOL).EQ.I) THEN
68413 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
68416 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
68418 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
68422 C...Update links of old connected partons.
68423 IF(IREC(IEVOL).EQ.I) THEN
68426 ELSEIF(IREC(IEVOL).EQ.IR) THEN
68432 C...q->qg or g->gg: create new gluon radiators.
68433 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
68440 PTSCA(NEVOL)=SQRT(PT2)
68447 PTSCA(NEVOL)=PTSCA(NEVOL-1)
68450 C...Update matrix elements parton list and add new for g/gamma->qqbar.
68451 DO 470 IME=1,NMESYS
68452 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
68453 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
68454 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
68455 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
68460 MESYS(NMESYS,1)=INEW
68461 MESYS(NMESYS,2)=IGNEW
68463 MESYS(NMESYS,0)=102
68464 MESYS(NMESYS,1)=INEW
68465 MESYS(NMESYS,2)=IGNEW
68468 C...Global statistics.
68469 MINT(353)=MINT(353)+1
68470 VINT(353)=VINT(353)+PTCOR
68471 IF (MINT(353).EQ.1) VINT(358)=PTCOR
68473 C...Loopback for more emissions if enough space.
68475 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
68476 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
68479 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
68488 C*********************************************************************
68491 C...Auxiliary to PYSHOW and PYPTFS.
68492 C...Matrix elements for gluon (or photon) emission from
68493 C...a two-body state; to be used by the parton shower routine.
68494 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
68495 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
68496 C... = (alpha-strong/2 pi) * CF * PYMAEL,
68497 C...i.e. normalization is such that one recovers the familiar
68498 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
68499 C...Coupling structure:
68500 C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
68501 C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
68502 C... = 16-19 : q -> q V
68503 C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
68504 C... = 26-29 : q -> q S
68505 C... = 31-34 : V -> ~q ~qbar (~q = squark)
68506 C... = 36-39 : ~q -> ~q V
68507 C... = 41-44 : S -> ~q ~qbar
68508 C... = 46-49 : ~q -> ~q S
68509 C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
68510 C... = 56-59 : ~q -> q chi
68511 C... = 61-64 : q -> ~q chi
68512 C... = 66-69 : ~g -> q ~qbar
68513 C... = 71-74 : ~q -> q ~g
68514 C... = 76-79 : q -> ~q ~g
68515 C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
68516 C...Note that the order of the decay products is important.
68517 C...In each set of four, the variants are ordered as:
68518 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
68519 C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
68520 C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
68521 C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
68523 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
68525 C...Double precision and integer declarations.
68526 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68527 IMPLICIT INTEGER(I-N)
68529 C...Check input values. Return zero outside allowed phase space.
68531 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
68532 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
68533 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
68534 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
68535 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
68536 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
68538 C...Initial values and flags.
68546 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
68548 C...Eikonal expression; also acts as default.
68549 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
68551 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
68553 ELSEIF(ICOMBI.EQ.2) THEN
68554 ANUM=(2D0-X1-X2)**2
68555 ELSEIF(ICOMBI.EQ.3) THEN
68556 ANUM=ALPCOR*(2D0-X1-X2)**2
68558 ANUM=0.5D0*(2D0-X1-X2)**2
68560 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
68561 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
68562 & R1**2/(1D0+R2**2-R1**2-X2)**2-
68563 & R2**2/(1D0+R1**2-R2**2-X1)**2)
68566 C...V -> q qbar (V = gamma*/Z0/W+-/...).
68567 ELSEIF(ICLASS.EQ.2) THEN
68568 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68569 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
68570 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
68571 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
68572 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
68573 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
68574 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
68575 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
68576 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
68577 & (-1+R1**2-R2**2+X2)**2
68578 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
68579 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
68580 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
68581 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
68582 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
68583 & -X1-X2)**2+X1*(2-X1-X2)**2)/
68584 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68585 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
68586 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
68587 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
68588 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
68589 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
68593 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68594 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
68595 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
68596 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
68597 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
68598 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
68599 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
68600 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
68601 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
68602 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
68603 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
68604 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
68605 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
68606 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
68607 & -X1-X2)**2+X1*(2-X1-X2)**2)/
68608 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68609 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
68610 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
68611 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
68612 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
68613 & +X2)/(-1-R1**2+R2**2+X1)**2
68617 IF(ICOMBI.EQ.4) THEN
68618 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
68619 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
68620 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
68621 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
68622 & (-1-R1**2+R2**2+X1)**2
68624 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
68625 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
68626 & -R1**2*X2**2+X1*X2**2)/
68627 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68628 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
68629 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
68630 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
68631 & (-1+R1**2-R2**2+X2)**2
68637 ELSEIF(ICLASS.EQ.3) THEN
68638 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68639 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
68640 & +R1**2*R2**2-2D0*R2**4)
68641 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
68642 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
68643 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
68644 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
68645 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
68646 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
68647 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
68648 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
68649 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
68650 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
68651 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
68652 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
68653 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
68654 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
68655 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
68656 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
68657 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
68658 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
68659 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
68662 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68663 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
68664 & +R1**2*R2**2-2D0*R2**4)
68665 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
68666 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
68667 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
68668 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
68669 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
68670 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
68671 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68672 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
68673 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
68674 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
68675 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
68676 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
68677 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
68678 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
68679 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
68680 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
68681 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
68682 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
68683 & +X1*X2**2)/(-2+X1+X2)**2
68686 IF(ICOMBI.EQ.4) THEN
68687 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
68688 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
68689 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
68690 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
68691 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
68692 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68693 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
68694 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
68695 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
68696 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
68697 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
68698 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
68699 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
68700 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
68701 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
68702 & +X1*X2**2)/(2-X1-X2)**2
68706 C...S -> q qbar (S = h0/H0/A0/H+-/...).
68707 ELSEIF(ICLASS.EQ.4) THEN
68708 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68709 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
68710 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68711 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68712 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
68713 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
68714 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
68715 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68716 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68717 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
68718 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68721 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68722 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
68723 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68724 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68725 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
68726 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68727 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
68728 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68729 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
68730 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
68731 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
68732 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68735 IF(ICOMBI.EQ.4) THEN
68736 RLO4=PS*(1D0-R1**2-R2**2)
68737 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
68738 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
68739 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
68740 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
68741 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68742 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
68743 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68748 ELSEIF(ICLASS.EQ.5) THEN
68749 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68750 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
68751 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
68752 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
68753 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
68754 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68755 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
68756 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
68757 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68758 & (-1+R1**2-R2**2+X2)**2
68761 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68762 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
68763 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
68764 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
68765 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
68766 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68767 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
68768 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
68769 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68770 & (-1+R1**2-R2**2+X2)**2
68773 IF(ICOMBI.EQ.4) THEN
68774 RLO4=PS*(1D0+R1**2-R2**2)
68775 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
68776 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
68777 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
68778 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
68779 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
68780 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
68784 C...V -> ~q ~qbar (~q = squark).
68785 ELSEIF(ICLASS.EQ.6) THEN
68786 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
68787 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
68788 & (-1-R1**2+R2**2+X1)**2
68789 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
68790 & (-1-R1**2+R2**2+X1)
68791 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
68792 & /(-1+R1**2-R2**2+X2)**2
68793 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
68794 & (-1+R1**2-R2**2+X2)
68795 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
68796 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
68797 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
68798 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68802 ELSEIF(ICLASS.EQ.7) THEN
68803 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
68804 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
68805 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
68806 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
68807 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
68808 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
68809 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
68810 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
68811 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
68812 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
68813 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
68819 ELSEIF(ICLASS.EQ.8) THEN
68821 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
68822 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
68823 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
68824 & -R1**2*X2**2+X1*X2**2)/
68825 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
68830 ELSEIF(ICLASS.EQ.9) THEN
68832 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
68833 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68834 & -(X1+X2)/(-2+X1+X2)**2
68837 C...chi -> q ~qbar (chi = neutralino/chargino).
68838 ELSEIF(ICLASS.EQ.10) THEN
68839 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68840 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
68841 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
68842 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
68843 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
68844 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68845 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
68846 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68847 & (-1+R1**2-R2**2+X2)**2
68850 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68851 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
68852 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
68853 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
68854 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
68855 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68856 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
68857 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68858 & (-1+R1**2-R2**2+X2)**2
68861 IF(ICOMBI.EQ.4) THEN
68862 RLO4=PS*(1+R1**2-R2**2)
68863 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
68864 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
68865 & +X2+R1**2*X2-X1*X2/2)/
68866 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68867 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
68868 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
68873 ELSEIF(ICLASS.EQ.11) THEN
68874 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68875 RLO1=PS*(1D0-(R1+R2)**2)
68876 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
68877 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68878 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
68879 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68880 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
68881 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
68882 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68885 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68886 RLO2=PS*(1D0-(R1-R2)**2)
68887 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
68889 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68890 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
68891 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68892 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
68893 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
68894 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68897 IF(ICOMBI.EQ.4) THEN
68898 RLO4=PS*(1D0-R1**2-R2**2)
68899 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
68900 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
68901 & +3*R1**2*X2-R2**2*X2-X1*X2)/
68902 & (-1+R1**2-R2**2+X2)**2
68903 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
68904 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
68905 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68910 ELSEIF(ICLASS.EQ.12) THEN
68911 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68912 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
68913 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
68914 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
68915 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
68916 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
68917 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
68918 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68921 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68922 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
68923 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
68924 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
68925 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
68926 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
68927 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
68928 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68931 IF(ICOMBI.EQ.4) THEN
68932 RLO4=PS*(1D0-R1**2+R2**2)
68933 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
68934 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
68935 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
68936 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
68937 & +R1**2*X2-X1*X2/2-X2**2/2)/
68938 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68943 ELSEIF(ICLASS.EQ.13) THEN
68944 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68945 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
68946 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
68947 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
68948 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
68949 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
68950 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
68951 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
68952 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
68953 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
68954 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
68955 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
68956 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
68957 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68958 & (3*(-1+R1**2-R2**2+X2)**2)
68962 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68963 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
68964 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
68965 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
68966 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
68967 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
68968 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
68969 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
68970 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
68971 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
68972 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
68973 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68974 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
68975 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
68976 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68977 & (3*(-1+R1**2-R2**2+X2)**2)
68981 IF(ICOMBI.EQ.4) THEN
68982 RLO4=PS*(1D0+R1**2-R2**2)
68983 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
68984 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
68985 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
68986 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
68987 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
68988 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68989 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
68990 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68991 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
68992 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68993 & (3*(-1+R1**2-R2**2+X2)**2)
68999 ELSEIF(ICLASS.EQ.14) THEN
69000 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
69001 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
69002 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
69003 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
69004 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
69005 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
69006 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
69007 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
69008 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
69009 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
69010 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
69011 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
69012 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
69013 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
69014 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
69016 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
69017 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
69018 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69022 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
69023 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
69024 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
69025 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
69026 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
69027 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
69028 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
69029 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
69030 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
69031 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
69032 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
69033 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
69035 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
69036 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
69037 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
69038 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
69039 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
69040 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69044 IF(ICOMBI.EQ.4) THEN
69045 RLO4=PS*(1-R1**2-R2**2)
69046 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
69047 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
69048 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
69049 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
69050 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
69051 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
69052 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
69053 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
69054 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
69055 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
69056 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
69057 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
69058 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
69059 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
69060 RFO4=9D0*RFO4/128D0
69065 ELSEIF(ICLASS.EQ.15) THEN
69066 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
69067 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
69068 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
69069 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
69070 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
69071 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
69072 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
69073 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
69074 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
69075 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
69076 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
69077 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
69078 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
69079 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
69080 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
69081 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69085 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
69086 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
69087 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
69088 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
69089 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
69090 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
69091 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
69092 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
69093 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
69094 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
69095 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
69096 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
69097 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
69098 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
69099 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
69100 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69104 IF(ICOMBI.EQ.4) THEN
69105 RLO4=PS*(1D0-R1**2+R2**2)
69106 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
69107 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
69108 & -R2**2*X2/2-X1*X2/2)/
69109 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
69110 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
69111 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
69112 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
69113 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
69114 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
69115 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
69116 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
69117 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69122 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
69123 ELSEIF(ICLASS.EQ.16) THEN
69125 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
69127 ELSEIF(ICOMBI.EQ.2) THEN
69128 ANUM=(2D0-X1-X2)**2
69129 ELSEIF(ICOMBI.EQ.3) THEN
69130 ANUM=ALPCOR*(2D0-X1-X2)**2
69132 ANUM=0.5D0*(2D0-X1-X2)**2
69134 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
69135 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
69136 & R1**2/(1D0+R2**2-R1**2-X2)**2-
69137 & R2**2/(1D0+R1**2-R2**2-X1)**2)
69142 C...Find relevant LO and FO expression.
69143 IF(ICOMBI.EQ.0) THEN
69144 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
69147 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
69150 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
69151 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
69152 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
69153 ELSEIF(ISSET4.EQ.1) THEN
69156 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
69157 RLO=0.5D0*(RLO1+RLO2)
69158 RFO=0.5D0*(RFO1+RFO2)
69159 ELSEIF(ISSET1.EQ.1) THEN
69163 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
69174 C*********************************************************************
69177 C...Modifies an event so as to approximately take into account
69178 C...Bose-Einstein effects according to a simple phenomenological
69179 C...parametrization.
69181 SUBROUTINE PYBOEI(NSAV)
69183 C...Double precision and integer declarations.
69184 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69185 IMPLICIT INTEGER(I-N)
69186 INTEGER PYK,PYCHGE,PYCOMP
69187 C...Parameter statement to help give large particle numbers.
69188 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69189 &KEXCIT=4000000,KDIMEN=5000000)
69191 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69192 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69193 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69194 COMMON/PYINT1/MINT(400),VINT(400)
69195 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
69196 C...Local arrays and data.
69197 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
69198 &BEIW(100),BEI3W(100)
69199 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
69200 C...Statement function: squared invariant mass.
69201 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
69202 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
69204 C...Boost event to overall CM frame. Calculate CM energy.
69205 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
69211 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
69212 & .AND.K(I,3).GT.0) THEN
69213 KFMA=IABS(K(K(I,3),2))
69214 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
69216 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
69218 DPS(J)=DPS(J)+P(I,J)
69221 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
69225 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
69228 C...Check if we have separated strings
69230 C...Reserve copy of particles by species at end of record.
69236 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
69237 NBE(IBE)=NBE(IBE-1)
69239 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
69240 DO 140 IIBE=1,IBE-1
69241 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
69244 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
69246 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
69247 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
69248 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
69251 NBE(IBE)=NBE(IBE)+1
69258 P(NBE(IBE),1)=0.0D0
69259 P(NBE(IBE),2)=0.0D0
69260 P(NBE(IBE),3)=0.0D0
69261 P(NBE(IBE),4)=0.0D0
69262 P(NBE(IBE),5)=0.0D0
69263 SMMIN=MIN(SMMIN,P(I,5))
69264 C...Check if particles comes from different W's or Z's
69265 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
69267 150 IF(K(IM,3).GT.0) THEN
69269 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
69271 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
69272 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
69273 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
69274 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
69277 C...Check if particles comes from different strings.
69278 IF(PARJ(94).GT.0.0D0) THEN
69280 160 IF(K(IM,3).GT.0) THEN
69282 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
69290 P(NBE(IBE),5)=-1.0D0
69293 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
69295 C...Calculate separation between W+ and W- or between two Z0's.
69296 C...No separation if there has been re-connections.
69298 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
69299 IF(K(IWP,2).EQ.23) THEN
69308 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
69309 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
69310 TAUP=-TAUPD*LOG(PYR(IDUM))
69311 TAUN=-TAUND*LOG(PYR(IDUM))
69312 DXP=TAUP*PYP(IWP,8)/DMP
69313 DXN=TAUN*PYP(IWN,8)/DMN
69315 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
69316 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
69319 C...Add separation between strings.
69320 IF(PARJ(94).GT.0.0D0) THEN
69321 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
69326 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
69327 DO 220 IBE=1,MIN(9,MSTJ(52))
69328 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
69331 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
69332 IF(I2M.EQ.I1M) GOTO 200
69334 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
69335 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
69336 & (P(I1,5)+P(I2,5))**2
69337 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
69346 C...Tabulate integral for subsequent momentum shift.
69347 DO 400 IBE=1,MIN(9,MSTJ(52))
69348 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
69349 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
69351 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
69352 & NBE(7)-NBE(6)).LE.1) GOTO 270
69353 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
69354 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
69355 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
69356 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
69357 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
69358 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
69359 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
69360 QDELW=0.1D0*MIN(PMHQ,SIGW)
69361 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
69362 IF(MSTJ(51).EQ.1) THEN
69363 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
69364 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
69365 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
69366 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
69367 BEEX=EXP(0.5D0*QDEL/PARJ(93))
69368 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
69369 BEEXW=EXP(0.5D0*QDELW/SIGW)
69370 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
69371 BERT=EXP(-QDEL/PARJ(93))
69372 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
69373 BERTW=EXP(-QDELW/SIGW)
69374 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
69376 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
69377 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
69378 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
69379 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
69382 QBIN=QDEL*(IBIN-0.5D0)
69383 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
69384 IF(MSTJ(51).EQ.1) THEN
69386 BEI(IBIN)=BEI(IBIN)*BEEX
69388 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
69390 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
69392 DO 240 IBIN=1,NBIN3
69393 QBIN=QDEL3*(IBIN-0.5D0)
69394 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
69395 IF(MSTJ(51).EQ.1) THEN
69397 BEI3(IBIN)=BEI3(IBIN)*BEEX3
69399 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
69401 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
69403 DO 250 IBIN=1,NBINW
69404 QBIN=QDELW*(IBIN-0.5D0)
69405 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
69406 IF(MSTJ(51).EQ.1) THEN
69408 BEIW(IBIN)=BEIW(IBIN)*BEEXW
69410 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
69412 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
69414 DO 260 IBIN=1,NBIN3W
69415 QBIN=QDEL3W*(IBIN-0.5D0)
69416 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
69417 & SQRT(QBIN**2+PMHQ**2)
69418 IF(MSTJ(51).EQ.1) THEN
69419 BEEX3W=BEEX3W*BERT3W
69420 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
69422 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
69424 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
69427 C...Loop through particle pairs and find old relative momentum.
69428 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
69430 DO 380 I2M=I1M+1,NBE(IBE)
69431 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
69432 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
69434 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
69435 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
69436 IF(Q2OLD.LE.0.0D0) GOTO 380
69439 C...Calculate new relative momentum.
69444 IF(QOLD.LT.1D-3*QDEL) THEN
69446 ELSEIF(QOLD.LE.QDEL) THEN
69448 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
69451 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
69452 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
69453 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
69455 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69457 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
69458 IF(QOLD.LT.1D-3*QDEL3) THEN
69460 ELSEIF(QOLD.LE.QDEL3) THEN
69462 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
69465 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
69466 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
69467 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
69469 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69471 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
69474 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
69475 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
69476 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
69478 IF(QOLD.LT.1D-3*QDELW) THEN
69480 ELSEIF(QOLD.LE.QDELW) THEN
69482 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
69485 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
69486 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
69487 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
69489 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69491 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
69492 IF(QOLD.LT.1D-3*QDEL3W) THEN
69494 ELSEIF(QOLD.LE.QDEL3W) THEN
69496 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
69499 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
69500 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
69501 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69503 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69505 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
69507 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
69509 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
69511 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
69512 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
69514 IF(MSTJ(54).GE.1) THEN
69515 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
69517 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
69518 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
69520 ELSEIF(MSTJ(54).LE.-1) THEN
69521 EDEL=P(I1,4)+P(I2,4)-
69522 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
69523 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
69524 & (P(I1,3)-P(I2,3))**2
69529 SM1=(P(I1,5)+SMMIN)**2
69530 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
69531 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
69532 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
69533 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
69534 & K(I3M,5).NE.K(I1M,5)) GOTO 360
69536 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
69539 SM3=(P(I3,5)+SMMIN)**2
69540 IF(MSTJ(54).EQ.-2) THEN
69541 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
69542 & S23*MIN(SM1,SM3))*SM1)
69544 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
69545 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
69546 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
69547 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
69549 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
69550 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
69553 IF(WMAX*WI.GE.1.0) GOTO 360
69555 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
69556 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
69557 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
69558 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
69559 & K(I4M,5).NE.K(I1M,5)) GOTO 350
69561 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
69563 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
69564 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
69565 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
69567 IF(MSTJ(54).EQ.-2) THEN
69571 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
69572 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
69573 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
69574 W=MIN(W,MIN(S23,S24)*S13*S14)
69577 C...weight=1-cos(theta)/mtot2
69578 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
69579 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
69580 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
69581 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
69583 IF(W.LE.WMAX) GOTO 350
69585 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
69586 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
69587 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
69588 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
69589 IF(W.LE.WMAX) GOTO 350
69595 IF(MI4.EQ.0) GOTO 380
69598 EOLD=P(I3,4)+P(I4,4)
69600 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
69601 & (P(I3,3)+P(I4,3))**2
69602 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
69603 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
69604 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
69606 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
69607 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
69614 C...Shift momenta and recalculate energies.
69618 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
69622 P(I,J)=P(I,J)+P(IM,J)
69624 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
69627 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
69632 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
69633 440 ALPHA=(ESUMP-ESUM)/PROD
69634 PARJ(96)=PARJ(96)+ALPHA
69637 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
69640 P(I,J)=P(I,J)+ALPHA*V(IM,J)
69642 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
69645 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
69648 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
69652 C...Rescale all momenta for energy conservation.
69656 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
69658 PQS=PQS+P(I,5)**2/P(I,4)
69661 FAC=(PECM-PQS)/(PES-PQS)
69663 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
69667 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
69670 C...Boost back to correct reference frame.
69671 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
69673 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
69679 C*********************************************************************
69682 C...Calculates the momentum shift in a system of two particles assuming
69683 C...the relative momentum squared should be shifted to Q2NEW. NI is the
69684 C...last position occupied in /PYJETS/.
69686 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
69688 C...Double precision and integer declarations.
69689 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69690 IMPLICIT INTEGER(I-N)
69691 INTEGER PYK,PYCHGE,PYCOMP
69692 C...Parameter statement to help give large particle numbers.
69693 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69694 &KEXCIT=4000000,KDIMEN=5000000)
69696 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69697 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69698 SAVE /PYJETS/,/PYDAT1/
69699 C...Local arrays and data.
69703 IF(MSTJ(55).EQ.0) THEN
69705 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
69706 & (P(I1,3)-P(I2,3))**2
69707 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
69708 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
69712 DA=SE*DE*DP12-DP2*DQ2SE
69713 DB=DP2*DQ2SE-DP12**2
69714 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
69716 PD=HA*(P(I1,J)-P(I2,J))
69728 DP(J)=P(I1,J)+P(I2,J)
69731 C...Boost to cms and rotate first particle to z-axis
69732 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
69733 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
69734 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
69735 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
69736 S=Q2NEW+(P(I1,5)+P(I2,5))**2
69737 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
69741 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
69745 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
69746 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
69747 CALL PYROBO(NI+1,NI+2,THE,PHI,
69748 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
69751 P(NI+1,J)=P(NI+1,J)-P(I1,J)
69752 P(NI+2,J)=P(NI+2,J)-P(I2,J)
69758 C*********************************************************************
69761 C...Gives the mass of a particle/parton.
69763 FUNCTION PYMASS(KF)
69765 C...Double precision and integer declarations.
69766 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69767 IMPLICIT INTEGER(I-N)
69768 INTEGER PYK,PYCHGE,PYCOMP
69770 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69771 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69772 SAVE /PYDAT1/,/PYDAT2/
69774 C...Reset variables. Compressed code. Special case for popcorn diquarks.
69783 C...Guarantee use of constituent masses for internal checks.
69784 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
69785 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
69787 PYMASS=PARF(100+KFA)
69788 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
69789 ELSEIF(KFA.LE.10) THEN
69791 ELSEIF(MSTJ(93).EQ.1) THEN
69792 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
69794 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
69797 C...Other masses can be read directly off table.
69802 C...Optional mass broadening according to truncated Breit-Wigner
69803 C...(either in m or in m^2).
69804 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
69805 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
69806 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
69807 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
69810 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
69811 & (PM0*PMAS(KC,2)))
69812 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
69813 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
69814 & (PMUPP-PMLOW)*PYR(0))))
69822 C*********************************************************************
69825 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
69826 C...for Higgs couplings. Everything else sent on to PYMASS.
69828 FUNCTION PYMRUN(KF,Q2)
69830 C...Double precision and integer declarations.
69831 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69832 IMPLICIT INTEGER(I-N)
69833 INTEGER PYK,PYCHGE,PYCOMP
69835 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69836 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69837 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69838 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
69840 C...Most masses not handled here.
69842 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
69845 C...Current-algebra masses, but no Q2 dependence.
69846 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
69847 PYMRUN=PARF(90+KFA)
69849 C...Running current-algebra masses.
69852 PYMRUN=PARF(90+KFA)*
69853 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
69854 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
69860 C*********************************************************************
69863 C...Gives the particle/parton name as a character string.
69865 SUBROUTINE PYNAME(KF,CHAU)
69867 C...Double precision and integer declarations.
69868 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69869 IMPLICIT INTEGER(I-N)
69870 INTEGER PYK,PYCHGE,PYCOMP
69872 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69873 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69874 COMMON/PYDAT4/CHAF(500,2)
69876 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
69877 C...Local character variable.
69880 C...Read out code with distinction particle/antiparticle.
69883 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
69889 C*********************************************************************
69892 C...Gives three times the charge for a particle/parton.
69894 FUNCTION PYCHGE(KF)
69896 C...Double precision and integer declarations.
69897 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69898 IMPLICIT INTEGER(I-N)
69899 INTEGER PYK,PYCHGE,PYCOMP
69901 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69904 C...Read out charge and change sign for antiparticle.
69907 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
69912 C*********************************************************************
69915 C...Compress the standard KF codes for use in mass and decay arrays;
69916 C...also checks whether a given code actually is defined.
69918 FUNCTION PYCOMP(KF)
69920 C...Double precision and integer declarations.
69921 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69922 IMPLICIT INTEGER(I-N)
69923 INTEGER PYK,PYCHGE,PYCOMP
69925 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69926 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69927 SAVE /PYDAT1/,/PYDAT2/
69928 C...Local arrays and saved data.
69929 DIMENSION KFORD(100:500),KCORD(101:500)
69930 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
69932 C...Whenever necessary reorder codes for faster search.
69933 IF(MSTU(20).EQ.0) THEN
69938 IF(KFA.LE.100) GOTO 120
69940 DO 100 I1=NFORD-1,0,-1
69941 IF(KFA.GE.KFORD(I1)) GOTO 110
69942 KFORD(I1+1)=KFORD(I1)
69943 KCORD(I1+1)=KCORD(I1)
69945 110 KFORD(I1+1)=KFA
69953 C...Fast action if same code as in latest call.
69954 IF(KF.EQ.KFLAST) THEN
69959 C...Starting values. Remove internal diquark flags.
69962 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
69963 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
69965 C...Simple cases: direct translation.
69966 IF(KFA.GT.KFORD(NFORD)) THEN
69967 ELSEIF(KFA.LE.100) THEN
69970 C...Else binary search.
69974 130 IAVG=(IMIN+IMAX)/2
69975 IF(KFORD(IAVG).GT.KFA) THEN
69977 IF(IMAX.GT.IMIN+1) GOTO 130
69978 ELSEIF(KFORD(IAVG).LT.KFA) THEN
69980 IF(IMAX.GT.IMIN+1) GOTO 130
69986 C...Check if antiparticle allowed.
69987 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
69988 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
69991 C...Save codes for possible future fast action.
69998 C*********************************************************************
70001 C...Informs user of errors in program execution.
70003 SUBROUTINE PYERRM(MERR,CHMESS)
70005 C...Double precision and integer declarations.
70006 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70007 IMPLICIT INTEGER(I-N)
70008 INTEGER PYK,PYCHGE,PYCOMP
70010 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70011 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70012 SAVE /PYJETS/,/PYDAT1/
70013 C...Local character variable.
70014 CHARACTER CHMESS*(*)
70016 C...Write first few warnings, then be silent.
70017 IF(MERR.LE.10) THEN
70018 MSTU(27)=MSTU(27)+1
70020 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
70021 & MERR,MSTU(31),CHMESS
70023 C...Write first few errors, then be silent or stop program.
70024 ELSEIF(MERR.LE.20) THEN
70025 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
70026 MSTU(30)=MSTU(30)+1
70028 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
70029 & MERR-10,MSTU(31),CHMESS
70030 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
70031 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
70032 WRITE(MSTU(11),5200)
70033 IF(MERR.NE.17) CALL PYLIST(2)
70037 C...Stop program in case of irreparable error.
70039 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
70043 C...Formats for output.
70044 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
70045 &' PYEXEC calls:'/5X,A)
70046 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
70047 &' PYEXEC calls:'/5X,A)
70048 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
70050 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
70051 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
70056 C*********************************************************************
70059 C...Calculates the running alpha_electromagnetic.
70061 FUNCTION PYALEM(Q2)
70063 C...Double precision and integer declarations.
70064 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70065 IMPLICIT INTEGER(I-N)
70066 INTEGER PYK,PYCHGE,PYCOMP
70068 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70071 C...Calculate real part of photon vacuum polarization.
70072 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
70073 C...For hadrons use parametrization of H. Burkhardt et al.
70074 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
70075 AEMPI=PARU(101)/(3D0*PARU(1))
70076 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
70078 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
70080 ELSEIF(MSTU(101).EQ.2) THEN
70081 RPIGG=1D0-PARU(101)/PARU(103)
70082 ELSEIF(Q2.LT.0.09D0) THEN
70083 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
70084 ELSEIF(Q2.LT.9D0) THEN
70085 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
70086 & 0.00238D0*LOG(1D0+3.927D0*Q2)
70087 ELSEIF(Q2.LT.1D4) THEN
70088 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
70089 & 0.00299D0*LOG(1D0+Q2)
70091 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
70092 & 0.00293D0*LOG(1D0+Q2)
70095 C...Calculate running alpha_em.
70096 PYALEM=PARU(101)/(1D0-RPIGG)
70102 C*********************************************************************
70105 C...Gives the value of alpha_strong.
70107 FUNCTION PYALPS(Q2)
70109 C...Double precision and integer declarations.
70110 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70111 IMPLICIT INTEGER(I-N)
70112 INTEGER PYK,PYCHGE,PYCOMP
70114 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70115 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70116 SAVE /PYDAT1/,/PYDAT2/
70117 C...Coefficients for second-order threshold matching.
70118 C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
70119 DIMENSION STEPDN(6),STEPUP(6)
70120 c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
70121 c &(2D0*321D0/3703D0),0D0/
70122 c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
70123 c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
70124 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
70125 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
70127 C...Constant alpha_strong trivial. Pick artificial Lambda.
70128 IF(MSTU(111).LE.0) THEN
70130 MSTU(118)=MSTU(112)
70132 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
70133 & ((33D0-2D0*MSTU(112))*PARU(111)))
70134 PARU(118)=PARU(111)
70138 C...Find effective Q2, number of flavours and Lambda.
70140 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
70143 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
70144 Q2THR=PARU(113)*PMAS(NF,1)**2
70145 IF(Q2EFF.LT.Q2THR) THEN
70148 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
70149 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
70153 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
70154 Q2THR=PARU(113)*PMAS(NF+1,1)**2
70155 IF(Q2EFF.GT.Q2THR) THEN
70158 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
70159 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
70163 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
70164 PARU(117)=SQRT(ALAM2)
70166 C...Evaluate first or second order alpha_strong.
70167 B0=(33D0-2D0*NF)/6D0
70168 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
70169 IF(MSTU(111).EQ.1) THEN
70170 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
70172 B1=(153D0-19D0*NF)/6D0
70173 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
70182 C*********************************************************************
70185 C...Reconstructs an angle from given x and y coordinates.
70187 FUNCTION PYANGL(X,Y)
70189 C...Double precision and integer declarations.
70190 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70191 IMPLICIT INTEGER(I-N)
70192 INTEGER PYK,PYCHGE,PYCOMP
70194 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70199 IF(R.LT.1D-20) RETURN
70200 IF(ABS(X)/R.LT.0.8D0) THEN
70201 PYANGL=SIGN(ACOS(X/R),Y)
70204 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
70205 PYANGL=PARU(1)-PYANGL
70206 ELSEIF(X.LT.0D0) THEN
70207 PYANGL=-PARU(1)-PYANGL
70214 C*********************************************************************
70217 C...Performs rotations and boosts.
70219 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
70221 C...Double precision and integer declarations.
70222 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70223 IMPLICIT INTEGER(I-N)
70224 INTEGER PYK,PYCHGE,PYCOMP
70226 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70227 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70228 SAVE /PYJETS/,/PYDAT1/
70230 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
70232 C...Find and check range of rotation/boost.
70234 IF(IMIN.LE.0) IMIN=1
70235 IF(MSTU(1).GT.0) IMIN=MSTU(1)
70237 IF(IMAX.LE.0) IMAX=N
70238 IF(MSTU(2).GT.0) IMAX=MSTU(2)
70239 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
70240 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
70244 C...Optional resetting of V (when not set before.)
70245 IF(MSTU(33).NE.0) THEN
70246 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
70254 C...Rotate, typically from z axis to direction (theta,phi).
70255 IF(THE**2+PHI**2.GT.1D-20) THEN
70256 ROT(1,1)=COS(THE)*COS(PHI)
70258 ROT(1,3)=SIN(THE)*COS(PHI)
70259 ROT(2,1)=COS(THE)*SIN(PHI)
70261 ROT(2,3)=SIN(THE)*SIN(PHI)
70266 IF(K(I,1).LE.0) GOTO 140
70272 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
70273 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
70278 C...Boost, typically from rest to momentum/energy=beta.
70279 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
70283 DB=SQRT(DBX**2+DBY**2+DBZ**2)
70285 IF(DB.GT.EPS1) THEN
70286 C...Rescale boost vector if too close to unity.
70287 CALL PYERRM(3,'(PYROBO:) boost vector too large')
70293 DGA=1D0/SQRT(1D0-DB**2)
70295 IF(K(I,1).LE.0) GOTO 160
70300 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
70301 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
70302 P(I,1)=DP(1)+DGABP*DBX
70303 P(I,2)=DP(2)+DGABP*DBY
70304 P(I,3)=DP(3)+DGABP*DBZ
70305 P(I,4)=DGA*(DP(4)+DBP)
70306 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
70307 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
70308 V(I,1)=DV(1)+DGABV*DBX
70309 V(I,2)=DV(2)+DGABV*DBY
70310 V(I,3)=DV(3)+DGABV*DBZ
70311 V(I,4)=DGA*(DV(4)+DBV)
70318 C*********************************************************************
70321 C...Performs global manipulations on the event record, in particular
70322 C...to exclude unstable or undetectable partons/particles.
70324 SUBROUTINE PYEDIT(MEDIT)
70326 C...Double precision and integer declarations.
70327 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70328 IMPLICIT INTEGER(I-N)
70329 INTEGER PYK,PYCHGE,PYCOMP
70330 C...Parameter statement to help give large particle numbers.
70331 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70332 &KEXCIT=4000000,KDIMEN=5000000)
70334 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70335 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70336 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70337 COMMON/PYCTAG/NCT,MCT(4000,2)
70338 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
70340 DIMENSION NS(2),PTS(2),PLS(2)
70342 C...Remove unwanted partons/particles.
70343 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
70345 IF(MSTU(2).GT.0) IMAX=MSTU(2)
70346 I1=MAX(1,MSTU(1))-1
70347 DO 110 I=MAX(1,MSTU(1)),IMAX
70348 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
70349 IF(MEDIT.EQ.1) THEN
70350 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
70351 ELSEIF(MEDIT.EQ.2) THEN
70352 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
70354 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70355 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70356 & K(I,2).EQ.KSUSY1+39) GOTO 110
70357 ELSEIF(MEDIT.EQ.3) THEN
70358 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
70360 IF(KC.EQ.0) GOTO 110
70361 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
70362 ELSEIF(MEDIT.EQ.5) THEN
70363 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
70365 IF(KC.EQ.0) GOTO 110
70366 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
70367 & KCHG(KC,2).EQ.0) GOTO 110
70370 C...Pack remaining partons/particles. Origin no longer known.
70379 IF(I1.LT.N) MSTU(3)=0
70380 IF(I1.LT.N) MSTU(70)=0
70383 C...Selective removal of class of entries. New position of retained.
70384 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
70387 K(I,3)=MOD(K(I,3),MSTU(5))
70388 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
70389 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
70390 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
70391 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
70392 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
70393 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
70394 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
70396 K(I,3)=K(I,3)+MSTU(5)*I1
70399 C...Find new event history information and replace old.
70401 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
70402 & K(I,3)/MSTU(5).EQ.0) GOTO 140
70404 130 IM=MOD(K(ID,3),MSTU(5))
70405 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
70406 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
70407 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
70411 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
70412 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
70413 & K(IM,2).EQ.94) THEN
70418 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
70419 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
70420 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
70421 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
70422 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
70423 & K(K(I,4),3)/MSTU(5)
70424 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
70425 & K(K(I,5),3)/MSTU(5)
70427 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
70428 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
70429 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
70430 KCD=MOD(K(I,4),MSTU(5))
70431 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
70432 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
70433 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
70434 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
70435 KCD=MOD(K(I,5),MSTU(5))
70436 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
70437 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
70441 C...Pack remaining entries.
70446 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
70453 C...Also update LHA1 colour tags
70456 K(I1,3)=MOD(K(I1,3),MSTU(5))
70458 IF(I.EQ.MSTU(90+IZ)) THEN
70459 MSTU(90)=MSTU(90)+1
70460 MSTU(90+MSTU(90))=I1
70461 PARU(90+MSTU(90))=PARU(90+IZ)
70465 IF(I1.LT.N) MSTU(3)=0
70466 IF(I1.LT.N) MSTU(70)=0
70469 C...Fill in some missing daughter pointers (lost in colour flow).
70470 ELSEIF(MEDIT.EQ.16) THEN
70472 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
70473 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
70474 C...Find daughters who point to mother.
70476 IF(K(I1,3).NE.I) THEN
70477 ELSEIF(K(I,4).EQ.0) THEN
70483 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
70484 IF(K(I,4).NE.0) GOTO 220
70485 C...Find daughters who point to documentation version of mother.
70487 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
70488 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
70489 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
70491 IF(K(I1,3).NE.IM) THEN
70492 ELSEIF(K(I,4).EQ.0) THEN
70498 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
70499 IF(K(I,4).NE.0) GOTO 220
70500 C...Find daughters who point to documentation daughters who,
70501 C...in their turn, point to documentation mother.
70505 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
70507 IF(ID1.EQ.IM) ID1=I1
70511 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
70512 ELSEIF(K(I,4).EQ.0) THEN
70518 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
70521 C...Save top entries at bottom of PYJETS commonblock.
70522 ELSEIF(MEDIT.EQ.21) THEN
70523 IF(2*N.GE.MSTU(4)) THEN
70524 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
70529 K(MSTU(4)-I,J)=K(I,J)
70530 P(MSTU(4)-I,J)=P(I,J)
70531 V(MSTU(4)-I,J)=V(I,J)
70536 C...Restore bottom entries of commonblock PYJETS to top.
70537 ELSEIF(MEDIT.EQ.22) THEN
70538 DO 260 I=1,MSTU(32)
70540 K(I,J)=K(MSTU(4)-I,J)
70541 P(I,J)=P(MSTU(4)-I,J)
70542 V(I,J)=V(MSTU(4)-I,J)
70547 C...Mark primary entries at top of commonblock PYJETS as untreated.
70548 ELSEIF(MEDIT.EQ.23) THEN
70553 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
70555 IF(KH.NE.0) GOTO 280
70557 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
70558 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
70562 C...Place largest axis along z axis and second largest in xy plane.
70563 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
70564 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
70565 & P(MSTU(61),2)),0D0,0D0,0D0)
70566 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
70567 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
70568 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
70569 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
70570 IF(MEDIT.EQ.31) RETURN
70572 C...Rotate to put slim jet along +z axis.
70579 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
70580 IF(MSTU(41).GE.2) THEN
70582 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70583 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70584 & K(I,2).EQ.KSUSY1+39) GOTO 300
70585 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
70588 IS=2D0-SIGN(0.5D0,P(I,3))
70590 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
70592 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
70593 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
70595 C...Rotate to put second largest jet into -z,+x quadrant.
70597 IF(P(I,3).GE.0D0) GOTO 310
70598 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
70599 IF(MSTU(41).GE.2) THEN
70601 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70602 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70603 & K(I,2).EQ.KSUSY1+39) GOTO 310
70604 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
70607 IS=2D0-SIGN(0.5D0,P(I,1))
70608 PLS(IS)=PLS(IS)-P(I,3)
70610 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
70617 C*********************************************************************
70620 C...Gives program heading, or lists an event, or particle
70621 C...data, or current parameter values.
70623 SUBROUTINE PYLIST(MLIST)
70625 C...Double precision and integer declarations.
70626 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70627 IMPLICIT INTEGER(I-N)
70628 INTEGER PYK,PYCHGE,PYCOMP
70629 C...Parameter statement to help give large particle numbers.
70630 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70631 &KEXCIT=4000000,KDIMEN=5000000)
70633 C...HEPEVT commonblock.
70634 PARAMETER (NMXHEP=4000)
70635 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
70636 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
70637 DOUBLE PRECISION PHEP,VHEP
70640 C...User process event common block.
70642 PARAMETER (MAXNUP=500)
70643 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
70644 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
70645 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
70646 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
70647 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
70651 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70652 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70653 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70654 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
70655 COMMON/PYCTAG/NCT,MCT(4000,2)
70656 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
70657 C...Local arrays, character variables and data.
70658 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
70660 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
70662 C...Initialization printout: version number and date of last change.
70663 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
70666 IF(MLIST.EQ.0) RETURN
70669 C...List event data, including additional lines after N.
70670 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
70671 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
70672 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
70673 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
70674 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
70676 IF(MLIST.GE.2) LMX=16
70679 IF(MSTU(2).GT.0) IMAX=MSTU(2)
70680 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
70681 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
70682 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
70683 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
70685 C...Get particle name, pad it and check it is not too long.
70686 CALL PYNAME(K(I,2),CHAP)
70689 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
70693 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
70695 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
70698 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
70700 CHAC=CHDL(MDL)(1:2*LDL)//' '
70702 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
70703 & CHDL(MDL)(LDL+1:2*LDL)//' '
70704 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
70708 C...Add information on string connection.
70709 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
70713 IF(KC.NE.0) KCC=KCHG(KC,2)
70714 IF(IABS(K(I,2)).EQ.39) THEN
70715 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
70716 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
70718 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
70719 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
70720 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
70721 ELSEIF(KCC.NE.0) THEN
70723 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
70726 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
70727 & CHAC(LMX-1:LMX-1)='I'
70729 C...Write data for particle/jet.
70730 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
70731 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
70733 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
70734 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
70736 ELSEIF(MLIST.EQ.1) THEN
70737 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
70739 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
70740 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
70741 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
70742 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
70743 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
70745 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
70746 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
70747 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
70748 & ,10000),MCT(I,1),MCT(I,2)
70750 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
70752 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
70753 & ,MCT(I,1),MCT(I,2)
70755 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
70757 C...Insert extra separator lines specified by user.
70758 IF(MSTU(70).GE.1) THEN
70760 DO 110 J=1,MIN(10,MSTU(70))
70761 IF(I.EQ.MSTU(70+J)) ISEP=1
70764 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
70765 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
70766 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
70771 C...Sum of charges and momenta.
70775 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
70776 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
70777 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
70778 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
70779 ELSEIF(MLIST.EQ.1) THEN
70780 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
70781 ELSEIF(MLIST.LE.3) THEN
70782 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
70784 WRITE(MSTU(11),7000) PS(6)
70787 C...Simple listing of HEPEVT entries (mainly for test purposes).
70788 ELSEIF(MLIST.EQ.5) THEN
70789 WRITE(MSTU(11),7100)
70791 IF(ISTHEP(I).EQ.0) GOTO 140
70792 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
70793 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
70797 C...Simple listing of user-process entries (mainly for test purposes).
70798 ELSEIF(MLIST.EQ.7) THEN
70799 WRITE(MSTU(11),7300)
70801 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
70802 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
70805 C...Give simple list of KF codes defined in program.
70806 ELSEIF(MLIST.EQ.11) THEN
70807 WRITE(MSTU(11),7500)
70809 CALL PYNAME(KF,CHAP)
70810 CALL PYNAME(-KF,CHAN)
70811 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
70812 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70816 DO 170 KFLB=1,KFLA-(3-KFLS)/2
70817 KF=1000*KFLA+100*KFLB+KFLS
70818 CALL PYNAME(KF,CHAP)
70819 CALL PYNAME(-KF,CHAN)
70820 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70826 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
70827 IF(KMUL.EQ.5) KFLS=5
70829 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
70830 IF(KMUL.EQ.4) KFLR=2
70832 DO 200 KFLC=1,KFLB-1
70833 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
70834 CALL PYNAME(KF,CHAP)
70835 CALL PYNAME(-KF,CHAN)
70836 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70839 CALL PYNAME(KFK,CHAP)
70840 WRITE(MSTU(11),7600) KFK,CHAP
70842 CALL PYNAME(KFK,CHAP)
70843 WRITE(MSTU(11),7600) KFK,CHAP
70846 KF=10000*KFLR+110*KFLB+KFLS
70847 CALL PYNAME(KF,CHAP)
70848 WRITE(MSTU(11),7600) KF,CHAP
70852 CALL PYNAME(KF,CHAP)
70853 WRITE(MSTU(11),7600) KF,CHAP
70855 CALL PYNAME(KF,CHAP)
70856 WRITE(MSTU(11),7600) KF,CHAP
70862 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
70864 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
70865 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
70866 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
70867 CALL PYNAME(KF,CHAP)
70868 CALL PYNAME(-KF,CHAN)
70869 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70876 IF(KF.LT.1000000) GOTO 270
70877 CALL PYNAME(KF,CHAP)
70878 CALL PYNAME(-KF,CHAN)
70879 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
70880 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70883 C...List parton/particle data table. Check whether to be listed.
70884 ELSEIF(MLIST.EQ.12) THEN
70885 WRITE(MSTU(11),7700)
70886 DO 300 KC=1,MSTU(6)
70888 IF(KF.EQ.0) GOTO 300
70889 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
70892 C...Find particle name and mass. Print information.
70893 CALL PYNAME(KF,CHAP)
70894 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
70895 CALL PYNAME(-KF,CHAN)
70896 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
70897 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
70899 C...Particle decay: channel number, branching ratios, matrix element,
70900 C...decay products.
70901 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
70903 CALL PYNAME(KFDP(IDC,J),CHAD(J))
70905 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
70910 C...List parameter value table.
70911 ELSEIF(MLIST.EQ.13) THEN
70912 WRITE(MSTU(11),8000)
70914 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
70918 C...Format statements for output on unit MSTU(11) (by default 6).
70919 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
70920 &5X,'KF orig p_x p_y p_z E m'/)
70921 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
70922 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
70923 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
70924 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
70925 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
70926 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
70927 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
70928 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
70929 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
70930 & ,' C tag AC tag'/)
70931 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
70932 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
70933 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
70934 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
70935 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
70936 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
70937 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
70938 6200 FORMAT(66X,5(1X,F12.3))
70939 6300 FORMAT(1X,78('='))
70940 6400 FORMAT(1X,130('='))
70941 6500 FORMAT(1X,65('='))
70942 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
70943 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
70944 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
70945 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
70947 7000 FORMAT(19X,'sum charge:',F6.2)
70948 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
70949 &//' I IST ID Mothers Daughters p_x p_y p_z',
70951 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
70952 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
70953 &//' I IST ID Mothers Colours p_x p_y p_z',
70955 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
70956 7500 FORMAT(///20X,'List of KF codes in program'/)
70957 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
70958 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
70959 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
70960 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
70961 &1X,'ME',3X,'Br.rat.',4X,'decay products')
70962 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
70963 &1X,1P,E13.5,3X,I2)
70964 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
70965 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
70966 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
70967 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
70972 C*********************************************************************
70975 C...Writes a logo for the program.
70979 C...Double precision and integer declarations.
70980 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70981 IMPLICIT INTEGER(I-N)
70982 INTEGER PYK,PYCHGE,PYCOMP
70983 C...Parameter for length of information block.
70984 PARAMETER (IREFER=21)
70986 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70987 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
70988 SAVE /PYDAT1/,/PYPARS/
70989 C...Local arrays and character variables.
70991 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
70992 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
70994 C...Data on months, logo, titles, and references.
70995 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
70996 &'Oct','Nov','Dec'/
70997 DATA (LOGO(J),J=1,19)/
70999 &' *:::!!:::::::::::* ',
71000 &' *::::::!!::::::::::::::* ',
71001 &' *::::::::!!::::::::::::::::* ',
71002 &' *:::::::::!!:::::::::::::::::* ',
71003 &' *:::::::::!!:::::::::::::::::* ',
71004 &' *::::::::!!::::::::::::::::*! ',
71005 &' *::::::!!::::::::::::::* !! ',
71006 &' !! *:::!!:::::::::::* !! ',
71007 &' !! !* -><- * !! ',
71017 DATA (LOGO(J),J=20,38)/
71018 &'Welcome to the Lund Monte Carlo!',
71020 &'PPP Y Y TTTTT H H III A ',
71021 &'P P Y Y T H H I A A ',
71022 &'PPP Y T HHHHH I AAAAA',
71023 &'P Y T H H I A A',
71024 &'P Y T H H III A A',
71026 &'This is PYTHIA version x.xxx ',
71027 &'Last date of change: xx xxx 200x',
71029 &'Now is xx xxx 200x at xx:xx:xx ',
71031 &'Disclaimer: this program comes ',
71032 &'without any guarantees. Beware ',
71033 &'of errors and use common sense ',
71034 &'when interpreting results. ',
71036 &'Copyright T. Sjostrand (2007) '/
71037 DATA (REFER(J),J=1,14)/
71038 &'An archive of program versions and d',
71039 &'ocumentation is found on the web: ',
71040 &'http://www.thep.lu.se/~torbjorn/Pyth',
71044 &'When you cite this program, the offi',
71045 &'cial reference is to the 6.4 manual:',
71046 &'T. Sjostrand, S. Mrenna and P. Skand',
71047 &'s, JHEP05 (2006) 026 ',
71048 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
71049 &'-T) [hep-ph/0603175]. ',
71052 DATA (REFER(J),J=15,32)/
71053 &'Also remember that the program, to a',
71054 &' large extent, represents original ',
71055 &'physics research. Other publications',
71056 &' of special relevance to your ',
71057 &'studies may therefore deserve separa',
71061 &'Main author: Torbjorn Sjostrand; CER',
71062 &'N/PH, CH-1211 Geneva, Switzerland, ',
71063 &' and Department of Theoretical Phys',
71064 &'ics, Lund University, Lund, Sweden; ',
71065 &' phone: + 41 - 22 - 767 82 27; e-ma',
71066 &'il: torbjorn@thep.lu.se ',
71067 &'Author: Stephen Mrenna; Computing Di',
71068 &'vision, GDS Group, ',
71069 &' Fermi National Accelerator Laborat',
71070 &'ory, MS 234, Batavia, IL 60510, USA;'/
71071 DATA (REFER(J),J=33,2*IREFER)/
71072 &' phone: + 1 - 630 - 840 - 2556; e-m',
71073 &'ail: mrenna@fnal.gov ',
71074 &'Author: Peter Skands; Theoretical Ph',
71075 &'ysics Department, ',
71076 &' Fermi National Accelerator Laborat',
71077 &'ory, MS 106, Batavia, IL 60510, USA;',
71078 &' and CERN/PH, CH-1211 Geneva, Switz',
71080 &' phone: + 41 - 22 - 767 24 59; e-ma',
71081 &'il: skands@fnal.gov '/
71083 C...Check that PYDATA linked.
71084 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
71086 & 'Error: PYDATA has not been linked.'
71087 WRITE(*,'(1X,A)') 'Execution stopped!'
71090 C...Write current version number and current date+time.
71092 WRITE(VERS,'(I1)') MSTP(181)
71093 LOGO(28)(24:24)=VERS
71094 WRITE(SUBV,'(I3)') MSTP(182)
71095 LOGO(28)(26:28)=SUBV
71096 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
71097 WRITE(DATE,'(I2)') MSTP(185)
71098 LOGO(29)(22:23)=DATE
71099 LOGO(29)(25:27)=MONTH(MSTP(184))
71100 WRITE(YEAR,'(I4)') MSTP(183)
71101 LOGO(29)(29:32)=YEAR
71103 IF(IDATI(1).LE.0) THEN
71106 WRITE(DATE,'(I2)') IDATI(3)
71108 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
71109 WRITE(YEAR,'(I4)') IDATI(1)
71110 LOGO(31)(15:18)=YEAR
71111 WRITE(HOUR,'(I2)') IDATI(4)
71112 LOGO(31)(23:24)=HOUR
71113 WRITE(MINU,'(I2)') IDATI(5)
71114 LOGO(31)(26:27)=MINU
71115 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
71116 WRITE(SECO,'(I2)') IDATI(6)
71117 LOGO(31)(29:30)=SECO
71118 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
71122 C...Loop over lines in header. Define page feed and side borders.
71123 DO 100 ILIN=1,29+IREFER
71132 C...Separator lines and logos.
71133 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
71134 LINE(4:77)='***********************************************'//
71135 & '***************************'
71136 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
71137 LINE(6:37)=LOGO(ILIN-5)
71138 LINE(44:75)=LOGO(ILIN+14)
71139 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
71140 LINE(5:40)=REFER(2*ILIN-51)
71141 LINE(41:76)=REFER(2*ILIN-50)
71144 C...Write lines to appropriate unit.
71145 WRITE(MSTU(11),'(A79)') LINE
71151 C*********************************************************************
71154 C...Facilitates the updating of particle and decay data
71155 C...by allowing it to be done in an external file.
71157 SUBROUTINE PYUPDA(MUPDA,LFN)
71159 C...Double precision and integer declarations.
71160 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71161 IMPLICIT INTEGER(I-N)
71162 INTEGER PYK,PYCHGE,PYCOMP
71164 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71165 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71166 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
71167 COMMON/PYDAT4/CHAF(500,2)
71169 COMMON/PYINT4/MWID(500),WIDS(500,5)
71170 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
71171 C...Local arrays, character variables and data.
71172 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
71173 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
71174 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
71175 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
71176 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
71177 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
71178 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
71180 C...Write header if not yet done.
71181 IF(MSTU(12).NE.12345) CALL PYLIST(0)
71183 C...Write information on file for editing.
71184 IF(MUPDA.EQ.1) THEN
71186 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
71187 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
71188 & MWID(KC),MDCY(KC,1)
71189 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
71190 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
71191 & (KFDP(IDC,J),J=1,5)
71195 C...Read complete set of information from edited file or
71196 C...read partial set of new or updated information from edited file.
71197 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
71199 C...Reset counters.
71203 IF(MUPDA.EQ.2) THEN
71208 DO 130 KC=1,MSTU(6)
71209 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
71210 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
71214 C...Begin of loop: read new line; unknown whether particle or
71216 140 READ(LFN,5200,END=190) CHINL
71218 C...Identify particle code and whether already defined (for MUPDA=3).
71219 IF(CHINL(2:10).NE.' ') THEN
71222 IF(MUPDA.EQ.2) THEN
71235 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
71238 C...Remove duplicate old decay data.
71239 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
71240 IDCREP=MDCY(KCREP,2)
71241 NDCREP=MDCY(KCREP,3)
71243 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
71245 DO 180 I=IDCREP,NDC-NDCREP
71246 MDME(I,1)=MDME(I+NDCREP,1)
71247 MDME(I,2)=MDME(I+NDCREP,2)
71248 BRAT(I)=BRAT(I+NDCREP)
71250 KFDP(I,J)=KFDP(I+NDCREP,J)
71255 ELSEIF(KCREP.NE.0) THEN
71263 C...Study line with particle data.
71264 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
71265 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
71266 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
71267 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
71268 & MWID(KC),MDCY(KC,1)
71272 C...Study line with decay data.
71275 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
71276 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
71277 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
71278 MDCY(KC,3)=MDCY(KC,3)+1
71279 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
71280 & (KFDP(NDC,J),J=1,5)
71283 C...End of loop; ensure that PYCOMP tables are updated.
71288 C...Perform possible tests that new information is consistent.
71289 DO 220 KC=1,MSTU(6)
71291 IF(KF.EQ.0) GOTO 220
71292 WRITE(CHKF,5300) KF
71293 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
71294 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
71295 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
71297 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
71298 IF(MDME(IDC,2).GT.80) GOTO 210
71300 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
71304 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
71306 ELSEIF(PYCOMP(KP).EQ.0) THEN
71311 PMS=PMS-PMAS(KPC,1)
71312 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
71316 IF(KQ.NE.0) MERR=MAX(2,MERR)
71317 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
71319 IF(MERR.EQ.3) CALL PYERRM(17,
71320 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
71321 IF(MERR.EQ.2) CALL PYERRM(17,
71322 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
71323 IF(MERR.EQ.1) CALL PYERRM(7,
71324 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
71325 BRSUM=BRSUM+BRAT(IDC)
71327 WRITE(CHTMP,5500) BRSUM
71328 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
71329 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
71330 & CHTMP(9:16)//' for KF ='//CHKF)
71333 C...Write DATA statements for inclusion in program.
71334 ELSEIF(MUPDA.EQ.4) THEN
71336 C...Find out how many codes and decay channels are actually used.
71340 IF(KCHG(I,4).NE.0) THEN
71342 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
71346 C...Initialize writing of DATA statements for inclusion in program.
71349 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
71352 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
71356 C...Loop through variables for conversion to characters.
71358 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
71359 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
71360 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
71361 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
71362 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
71363 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
71364 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
71365 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
71366 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
71367 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
71368 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
71369 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
71370 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
71371 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
71372 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
71373 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
71374 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
71375 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
71376 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
71377 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
71378 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
71379 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
71381 C...Replace variables beyond what is properly defined.
71383 IF(IDIM.GT.KCC) CHTMP=' 0'
71384 ELSEIF(IVAR.LE.8) THEN
71385 IF(IDIM.GT.KCC) CHTMP=' 0.0'
71386 ELSEIF(IVAR.LE.11) THEN
71387 IF(IDIM.GT.KCC) CHTMP=' 0'
71388 ELSEIF(IVAR.LE.13) THEN
71389 IF(IDIM.GT.NDC) CHTMP=' 0'
71390 ELSEIF(IVAR.LE.14) THEN
71391 IF(IDIM.GT.NDC) CHTMP=' 0.0'
71392 ELSEIF(IVAR.LE.19) THEN
71393 IF(IDIM.GT.NDC) CHTMP=' 0'
71394 ELSEIF(IVAR.LE.21) THEN
71395 IF(IDIM.GT.KCC) CHTMP=' '
71397 IF(IDIM.GT.KCC) CHTMP=' 0'
71400 C...Length of variable, trailing decimal zeros, quotation marks.
71404 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
71405 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
71407 CHNEW=CHTMP(LLOW:LHIG)//' '
71409 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
71412 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
71413 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
71418 CHNEW(LNEW+1:LNEW+2)='D0'
71421 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
71422 DO 260 LL=LNEW,1,-1
71423 IF(CHNEW(LL:LL).EQ.'''') THEN
71425 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
71431 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
71435 C...Form composite character string, often including repetition counter.
71436 IF(CHNEW.NE.CHOLD) THEN
71443 IF(NRPT.GE.2) LRPT=LNEW+3
71444 IF(NRPT.GE.10) LRPT=LNEW+4
71445 IF(NRPT.GE.100) LRPT=LNEW+5
71446 IF(NRPT.GE.1000) LRPT=LNEW+6
71449 WRITE(CHTMP,5400) NRPT
71451 IF(NRPT.GE.10) LRPT=2
71452 IF(NRPT.GE.100) LRPT=3
71453 IF(NRPT.GE.1000) LRPT=4
71454 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
71458 C...Add characters to end of line, to new line (after storing old line),
71459 C...or to new block of lines (after writing old block).
71460 IF(LLIN+LCOM.LE.70) THEN
71461 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
71463 ELSEIF(NLIN.LE.19) THEN
71464 CHLIN(LLIN+1:72)=' '
71467 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
71470 CHLIN(LLIN:72)='/'//' '
71472 WRITE(CHTMP,5400) IDIM-NRPT
71473 CHBLK(1)(30:33)=CHTMP(13:16)
71475 WRITE(LFN,5700) CHBLK(ILIN)
71479 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
71480 & ',I= , )/'//CHCOM(1:LCOM)//','
71481 WRITE(CHTMP,5400) IDIM-NRPT+1
71482 CHLIN(25:28)=CHTMP(13:16)
71487 C...Write final block of lines.
71488 CHLIN(LLIN:72)='/'//' '
71490 WRITE(CHTMP,5400) NDIM
71491 CHBLK(1)(30:33)=CHTMP(13:16)
71493 WRITE(LFN,5700) CHBLK(ILIN)
71498 C...Formats for reading and writing particle data.
71499 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
71500 5100 FORMAT(10X,2I5,F12.6,5I10)
71511 C*********************************************************************
71514 C...Provides various integer-valued event related data.
71518 C...Double precision and integer declarations.
71519 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71520 IMPLICIT INTEGER(I-N)
71521 INTEGER PYK,PYCHGE,PYCOMP
71523 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71524 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71525 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71526 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71528 C...Default value. For I=0 number of entries, number of stable entries
71529 C...or 3 times total charge.
71531 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
71532 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
71534 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
71536 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
71537 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
71540 ELSEIF(I.EQ.0) THEN
71542 C...For I > 0 direct readout of K matrix or charge.
71543 ELSEIF(J.LE.5) THEN
71545 ELSEIF(J.EQ.6) THEN
71548 C...Status (existing/fragmented/decayed), parton/hadron separation.
71549 ELSEIF(J.LE.8) THEN
71550 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
71551 IF(J.EQ.8) PYK=PYK*K(I,2)
71552 ELSEIF(J.LE.12) THEN
71556 IF(KC.NE.0) KQ=KCHG(KC,2)
71557 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
71558 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
71560 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
71562 C...Heaviest flavour in hadron/diquark.
71563 ELSEIF(J.EQ.13) THEN
71565 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
71566 IF(KFA.LT.10) PYK=KFA
71567 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
71568 PYK=PYK*ISIGN(1,K(I,2))
71570 C...Particle history: generation, ancestor, rank.
71571 ELSEIF(J.LE.15) THEN
71578 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
71581 ELSEIF(J.EQ.16) THEN
71583 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
71584 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
71591 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
71592 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
71594 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
71595 IF(ILP.EQ.1) GOTO 120
71597 IF(K(I1,1).EQ.12) THEN
71599 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
71600 & .AND.K(I3,2).NE.93) PYK=PYK+1
71606 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
71610 C...Particle coming from collapsing jet system or not.
71611 ELSEIF(J.EQ.17) THEN
71618 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
71619 IF(PYK.EQ.1) PYK=-1
71623 IF(KCHG(KC,2).EQ.0) GOTO 150
71624 IF(K(I1,1).NE.12) PYK=0
71625 IF(K(I1,1).NE.12) RETURN
71628 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
71630 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
71632 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
71634 C...Number of decay products. Colour flow.
71635 ELSEIF(J.EQ.18) THEN
71636 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
71637 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
71638 ELSEIF(J.LE.22) THEN
71639 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
71640 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
71641 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
71642 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
71643 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
71650 C*********************************************************************
71653 C...Provides various real-valued event related data.
71657 C...Double precision and integer declarations.
71658 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71659 IMPLICIT INTEGER(I-N)
71660 INTEGER PYK,PYCHGE,PYCOMP
71662 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71663 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71664 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71665 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71669 C...Set default value. For I = 0 sum of momenta or charges,
71670 C...or invariant mass of system.
71672 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
71673 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
71675 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
71677 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
71681 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
71685 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
71686 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
71688 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
71690 ELSEIF(I.EQ.0) THEN
71692 C...Direct readout of P matrix.
71693 ELSEIF(J.LE.5) THEN
71696 C...Charge, total momentum, transverse momentum, transverse mass.
71697 ELSEIF(J.LE.12) THEN
71698 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
71699 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
71700 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
71701 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
71702 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
71704 C...Theta and phi angle in radians or degrees.
71705 ELSEIF(J.LE.16) THEN
71706 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
71707 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
71708 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
71710 C...True rapidity, rapidity with pion mass, pseudorapidity.
71711 ELSEIF(J.LE.19) THEN
71713 IF(J.EQ.17) PMR=P(I,5)
71714 IF(J.EQ.18) PMR=PYMASS(211)
71715 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
71716 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
71719 C...Energy and momentum fractions (only to be used in CM frame).
71720 ELSEIF(J.LE.25) THEN
71721 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
71722 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
71723 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
71724 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
71725 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
71726 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
71732 C*********************************************************************
71735 C...Performs sphericity tensor analysis to give sphericity,
71736 C...aplanarity and the related event axes.
71738 SUBROUTINE PYSPHE(SPH,APL)
71740 C...Double precision and integer declarations.
71741 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71742 IMPLICIT INTEGER(I-N)
71743 INTEGER PYK,PYCHGE,PYCOMP
71744 C...Parameter statement to help give large particle numbers.
71745 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71746 &KEXCIT=4000000,KDIMEN=5000000)
71748 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71749 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71750 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71751 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71753 DIMENSION SM(3,3),SV(3,3)
71755 C...Calculate matrix to be diagonalized.
71764 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
71765 IF(MSTU(41).GE.2) THEN
71767 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71768 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71769 & K(I,2).EQ.KSUSY1+39) GOTO 140
71770 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71774 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71776 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
71777 & MAX(1D-10,PA)**(PARU(41)-2D0)
71780 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
71786 C...Very low multiplicities (0 or 1) not considered.
71788 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
71795 SM(J1,J2)=SM(J1,J2)/PS
71799 C...Find eigenvalues to matrix (third degree equation).
71800 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
71801 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
71802 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
71803 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
71804 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
71805 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
71806 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
71807 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
71808 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
71809 IF(P(N+2,4).LT.1D-5) THEN
71810 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
71816 C...Find first and last eigenvector by solving equation system.
71819 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
71821 SV(J1,J2)=SM(J1,J2)
71822 SV(J2,J1)=SM(J1,J2)
71828 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
71831 SMAX=ABS(SV(J1,J2))
71835 DO 220 J3=JA+1,JA+2
71837 RL=SV(J1,JB)/SV(JA,JB)
71839 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
71840 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
71842 SMAX=ABS(SV(J1,J2))
71846 JB2=JB+2-3*((JB+1)/3)
71847 P(N+I,JB1)=-SV(JC,JB2)
71848 P(N+I,JB2)=SV(JC,JB1)
71849 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
71851 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
71852 SGN=(-1D0)**INT(PYR(0)+0.5D0)
71854 P(N+I,J)=SGN*P(N+I,J)/PA
71858 C...Middle axis orthogonal to other two. Fill other codes.
71859 SGN=(-1D0)**INT(PYR(0)+0.5D0)
71860 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
71861 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
71862 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
71875 C...Calculate sphericity and aplanarity. Select storing option.
71876 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
71880 IF(MSTU(43).LE.1) MSTU(3)=3
71881 IF(MSTU(43).GE.2) N=N+3
71886 C*********************************************************************
71889 C...Performs thrust analysis to give thrust, oblateness
71890 C...and the related event axes.
71892 SUBROUTINE PYTHRU(THR,OBL)
71894 C...Double precision and integer declarations.
71895 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71896 IMPLICIT INTEGER(I-N)
71897 INTEGER PYK,PYCHGE,PYCOMP
71898 C...Parameter statement to help give large particle numbers.
71899 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71900 &KEXCIT=4000000,KDIMEN=5000000)
71902 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71903 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71904 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71905 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71907 DIMENSION TDI(3),TPR(3)
71909 C...Take copy of particles that are to be considered in thrust analysis.
71913 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
71914 IF(MSTU(41).GE.2) THEN
71916 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71917 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71918 & K(I,2).EQ.KSUSY1+39) GOTO 100
71919 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71922 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
71923 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
71933 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71935 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
71936 & P(N+NP,4)**(PARU(42)-1D0)
71937 PS=PS+P(N+NP,4)*P(N+NP,5)
71940 C...Very low multiplicities (0 or 1) not considered.
71942 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
71948 C...Loop over thrust and major. T axis along z direction in latter case.
71952 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
71954 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
71955 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
71956 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
71959 C...Find and order particles with highest p (pT for major).
71960 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
71964 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
71965 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
71966 IF(P(I,4).LE.P(ILF,4)) GOTO 140
71968 P(ILF+1,J)=P(ILF,J)
71977 C...Find and order initial axes with highest thrust (major).
71978 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
71981 NC=2**(MIN(MSTU(44),NP)-1)
71986 DO 200 ILF=1,MIN(MSTU(44),NP)
71987 SGN=P(N+NP+ILF+3,5)
71988 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
71990 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
71993 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
71994 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
71995 IF(TDS.LE.P(ILG,4)) GOTO 230
71997 P(ILG+1,J)=P(ILG,J)
72000 ILG=N+NP+MSTU(44)+4
72007 C...Iterate direction of axis until stable maximum.
72014 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
72015 IF(THP.GT.1D-10) TDI(J)=TPR(J)
72019 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
72021 TPR(J)=TPR(J)+SGN*P(I,J)
72024 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
72025 IF(THP.GE.THPS+PARU(48)) GOTO 270
72027 C...Save good axis. Try new initial axis until a number of tries agree.
72028 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
72029 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
72031 SGN=(-1D0)**INT(PYR(0)+0.5D0)
72033 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
72039 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
72042 C...Find minor axis and value by orthogonality.
72043 SGN=(-1D0)**INT(PYR(0)+0.5D0)
72044 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
72045 P(N+NP+3,2)=SGN*P(N+NP+2,1)
72049 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
72054 C...Fill axis information. Rotate back to original coordinate system.
72062 P(N+ILD,J)=P(N+NP+ILD,J)
72066 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
72068 C...Calculate thrust and oblateness. Select storing option.
72070 OBL=P(N+2,4)-P(N+3,4)
72073 IF(MSTU(43).LE.1) MSTU(3)=3
72074 IF(MSTU(43).GE.2) N=N+3
72079 C*********************************************************************
72082 C...Subdivides the particle content of an event into jets/clusters.
72084 SUBROUTINE PYCLUS(NJET)
72086 C...Double precision and integer declarations.
72087 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72088 IMPLICIT INTEGER(I-N)
72089 INTEGER PYK,PYCHGE,PYCOMP
72090 C...Parameter statement to help give large particle numbers.
72091 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72092 &KEXCIT=4000000,KDIMEN=5000000)
72094 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72095 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72096 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72097 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72098 C...Local arrays and saved variables.
72100 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
72102 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
72103 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
72104 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
72105 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
72106 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
72107 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
72108 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
72110 C...If first time, reset. If reentering, skip preliminaries.
72111 IF(MSTU(48).LE.0) THEN
72117 PIMASS=PMAS(PYCOMP(211),1)
72120 IF(MSTU(43).GE.2) N=N-NJET
72121 DO 110 I=N+1,N+NJET
72122 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72124 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
72127 R2ACC=PARU(45)*PS(5)**2
72133 C...Find which particles are to be considered in cluster search.
72135 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
72136 IF(MSTU(41).GE.2) THEN
72138 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72139 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72140 & K(I,2).EQ.KSUSY1+39) GOTO 140
72141 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72144 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
72145 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
72150 C...Take copy of these particles, with space left for jets later on.
72156 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
72157 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
72158 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72159 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72161 PS(J)=PS(J)+P(N+NP,J)
72171 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
72173 C...Very low multiplicities not considered.
72174 IF(NP.LT.MSTU(47)) THEN
72175 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
72180 C...Find precluster configuration. If too few jets, make harder cuts.
72182 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
72185 R2ACC=PARU(45)*PS(5)**2
72187 RINIT=1.25D0*PARU(43)
72188 IF(NP.LE.MSTU(47)+2) RINIT=0D0
72189 170 RINIT=0.8D0*RINIT
72192 DO 180 I=N+NP+1,N+2*NP
72196 C...Sum up small momentum region. Jet if enough absolute momentum.
72197 IF(MSTU(46).LE.2) THEN
72201 DO 210 I=N+NP+1,N+2*NP
72202 IF(P(I,5).GT.2D0*RINIT) GOTO 210
72206 P(N+1,J)=P(N+1,J)+P(I,J)
72209 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
72210 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
72211 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
72212 IF(NREM.EQ.0) GOTO 170
72215 C...Find fastest remaining particle.
72218 DO 230 I=N+NP+1,N+2*NP
72219 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
72224 P(N+NPRE,J)=P(IMAX,J)
72229 C...Sum up precluster around it according to pT separation.
72230 IF(MSTU(46).LE.2) THEN
72231 DO 260 I=N+NP+1,N+2*NP
72232 IF(K(I,4).NE.0) GOTO 260
72234 IF(R2.GT.RINIT**2) GOTO 260
72238 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
72241 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
72243 C...Sum up precluster around it according to mass or
72244 C...Durham pT separation.
72248 DO 280 I=N+NP+1,N+2*NP
72249 IF(K(I,4).NE.0) GOTO 280
72250 IF(MSTU(46).LE.4) THEN
72255 IF(R2.GE.R2MIN) GOTO 280
72261 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
72263 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
72270 C...Check if more preclusters to be found. Start over if too few.
72271 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
72272 IF(NREM.GT.0) GOTO 220
72275 C...Reassign all particles to nearest jet. Sum up new jet momenta.
72278 310 IF(MSTU(46).LE.1) THEN
72279 DO 330 I=N+1,N+NJET
72284 DO 360 I=N+NP+1,N+2*NP
72286 DO 340 IJET=N+1,N+NJET
72287 IF(P(IJET,5).LT.RINIT) GOTO 340
72289 IF(R2.GE.R2MIN) GOTO 340
72295 V(IMIN,J)=V(IMIN,J)+P(I,J)
72299 DO 380 I=N+1,N+NJET
72303 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72308 C...Find two closest jets.
72309 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
72310 DO 400 ITRY1=N+1,N+NJET-1
72311 DO 390 ITRY2=ITRY1+1,N+NJET
72312 IF(MSTU(46).LE.2) THEN
72313 R2=R2T(ITRY1,ITRY2)
72314 ELSEIF(MSTU(46).LE.4) THEN
72315 R2=R2M(ITRY1,ITRY2)
72317 R2=R2D(ITRY1,ITRY2)
72319 IF(R2.GE.R2MIN) GOTO 390
72326 C...If allowed, join two closest jets and start over.
72327 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
72328 IREC=MIN(IMIN1,IMIN2)
72329 IDEL=MAX(IMIN1,IMIN2)
72331 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
72333 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
72334 DO 430 I=IDEL+1,N+NJET
72339 IF(MSTU(46).GE.2) THEN
72340 DO 440 I=N+NP+1,N+2*NP
72342 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
72343 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
72349 C...Divide up broad jet if empty cluster in list of final ones.
72350 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
72351 DO 450 I=N+1,N+NJET
72354 DO 460 I=N+NP+1,N+2*NP
72355 K(N+K(I,4),5)=K(N+K(I,4),5)+1
72358 DO 470 I=N+1,N+NJET
72359 IF(K(I,5).EQ.0) IEMP=I
72365 DO 480 I=N+NP+1,N+2*NP
72366 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
72369 IF(R2.LE.R2MAX) GOTO 480
72376 P(IEMP,J)=P(ISPL,J)
72377 P(IJET,J)=P(IJET,J)-P(ISPL,J)
72379 P(IEMP,5)=P(ISPL,5)
72380 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
72381 IF(NLOOP.LE.2) GOTO 300
72386 C...If generalized thrust has not yet converged, continue iteration.
72387 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
72393 C...Reorder jets according to energy.
72394 DO 510 I=N+1,N+NJET
72399 DO 540 INEW=N+1,N+NJET
72401 DO 520 ITRY=N+1,N+NJET
72402 IF(V(ITRY,4).LE.PEMAX) GOTO 520
72411 P(INEW,J)=V(IMAX,J)
72417 C...Clean up particle-jet assignments and jet information.
72418 DO 550 I=N+NP+1,N+2*NP
72421 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
72422 K(IORI,4)=K(IORI,4)+1
72426 DO 570 I=N+1,N+NJET
72429 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
72433 IF(K(I,4).EQ.0) IEMP=I
72436 C...Select storing option. Output variables. Check for failure.
72442 PARU(63)=SQRT(R2MIN)
72443 IF(NJET.LE.1) PARU(63)=0D0
72445 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
72449 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
72450 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
72456 C*********************************************************************
72459 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
72460 C...as used for calorimeters at hadron colliders.
72462 SUBROUTINE PYCELL(NJET)
72464 C...Double precision and integer declarations.
72465 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72466 IMPLICIT INTEGER(I-N)
72467 INTEGER PYK,PYCHGE,PYCOMP
72468 C...Parameter statement to help give large particle numbers.
72469 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72470 &KEXCIT=4000000,KDIMEN=5000000)
72472 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72473 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72474 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72475 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72477 C...Loop over all particles. Find cell that was hit by given particle.
72478 PTLRAT=1D0/SINH(PARU(51))**2
72482 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
72483 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
72484 IF(MSTU(41).GE.2) THEN
72486 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72487 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72488 & K(I,2).EQ.KSUSY1+39) GOTO 110
72489 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72493 PT=SQRT(P(I,1)**2+P(I,2)**2)
72494 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
72495 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
72496 & (ETA/PARU(51)+1D0))))
72497 PHI=PYANGL(P(I,1),P(I,2))
72498 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
72499 & (PHI/PARU(1)+1D0))))
72500 IETPH=MSTU(52)*IETA+IPHI
72502 C...Add to cell already hit, or book new cell.
72504 IF(IETPH.EQ.K(IC,3)) THEN
72510 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
72511 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
72519 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
72520 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
72524 C...Smear true bin content by calorimeter resolution.
72525 IF(MSTU(53).GE.1) THEN
72528 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
72529 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
72530 & COS(PARU(2)*PYR(0))
72531 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
72533 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
72537 C...Remove cells below threshold.
72538 IF(PARU(58).GT.0D0) THEN
72542 IF(P(IC,5).GT.PARU(58)) THEN
72554 C...Find initiator cell: the one with highest pT of not yet used ones.
72558 IF(K(IC,5).NE.2) GOTO 160
72559 IF(P(IC,5).LE.ETMAX) GOTO 160
72565 IF(ETMAX.LT.PARU(52)) GOTO 220
72566 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
72567 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
72581 C...Sum up unused cells within required distance of initiator.
72583 IF(K(IC,5).EQ.0) GOTO 170
72584 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
72585 DPHIA=ABS(P(IC,2)-PHI)
72586 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
72588 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
72589 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
72591 K(NJ,4)=K(NJ,4)+K(IC,4)
72592 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
72593 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
72594 P(NJ,5)=P(NJ,5)+P(IC,5)
72597 C...Reject cluster below minimum ET, else accept.
72598 IF(P(NJ,5).LT.PARU(53)) THEN
72601 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
72603 ELSEIF(MSTU(54).LE.2) THEN
72604 P(NJ,3)=P(NJ,3)/P(NJ,5)
72605 P(NJ,4)=P(NJ,4)/P(NJ,5)
72606 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
72609 IF(K(IC,5).LT.0) K(IC,5)=0
72616 IF(K(IC,5).GE.0) GOTO 210
72617 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
72618 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
72619 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
72620 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
72626 C...Arrange clusters in falling ET sequence.
72627 220 DO 250 I=1,NJ-NC
72630 IF(K(IJ,5).EQ.0) GOTO 230
72631 IF(P(IJ,5).LT.ETMAX) GOTO 230
72639 K(N+I,4)=K(IJMAX,4)
72642 P(N+I,J)=P(IJMAX,J)
72648 C...Convert to massless or massive four-vectors.
72649 IF(MSTU(54).EQ.2) THEN
72650 DO 260 I=N+1,N+NJET
72652 P(I,1)=P(I,5)*COS(P(I,4))
72653 P(I,2)=P(I,5)*SIN(P(I,4))
72654 P(I,3)=P(I,5)*SINH(ETA)
72655 P(I,4)=P(I,5)*COSH(ETA)
72658 ELSEIF(MSTU(54).GE.3) THEN
72659 DO 270 I=N+1,N+NJET
72660 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
72664 C...Information about storage.
72668 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
72669 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
72674 C*********************************************************************
72677 C...Determines, approximately, the two jet masses that minimize
72678 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
72680 SUBROUTINE PYJMAS(PMH,PML)
72682 C...Double precision and integer declarations.
72683 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72684 IMPLICIT INTEGER(I-N)
72685 INTEGER PYK,PYCHGE,PYCOMP
72686 C...Parameter statement to help give large particle numbers.
72687 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72688 &KEXCIT=4000000,KDIMEN=5000000)
72690 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72691 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72692 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72693 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72695 DIMENSION SM(3,3),SAX(3),PS(3,5)
72708 PIMASS=PMAS(PYCOMP(211),1)
72710 C...Take copy of particles that are to be considered in mass analysis.
72712 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
72713 IF(MSTU(41).GE.2) THEN
72715 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72716 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72717 & K(I,2).EQ.KSUSY1+39) GOTO 170
72718 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72721 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
72722 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
72731 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
72732 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
72733 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72735 C...Fill information in sphericity tensor and total momentum vector.
72738 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
72741 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72743 PS(3,J)=PS(3,J)+P(N+NP,J)
72747 C...Very low multiplicities (0 or 1) not considered.
72749 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
72754 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
72757 C...Find largest eigenvalue to matrix (third degree equation).
72760 SM(J1,J2)=SM(J1,J2)/PSS
72763 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
72764 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
72765 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
72766 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
72767 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
72768 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
72769 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
72771 C...Find largest eigenvector by solving equation system.
72773 SM(J1,J1)=SM(J1,J1)-SMA
72775 SM(J2,J1)=SM(J1,J2)
72781 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
72784 SMAX=ABS(SM(J1,J2))
72788 DO 250 J3=JA+1,JA+2
72790 RL=SM(J1,JB)/SM(JA,JB)
72792 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
72793 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
72795 SMAX=ABS(SM(J1,J2))
72799 JB2=JB+2-3*((JB+1)/3)
72800 SAX(JB1)=-SM(JC,JB2)
72801 SAX(JB2)=SM(JC,JB1)
72802 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
72804 C...Divide particles into two initial clusters by hemisphere.
72806 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
72808 IF(PSAX.LT.0D0) IS=2
72811 PS(IS,J)=PS(IS,J)+P(I,J)
72814 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
72815 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
72817 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
72821 PS(3,J)=PS(1,J)-PS(2,J)
72824 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)
72825 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
72826 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
72827 IF(PMDI.LT.PMD) THEN
72833 C...Loop back if significant reduction in sum of m^2.
72834 IF(PMD.LT.-PARU(48)*PMS) THEN
72838 PS(IS,J)=PS(IS,J)-P(IM,J)
72839 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
72845 C...Final masses and output.
72848 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
72849 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
72850 PMH=MAX(PS(1,5),PS(2,5))
72851 PML=MIN(PS(1,5),PS(2,5))
72856 C*********************************************************************
72859 C...Calculates the first few Fox-Wolfram moments.
72861 SUBROUTINE PYFOWO(H10,H20,H30,H40)
72863 C...Double precision and integer declarations.
72864 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72865 IMPLICIT INTEGER(I-N)
72866 INTEGER PYK,PYCHGE,PYCOMP
72867 C...Parameter statement to help give large particle numbers.
72868 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72869 &KEXCIT=4000000,KDIMEN=5000000)
72871 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72872 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72873 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72874 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72876 C...Copy momenta for particles and calculate H0.
72881 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
72882 IF(MSTU(41).GE.2) THEN
72884 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72885 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72886 & K(I,2).EQ.KSUSY1+39) GOTO 110
72887 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72890 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
72891 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
72902 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72908 C...Very low multiplicities (0 or 1) not considered.
72910 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
72918 C...Calculate H1 - H4.
72924 DO 120 I2=I1+1,N+NP
72925 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
72926 & (P(I1,4)*P(I2,4))
72927 H10=H10+P(I1,4)*P(I2,4)*CTHE
72928 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
72929 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
72930 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
72935 C...Calculate H1/H0 - H4/H0. Output.
72938 H10=(HD+2D0*H10)/H0
72939 H20=(HD+2D0*H20)/H0
72940 H30=(HD+2D0*H30)/H0
72941 H40=(HD+2D0*H40)/H0
72946 C*********************************************************************
72949 C...Evaluates various properties of an event, with statistics
72950 C...accumulated during the course of the run and
72951 C...printed at the end.
72953 SUBROUTINE PYTABU(MTABU)
72955 C...Double precision and integer declarations.
72956 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72957 IMPLICIT INTEGER(I-N)
72958 INTEGER PYK,PYCHGE,PYCOMP
72959 C...Parameter statement to help give large particle numbers.
72960 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72961 &KEXCIT=4000000,KDIMEN=5000000)
72963 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72964 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72965 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72966 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
72967 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
72968 C...Local arrays, character variables, saved variables and data.
72969 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
72970 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
72971 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
72972 &KFDM(8),KFDC(200,0:8),NPDC(200)
72973 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
72974 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
72975 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
72976 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
72977 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
72978 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
72979 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
72980 &NEVDC/0/,NKFDC/0/,NREDC/0/
72982 C...Reset statistics on initial parton state.
72983 IF(MTABU.EQ.10) THEN
72987 C...Identify and order flavour content of initial state.
72988 ELSEIF(MTABU.EQ.11) THEN
72990 KFM1=2*IABS(MSTU(161))
72991 IF(MSTU(161).GT.0) KFM1=KFM1-1
72992 KFM2=2*IABS(MSTU(162))
72993 IF(MSTU(162).GT.0) KFM2=KFM2-1
72994 KFMN=MIN(KFM1,KFM2)
72995 KFMX=MAX(KFM1,KFM2)
72997 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
73000 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
73001 & KFMX.LT.KFIS(I,2))) THEN
73007 110 IF(IKFIS.LT.0) THEN
73010 IF(NKFIS.GE.100) RETURN
73011 DO 130 I=NKFIS,IKFIS,-1
73012 KFIS(I+1,1)=KFIS(I,1)
73013 KFIS(I+1,2)=KFIS(I,2)
73015 NPIS(I+1,J)=NPIS(I,J)
73025 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
73027 C...Count number of partons in initial state.
73030 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
73031 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
73032 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
73037 IF(IM.LE.0.OR.IM.GT.N) THEN
73039 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
73041 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
73042 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
73052 IF(NP.GE.11) NPCO=8
73053 IF(NP.GE.16) NPCO=9
73054 IF(NP.GE.26) NPCO=10
73055 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
73058 C...Write statistics on initial parton state.
73059 ELSEIF(MTABU.EQ.12) THEN
73060 FAC=1D0/MAX(1,NEVIS)
73061 WRITE(MSTU(11),5000) NEVIS
73064 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
73066 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
73067 CALL PYNAME(KFM1,CHAU)
73069 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
73071 IF(KFIS(I,1).EQ.0) KFMX=0
73073 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
73074 CALL PYNAME(KFM2,CHAU)
73076 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
73077 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
73078 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
73081 C...Copy statistics on initial parton state into /PYJETS/.
73082 ELSEIF(MTABU.EQ.13) THEN
73083 FAC=1D0/MAX(1,NEVIS)
73086 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
73088 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
73090 IF(KFIS(I,1).EQ.0) KFMX=0
73092 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
73099 P(I,J)=FAC*NPIS(I,J)
73100 V(I,J)=FAC*NPIS(I,J+5)
73114 C...Reset statistics on number of particles/partons.
73115 ELSEIF(MTABU.EQ.20) THEN
73122 C...Identify whether particle/parton is primary or not.
73123 ELSEIF(MTABU.EQ.21) THEN
73127 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
73128 MSTU(62)=MSTU(62)+1
73131 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
73133 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
73135 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
73137 ELSEIF(KC.EQ.0) THEN
73138 ELSEIF(K(K(I,3),1).EQ.13) THEN
73140 IF(IM.LE.0.OR.IM.GT.N) THEN
73142 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
73145 ELSEIF(KCHG(KC,2).EQ.0) THEN
73146 KCM=PYCOMP(K(K(I,3),2))
73148 IF(KCHG(KCM,2).NE.0) MPRI=1
73151 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
73152 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
73154 IF(K(I,1).LE.10) THEN
73156 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
73159 C...Fill statistics on number of particles/partons in event.
73161 KFS=3-ISIGN(1,K(I,2))-MPRI
73163 IF(KFA.EQ.KFFS(IP)) THEN
73166 ELSEIF(KFA.LT.KFFS(IP)) THEN
73172 220 IF(IKFFS.LT.0) THEN
73175 IF(NKFFS.GE.400) RETURN
73176 DO 240 IP=NKFFS,IKFFS,-1
73177 KFFS(IP+1)=KFFS(IP)
73179 NPFS(IP+1,J)=NPFS(IP,J)
73188 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
73191 C...Write statistics on particle/parton composition of events.
73192 ELSEIF(MTABU.EQ.22) THEN
73193 FAC=1D0/MAX(1,NEVFS)
73194 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
73196 CALL PYNAME(KFFS(I),CHAU)
73199 IF(KC.NE.0) MDCYF=MDCY(KC,1)
73200 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
73201 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
73204 C...Copy particle/parton composition information into /PYJETS/.
73205 ELSEIF(MTABU.EQ.23) THEN
73206 FAC=1D0/MAX(1,NEVFS)
73212 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
73214 P(I,J)=FAC*NPFS(I,J)
73234 C...Reset factorial moments statistics.
73235 ELSEIF(MTABU.EQ.30) THEN
73241 FM1FM(IM,IB,IP)=0D0
73242 FM2FM(IM,IB,IP)=0D0
73247 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
73248 ELSEIF(MTABU.EQ.31) THEN
73253 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
73254 IF(MSTU(41).GE.2) THEN
73256 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73257 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73258 & K(I,2).EQ.KSUSY1+39) GOTO 410
73259 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
73260 & PYCHGE(K(I,2)).EQ.0) GOTO 410
73263 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
73264 IF(MSTU(42).GE.2) PMR=P(I,5)
73265 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
73266 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
73268 IF(ABS(YETA).GT.PARU(57)) GOTO 410
73269 PHI=PYANGL(P(I,1),P(I,2))
73270 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
73271 IYETA=MAX(0,MIN(511,IYETA))
73272 IPHI=512D0*(PHI+PARU(1))/PARU(2)
73273 IPHI=MAX(0,MIN(511,IPHI))
73276 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
73279 C...Order particles in (pseudo)rapidity and/or azimuth.
73280 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
73281 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
73285 IF(NUPP.EQ.NLOW+1) THEN
73290 DO 350 I1=NUPP-1,NLOW+1,-1
73291 IF(IYETA.GE.K(I1,1)) GOTO 360
73294 360 K(I1+1,1)=IYETA
73295 DO 370 I1=NUPP-1,NLOW+1,-1
73296 IF(IPHI.GE.K(I1,2)) GOTO 380
73300 DO 390 I1=NUPP-1,NLOW+1,-1
73301 IF(IYEP.GE.K(I1,3)) GOTO 400
73311 C...Calculate sum of factorial moments in event.
73319 IF(IM.LE.2) IBIN=2**(10-IB)
73320 IF(IM.EQ.3) IBIN=4**(10-IB)
73321 IAGR=K(NLOW+1,IM)/IBIN
73323 DO 440 I=NLOW+2,NUPP+1
73325 IF(ICUT.EQ.IAGR) THEN
73329 ELSEIF(NAGR.EQ.2) THEN
73330 FEVFM(IB,1)=FEVFM(IB,1)+2D0
73331 ELSEIF(NAGR.EQ.3) THEN
73332 FEVFM(IB,1)=FEVFM(IB,1)+6D0
73333 FEVFM(IB,2)=FEVFM(IB,2)+6D0
73334 ELSEIF(NAGR.EQ.4) THEN
73335 FEVFM(IB,1)=FEVFM(IB,1)+12D0
73336 FEVFM(IB,2)=FEVFM(IB,2)+24D0
73337 FEVFM(IB,3)=FEVFM(IB,3)+24D0
73339 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
73340 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
73341 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
73343 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
73344 & (NAGR-3D0)*(NAGR-4D0)
73352 C...Add results to total statistics.
73355 IF(FEVFM(1,IP).LT.0.5D0) THEN
73357 ELSEIF(IM.LE.2) THEN
73358 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
73360 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
73362 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
73363 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
73367 NMUFM=NMUFM+(NUPP-NLOW)
73370 C...Write accumulated statistics on factorial moments.
73371 ELSEIF(MTABU.EQ.32) THEN
73372 FAC=1D0/MAX(1,NEVFM)
73373 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
73374 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
73375 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
73377 WRITE(MSTU(11),5500)
73380 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
73382 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
73383 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
73384 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
73386 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
73387 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
73390 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
73395 C...Copy statistics on factorial moments into /PYJETS/.
73396 ELSEIF(MTABU.EQ.33) THEN
73397 FAC=1D0/MAX(1,NEVFM)
73404 IF(IM.NE.2) K(I,3)=2**(IB-1)
73406 IF(IM.NE.1) K(I,4)=2**(IB-1)
73408 P(I,1)=2D0*PARU(57)/K(I,3)
73409 V(I,1)=PARU(2)/K(I,4)
73411 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
73412 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
73428 C...Reset statistics on Energy-Energy Correlation.
73429 ELSEIF(MTABU.EQ.40) THEN
73440 C...Find particles to include, with proper assumed mass.
73441 ELSEIF(MTABU.EQ.41) THEN
73447 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
73448 IF(MSTU(41).GE.2) THEN
73450 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73451 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73452 & K(I,2).EQ.KSUSY1+39) GOTO 570
73453 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
73454 & PYCHGE(K(I,2)).EQ.0) GOTO 570
73457 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
73458 IF(MSTU(42).GE.2) PMR=P(I,5)
73459 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
73460 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
73467 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
73468 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
73471 IF(NUPP.EQ.NLOW) RETURN
73473 C...Analyze Energy-Energy Correlation in event.
73474 FAC=(2D0/ECM**2)*50D0/PARU(1)
73478 DO 600 I1=NLOW+2,NUPP
73479 DO 590 I2=NLOW+1,I1-1
73480 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
73481 & (P(I1,5)*P(I2,5))
73482 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
73483 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
73484 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
73488 FE1EC(J)=FE1EC(J)+FEVEE(J)
73489 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
73490 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
73491 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
73492 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
73493 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
73497 C...Write statistics on Energy-Energy Correlation.
73498 ELSEIF(MTABU.EQ.42) THEN
73499 FAC=1D0/MAX(1,NEVEE)
73500 WRITE(MSTU(11),5700) NEVEE
73503 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
73504 FEEC2=FAC*FE1EC(51-J)
73505 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
73507 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
73508 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
73509 & FEEC2,FEES2,FEECA,FEESA
73512 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
73513 ELSEIF(MTABU.EQ.43) THEN
73514 FAC=1D0/MAX(1,NEVEE)
73521 P(I,1)=FAC*FE1EC(I)
73522 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
73523 P(I,2)=FAC*FE1EC(51-I)
73524 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
73525 P(I,3)=FAC*FE1EA(I)
73526 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
73527 P(I,4)=PARU(1)*(I-1)/50D0
73528 P(I,5)=PARU(1)*I/50D0
73543 C...Reset statistics on decay channels.
73544 ELSEIF(MTABU.EQ.50) THEN
73549 C...Identify and order flavour content of final state.
73550 ELSEIF(MTABU.EQ.51) THEN
73554 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
73561 IF(K(I,2).LT.0) KFM=KFM-1
73562 DO 650 IDS=NDS-1,1,-1
73564 IF(KFM.LT.KFDM(IDS)) GOTO 660
73565 KFDM(IDS+1)=KFDM(IDS)
73571 C...Find whether old or new final state.
73573 IF(NDS.LT.KFDC(IDC,0)) THEN
73576 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
73578 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
73581 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
73590 700 IF(IKFDC.LT.0) THEN
73592 ELSEIF(NKFDC.GE.200) THEN
73596 DO 720 IDC=NKFDC,IKFDC,-1
73597 NPDC(IDC+1)=NPDC(IDC)
73599 KFDC(IDC+1,I)=KFDC(IDC,I)
73605 KFDC(IKFDC,I)=KFDM(I)
73609 NPDC(IKFDC)=NPDC(IKFDC)+1
73611 C...Write statistics on decay channels.
73612 ELSEIF(MTABU.EQ.52) THEN
73613 FAC=1D0/MAX(1,NEVDC)
73614 WRITE(MSTU(11),5900) NEVDC
73616 DO 740 I=1,KFDC(IDC,0)
73619 IF(2*KF.NE.KFM) KF=-KF
73620 CALL PYNAME(KF,CHAU)
73622 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
73624 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
73626 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
73628 C...Copy statistics on decay channels into /PYJETS/.
73629 ELSEIF(MTABU.EQ.53) THEN
73630 FAC=1D0/MAX(1,NEVDC)
73636 K(IDC,5)=KFDC(IDC,0)
73641 DO 770 I=1,KFDC(IDC,0)
73644 IF(2*KF.NE.KFM) KF=-KF
73645 IF(I.LE.5) P(IDC,I)=KF
73646 IF(I.GE.6) V(IDC,I-5)=KF
73648 V(IDC,5)=FAC*NPDC(IDC)
73663 C...Format statements for output on unit MSTU(11) (default 6).
73664 5000 FORMAT(///20X,'Event statistics - initial state'/
73665 &20X,'based on an analysis of ',I6,' events'//
73666 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
73667 &'according to fragmenting system multiplicity'/
73668 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
73669 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
73670 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
73671 5200 FORMAT(///20X,'Event statistics - final state'/
73672 &20X,'based on an analysis of ',I7,' events'//
73673 &5X,'Mean primary multiplicity =',F10.4/
73674 &5X,'Mean final multiplicity =',F10.4/
73675 &5X,'Mean charged multiplicity =',F10.4//
73676 &5X,'Number of particles produced per event (directly and via ',
73677 &'decays/branchings)'/
73678 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
73679 &8X,'Total'/35X,'prim seco prim seco'/)
73680 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
73681 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
73682 &20X,'based on an analysis of ',I6,' events'//
73683 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
73684 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
73686 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
73687 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
73688 &20X,'based on an analysis of ',I6,' events'//
73689 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
73690 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
73691 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
73692 5900 FORMAT(///20X,'Decay channel analysis - final state'/
73693 &20X,'based on an analysis of ',I6,' events'//
73694 &2X,'Probability',10X,'Complete final state'/)
73695 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
73696 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
73697 &'or table overflow)')
73702 C*********************************************************************
73705 C...Handles the generation of an e+e- annihilation jet event.
73707 SUBROUTINE PYEEVT(KFL,ECM)
73709 C...Double precision and integer declarations.
73710 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73711 IMPLICIT INTEGER(I-N)
73712 INTEGER PYK,PYCHGE,PYCOMP
73714 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73715 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73716 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73717 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
73719 C...Check input parameters.
73720 IF(MSTU(12).NE.12345) CALL PYLIST(0)
73721 IF(KFL.LT.0.OR.KFL.GT.8) THEN
73722 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
73723 IF(MSTU(21).GE.1) RETURN
73725 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
73726 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
73727 IF(ECM.LT.ECMMIN) THEN
73728 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
73729 IF(MSTU(21).GE.1) RETURN
73732 C...Check consistency of MSTJ options set.
73733 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
73735 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
73738 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
73740 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
73744 C...Initialize alpha_strong and total cross-section.
73745 MSTU(111)=MSTJ(108)
73746 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
73748 PARU(112)=PARJ(121)
73749 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
73750 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
73751 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
73753 IF(MSTJ(116).GE.3) MSTJ(116)=1
73756 C...Add initial e+e- to event record (documentation only).
73759 IF(NTRY.GT.100) THEN
73760 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
73765 IF(MSTJ(115).GE.2) THEN
73767 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
73769 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
73773 C...Radiative photon (in initial state).
73776 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
73778 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
73779 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
73781 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
73782 K(NC,3)=MIN(MSTJ(115)/2,1)
73785 C...Virtual exchange boson (gamma or Z0).
73786 IF(MSTJ(115).GE.3) THEN
73789 IF(MSTJ(102).EQ.2) KF=23
73793 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
73799 C...Choice of flavour and jet configuration.
73800 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
73801 IF(KFLC.EQ.0) GOTO 100
73802 CALL PYXJET(ECMC,NJET,CUT)
73804 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
73806 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
73807 IF(NJET.EQ.2) MSTJ(120)=1
73809 C...Fill jet configuration and origin.
73810 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
73811 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
73813 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
73814 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
73815 &-KFLC,ECMC,X1,X2,X4,X12,X14)
73816 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
73817 &-KFLC,ECMC,X1,X2,X4,X12,X14)
73818 IF(MSTU(24).NE.0) GOTO 100
73820 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
73823 C...Angular orientation according to matrix element.
73824 IF(MSTJ(106).EQ.1) THEN
73825 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
73826 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
73827 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
73830 C...Rotation and boost from radiative photon.
73832 DBEK=-PAK/(ECM-PAK)
73833 NMIN=NC+1-MSTJ(115)/3
73834 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
73835 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
73836 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
73839 C...Generate parton shower. Rearrange along strings and check.
73840 IF(MSTJ(101).EQ.5) THEN
73841 if(parj(200).ne.1.) CALL PYSHOW(N-1,N,ECMC)
73842 if(parj(200).eq.1.) CALL PYSHOWQ(N-1,N,ECMC)
73844 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
73845 IF(MSTJ(105).GE.0) MSTU(28)=0
73848 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
73851 C...Fragmentation/decay generation. Information for PYTABU.
73852 IF(MSTJ(105).EQ.1) CALL PYEXEC
73859 C*********************************************************************
73862 C...Calculates total cross-section, including initial state
73863 C...radiation effects.
73865 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
73867 C...Double precision and integer declarations.
73868 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73869 IMPLICIT INTEGER(I-N)
73870 INTEGER PYK,PYCHGE,PYCOMP
73872 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73873 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73874 SAVE /PYDAT1/,/PYDAT2/
73876 C...Status, (optimized) Q^2 scale, alpha_strong.
73878 MSTJ(119)=10*MSTJ(102)+KFL
73879 IF(MSTJ(111).EQ.0) THEN
73881 ELSEIF(MSTU(111).EQ.0) THEN
73882 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
73883 & ((33D0-2D0*MSTU(112))*PARU(111)))))
73884 Q2R=PARJ(168)*ECM**2
73886 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
73887 & (2D0*PARU(112)/ECM)**2))
73888 Q2R=PARJ(168)*ECM**2
73890 ALSPI=PYALPS(Q2R)/PARU(1)
73892 C...QCD corrections factor in R.
73893 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
73895 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
73897 ELSEIF(MSTJ(109).EQ.0) THEN
73898 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
73899 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
73900 & LOG(PARJ(168))*ALSPI**2)
73901 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
73902 RQCD=1D0+(3D0/4D0)*ALSPI
73904 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
73907 C...Calculate Z0 width if default value not acceptable.
73908 IF(MSTJ(102).GE.3) THEN
73909 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
73910 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
73913 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
73914 & (2D0*PYMASS(KFLC)/ ECM)**2))
73915 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
73916 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
73917 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
73919 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
73923 C...Calculate propagator and related constants for QFD case.
73924 POLL=1D0-PARJ(131)*PARJ(132)
73925 IF(MSTJ(102).GE.2) THEN
73926 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
73927 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
73928 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
73929 VE=4D0*PARU(102)-1D0
73930 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
73931 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
73936 C...Loop over different flavours: charge, velocity.
73941 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
73942 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
73945 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
73946 QF=KCHG(KFLC,1)/3D0
73948 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
73950 C...Calculate R and sum of charges for QED or QFD case.
73951 RQQ=RQQ+3D0*QF**2*POLL
73952 IF(MSTJ(102).LE.1) THEN
73953 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
73955 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
73956 RQV=RQV-6D0*QF*VF*SF1I
73957 RVA=RVA+3D0*(VF**2+1D0)*SF1W
73958 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
73959 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
73963 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
73965 C...Calculate cross-section, including QCD corrections.
73968 PARJ(143)=RTOT*RQCD
73969 PARJ(144)=PARJ(143)
73970 PARJ(145)=PARJ(141)*86.8D0/ECM**2
73971 PARJ(146)=PARJ(142)*86.8D0/ECM**2
73972 PARJ(147)=PARJ(143)*86.8D0/ECM**2
73973 PARJ(148)=PARJ(147)
73974 PARJ(157)=RSUM*RQCD
73978 IF(MSTJ(107).LE.0) RETURN
73980 C...Virtual cross-section.
73982 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
73983 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
73984 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
73985 &1.526D0*LOG(ECM**2/0.932D0)
73987 C...Soft and hard radiative cross-section in QED case.
73988 IF(MSTJ(102).LE.1) THEN
73989 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
73990 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
73991 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
73993 C...Soft and hard radiative cross-section in QFD case.
73995 SZM=1D0-(PARJ(123)/ECM)**2
73996 SZW=PARJ(123)*PARJ(124)/ECM**2
73997 PARJ(161)=-RQQ/RSUM
73998 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
73999 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
74000 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
74001 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
74002 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
74003 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
74004 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
74005 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
74006 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
74007 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
74008 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
74009 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
74010 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
74013 C...Total cross-section and fraction of hard photon events.
74014 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
74015 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
74016 PARJ(144)=PARJ(157)
74017 PARJ(148)=PARJ(144)*86.8D0/ECM**2
74023 C*********************************************************************
74026 C...Generates initial state photon radiation.
74028 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
74030 C...Double precision and integer declarations.
74031 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74032 IMPLICIT INTEGER(I-N)
74033 INTEGER PYK,PYCHGE,PYCOMP
74035 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74038 C...Function: cumulative hard photon spectrum in QFD case.
74039 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
74040 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
74042 C...Determine whether radiative photon or not.
74045 IF(PARJ(160).LT.PYR(0)) RETURN
74048 C...Photon energy range. Find photon momentum in QED case.
74050 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
74051 IF(MSTJ(102).LE.1) THEN
74052 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
74053 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
74055 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
74057 SZM=1D0-(PARJ(123)/ECM)**2
74058 SZW=PARJ(123)*PARJ(124)/ECM**2
74061 FXKD=1D-4*(FXKU-FXKL)
74062 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
74067 IF(FXKV.GT.FXKR) THEN
74074 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
74075 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
74079 C...Photon polar and azimuthal angle.
74080 PME=2D0*(PYMASS(11)/ECM)**2
74081 120 CTHM=PME*(2D0/PME)**PYR(0)
74082 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
74083 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
74085 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
74086 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
74087 THEK=PYANGL(CTHE,STHE)
74088 PHIK=PARU(2)*PYR(0)
74090 C...Rotation angle for hadronic system.
74092 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
74094 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
74095 &(2D0-XK*(1D0-SGN*CTHE)))
74100 C*********************************************************************
74103 C...Selects flavour for produced qqbar pair.
74105 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
74107 C...Double precision and integer declarations.
74108 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74109 IMPLICIT INTEGER(I-N)
74110 INTEGER PYK,PYCHGE,PYCOMP
74112 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74113 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74114 SAVE /PYDAT1/,/PYDAT2/
74116 C...Calculate maximum weight in QED or QFD case.
74117 IF(MSTJ(102).LE.1) THEN
74120 POLL=1D0-PARJ(131)*PARJ(132)
74121 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
74122 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
74123 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
74124 VE=4D0*PARU(102)-1D0
74125 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
74126 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
74127 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
74128 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
74129 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
74133 C...Choose flavour. Gives charge and velocity.
74136 IF(NTRY.GT.100) THEN
74137 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
74142 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
74145 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
74146 QF=KCHG(KFLC,1)/3D0
74148 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
74150 C...Calculate weight in QED or QFD case.
74151 IF(MSTJ(102).LE.1) THEN
74153 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
74155 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
74156 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
74157 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
74159 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
74162 C...Weighting or new event (radiative photon). Cross-section update.
74163 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
74164 PARJ(158)=PARJ(158)+1D0
74165 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
74166 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
74167 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
74168 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
74169 PARJ(148)=PARJ(144)*86.8D0/ECM**2
74174 C*********************************************************************
74177 C...Selects number of jets in matrix element approach.
74179 SUBROUTINE PYXJET(ECM,NJET,CUT)
74181 C...Double precision and integer declarations.
74182 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74183 IMPLICIT INTEGER(I-N)
74184 INTEGER PYK,PYCHGE,PYCOMP
74186 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74188 C...Local array and data.
74190 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
74192 C...Trivial result for two-jets only, including parton shower.
74193 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
74196 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
74197 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
74199 IF(MSTJ(109).EQ.2) CF=1D0
74200 IF(MSTJ(111).EQ.0) THEN
74203 ELSEIF(MSTU(111).EQ.0) THEN
74204 PARJ(169)=MIN(1D0,PARJ(129))
74205 Q2=PARJ(169)*ECM**2
74206 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
74207 & ((33D0-2D0*MSTU(112))*PARU(111)))))
74208 Q2R=PARJ(168)*ECM**2
74210 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
74211 Q2=PARJ(169)*ECM**2
74212 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
74213 & (2D0*PARU(112)/ECM)**2))
74214 Q2R=PARJ(168)*ECM**2
74217 C...alpha_strong for R and R itself.
74218 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
74219 IF(IABS(MSTJ(101)).EQ.1) THEN
74221 ELSEIF(MSTJ(109).EQ.0) THEN
74222 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
74223 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
74224 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
74226 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
74229 C...alpha_strong for jet rate. Initial value for y cut.
74230 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
74231 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
74232 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
74233 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
74234 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
74236 C...Parametrization of first order three-jet cross-section.
74237 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
74240 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
74241 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
74242 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
74243 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
74244 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
74248 C...Parametrization of second order three-jet cross-section.
74249 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
74250 & CUT.GE.0.25D0) THEN
74252 ELSEIF(MSTJ(110).LE.1) THEN
74253 CT=LOG(1D0/CUT-2D0)
74254 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
74255 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
74257 C...Interpolation in second/first order ratio for Zhu parametrization.
74258 ELSEIF(MSTJ(110).EQ.2) THEN
74261 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
74267 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
74269 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
74272 C...Shift in second order three-jet cross-section with optimized Q^2.
74273 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
74274 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
74275 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
74277 C...Parametrization of second order four-jet cross-section.
74278 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
74281 CT=LOG(1D0/CUT-5D0)
74282 IF(CUT.LE.0.018D0) THEN
74283 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
74284 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
74286 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
74287 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
74289 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
74290 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
74291 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
74292 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
74293 & 0.002093D0*CT**3)
74294 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
74296 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
74297 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
74300 C...If negative three-jet rate, change y' optimization parameter.
74301 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
74302 & PARJ(169).LT.0.99D0) THEN
74303 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
74304 Q2=PARJ(169)*ECM**2
74305 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
74309 C...If too high cross-section, use harder cuts, or fail.
74310 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
74311 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
74312 & PARJ(169).LT.0.99D0) THEN
74313 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
74314 Q2=PARJ(169)*ECM**2
74315 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
74317 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
74319 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
74321 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
74322 & PARJ(154))**(-1D0/3D0)
74323 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
74327 C...Scalar gluon (first order only).
74329 ALSPI=PYALPS(ECM**2)/PARU(1)
74330 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
74332 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
74333 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
74338 C...Select number of jets.
74340 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
74342 ELSEIF(MSTJ(101).LE.0) THEN
74343 NJET=MIN(4,2-MSTJ(101))
74347 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
74348 IF(PARJ(154).GT.RNJ) NJET=4
74354 C*********************************************************************
74357 C...Selects the kinematical variables of three-jet events.
74359 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
74361 C...Double precision and integer declarations.
74362 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74363 IMPLICIT INTEGER(I-N)
74364 INTEGER PYK,PYCHGE,PYCOMP
74366 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74369 DIMENSION ZHUP(5,12)
74371 C...Coefficients of Zhu second order parametrization.
74372 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
74373 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
74374 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
74375 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
74376 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
74377 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
74378 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
74379 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
74380 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
74381 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
74382 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
74384 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
74385 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
74388 C...Event type. Mass effect factors and other common constants.
74392 QME=(2D0*PMQ/ECM)**2
74393 IF(MSTJ(109).NE.1) THEN
74395 CUTD=LOG(1D0/CUT-2D0)
74396 IF(MSTJ(109).EQ.0) THEN
74400 WTMX=MIN(20D0,37D0-6D0*CUTD)
74401 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
74409 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
74410 ALS2PI=PARU(118)/PARU(2)
74412 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
74413 & LOG(PARJ(169))*ALS2PI
74414 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
74416 C...Choose three-jet events in allowed region.
74418 110 Y13L=CUTL+CUTD*PYR(0)
74419 Y23L=CUTL+CUTD*PYR(0)
74423 IF(Y12.LE.CUT) GOTO 110
74424 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
74426 C...Second order corrections.
74427 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
74432 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
74433 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
74434 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
74435 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
74436 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
74437 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
74438 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
74439 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
74440 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
74441 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
74442 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
74443 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
74444 & TR*(2D0*CUTL/3D0-10D0/9D0)+
74445 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
74446 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
74447 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
74448 & Y13*Y23)/(Y12+Y13)**2)/WT1+
74449 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
74450 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
74451 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
74452 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
74453 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
74454 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
74455 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
74456 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
74457 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
74458 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
74460 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
74461 C...Second order corrections; Zhu parametrization of ERT.
74466 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
74470 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
74471 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
74472 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
74473 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
74476 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
74477 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
74478 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
74479 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
74481 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
74482 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
74483 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
74484 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
74485 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
74487 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
74488 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
74489 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
74492 C...Impose mass cuts (gives two jets). For fixed jet number new try.
74496 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
74497 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
74498 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
74499 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
74500 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
74502 C...Scalar gluon model (first order only, no mass effects).
74505 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
74506 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
74507 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
74508 X1=1D0-0.5D0*(X3+YD)
74509 X2=1D0-0.5D0*(X3-YD)
74510 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
74511 IF(MSTJ(102).GE.2) THEN
74512 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
74513 & X3**2*PYR(0)) NJET=2
74515 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
74521 C*********************************************************************
74524 C...Selects the kinematical variables of four-jet events.
74526 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
74528 C...Double precision and integer declarations.
74529 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74530 IMPLICIT INTEGER(I-N)
74531 INTEGER PYK,PYCHGE,PYCOMP
74533 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74536 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
74538 C...Common constants. Colour factors for QCD and Abelian gluon theory.
74540 QME=(2D0*PMQ/ECM)**2
74541 CT=LOG(1D0/CUT-5D0)
74542 IF(MSTJ(109).EQ.0) THEN
74552 C...Choice of process (qqbargg or qqbarqqbar).
74555 IF(PARJ(155).GT.PYR(0)) IT=2
74556 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
74557 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
74558 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
74559 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
74562 C...Sample the five kinematical variables (for qqgg preweighted in y34).
74563 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
74564 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
74565 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
74566 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
74567 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
74569 CP=COS(PARU(1)*PYR(0))
74572 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
74573 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
74574 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
74576 Y12=1D0-Y134-Y23-Y24
74577 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
74581 C...Calculate matrix elements for qqgg or qqqq process.
74586 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
74587 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
74588 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
74589 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
74590 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
74591 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
74592 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
74593 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
74594 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
74595 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
74596 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
74597 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
74598 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
74599 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
74600 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
74601 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
74602 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
74603 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
74604 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
74605 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
74606 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
74607 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
74608 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
74609 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
74610 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
74611 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
74612 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
74613 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
74614 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
74615 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
74616 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
74617 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
74618 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
74619 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
74620 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
74621 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
74622 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
74623 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
74624 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
74625 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
74626 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
74629 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
74630 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
74631 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
74632 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
74633 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
74634 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
74635 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
74636 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
74637 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
74638 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
74639 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
74640 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
74641 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
74642 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
74643 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
74644 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
74645 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
74646 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
74649 C...Permutations of momenta in matrix element. Weighting.
74650 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
74661 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
74672 IF(IC.LE.3) GOTO 120
74673 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
74676 C...qqgg events: string configuration and event type.
74678 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
74679 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
74680 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
74681 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
74682 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
74683 IF(ID.EQ.2) GOTO 130
74684 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
74685 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
74686 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
74687 IF(ID.EQ.2) GOTO 130
74690 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
74691 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
74694 C...Mass cuts. Kinematical variables out.
74695 IF(Y12.LE.CUT+QME) NJET=2
74696 IF(NJET.EQ.2) GOTO 150
74697 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
74698 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
74699 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
74701 X12=(1D0-Q12)*Y13+Q12*Y23
74703 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
74705 C...qqbarqqbar events: string configuration, choose new flavour.
74708 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
74709 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
74710 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
74711 IF(WTR.LT.WTD(4)) ID=4
74712 IF(ID.GE.2) GOTO 130
74715 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
74716 140 KFLN=1+INT(5D0*PYR(0))
74717 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
74718 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
74719 IF(KFLN.GT.MSTJ(104)) NJET=2
74721 QMEN=(2D0*PMQN/ECM)**2
74723 C...Mass cuts. Kinematical variables out.
74724 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
74725 IF(NJET.EQ.2) GOTO 150
74726 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
74727 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
74728 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
74729 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
74730 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
74731 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
74734 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
74736 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
74737 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
74738 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
74740 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
74745 C*********************************************************************
74748 C...Gives the angular orientation of events.
74750 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
74752 C...Double precision and integer declarations.
74753 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74754 IMPLICIT INTEGER(I-N)
74755 INTEGER PYK,PYCHGE,PYCOMP
74757 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74758 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74759 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74760 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74762 C...Charge. Factors depending on polarization for QED case.
74764 POLL=1D0-PARJ(131)*PARJ(132)
74765 POLD=PARJ(132)-PARJ(131)
74766 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
74772 C...Factors depending on flavour, energy and polarization for QFD case.
74774 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
74775 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
74776 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
74778 VE=4D0*PARU(102)-1D0
74780 VF=AF-4D0*QF*PARU(102)
74781 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
74782 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
74783 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
74784 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
74785 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
74786 & SFW*SFF**2*(VE**2-AE**2))
74787 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
74791 C...Mass factor. Differential cross-sections for two-jet events.
74794 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
74795 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
74797 SIGU=4D0*SQRT(1D0-QME)
74798 SIGL=2D0*QME*SQRT(1D0-QME)
74804 C...Kinematical variables. Reduce four-jet event to three-jet one.
74807 X1=2D0*P(NC+1,4)/ECM
74808 X2=2D0*P(NC+3,4)/ECM
74810 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
74811 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
74812 X1=2D0*P(NC+1,4)/ECMR
74813 X2=2D0*P(NC+4,4)/ECMR
74816 C...Differential cross-sections for three-jet (or reduced four-jet).
74817 XQ=(1D0-X1)/(1D0-X2)
74818 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
74819 ST12=SQRT(1D0-CT12**2)
74820 IF(MSTJ(109).NE.1) THEN
74821 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
74822 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
74823 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
74824 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
74826 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
74827 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
74828 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
74829 SIGA=X2**2*ST12/SQ2
74830 SIGP=2D0*(X1**2-X2**2*CT12)
74832 C...Differential cross-sect for scalar gluons (no mass effects).
74836 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
74837 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
74838 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
74839 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
74840 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
74841 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
74842 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
74843 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
74844 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
74845 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
74846 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
74850 C...Upper bounds for differential cross-section.
74855 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
74856 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
74857 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
74858 &2D0*HF2A*ABS(SIGP)
74860 C...Generate angular orientation according to differential cross-sect.
74861 100 CHI=PARU(2)*PYR(0)
74862 CTHE=2D0*PYR(0)-1D0
74870 C2PHI=COS(2D0*(PHI-PARJ(134)))
74871 S2PHI=SIN(2D0*(PHI-PARJ(134)))
74872 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
74873 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
74874 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
74875 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
74876 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
74877 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
74878 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
74879 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
74884 C*********************************************************************
74887 C...Generates Upsilon and toponium decays into three gluons
74888 C...or two gluons and a photon.
74890 SUBROUTINE PYONIA(KFL,ECM)
74892 C...Double precision and integer declarations.
74893 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74894 IMPLICIT INTEGER(I-N)
74895 INTEGER PYK,PYCHGE,PYCOMP
74897 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74898 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74899 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74900 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74902 C...Printout. Check input parameters.
74903 IF(MSTU(12).NE.12345) CALL PYLIST(0)
74904 IF(KFL.LT.0.OR.KFL.GT.8) THEN
74905 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
74906 IF(MSTU(21).GE.1) RETURN
74908 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
74909 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
74910 IF(MSTU(21).GE.1) RETURN
74913 C...Initial e+e- and onium state (optional).
74915 IF(MSTJ(115).GE.2) THEN
74917 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
74919 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
74923 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
74929 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
74935 C...Choose x1 and x2 according to matrix element.
74940 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
74941 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
74944 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
74945 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
74947 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
74948 MSTU(111)=MSTJ(108)
74949 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
74951 PARU(112)=PARJ(121)
74952 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
74954 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
74955 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
74958 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
74959 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
74961 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
74962 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
74965 ECMC=SQRT(1D0-X1)*ECM
74966 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
74971 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
74972 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
74973 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
74974 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
74976 IF(ECMC.LT.4D0*PARJ(127)) THEN
74980 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
74986 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
74989 C...Differential cross-sections. Upper limit for cross-section.
74990 IF(MSTJ(106).EQ.1) THEN
74992 HF1=1D0-PARJ(131)*PARJ(132)
74994 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
74995 ST13=SQRT(1D0-CT13**2)
74996 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
74997 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
74999 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
75000 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
75001 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
75003 C...Angular orientation of event.
75004 120 CHI=PARU(2)*PYR(0)
75005 CTHE=2D0*PYR(0)-1D0
75013 C2PHI=COS(2D0*(PHI-PARJ(134)))
75014 S2PHI=SIN(2D0*(PHI-PARJ(134)))
75015 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
75016 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
75017 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
75018 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
75019 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
75020 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
75021 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
75022 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
75025 C...Generate parton shower. Rearrange along strings and check.
75026 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
75027 if(parj(200).ne.1.) CALL PYSHOW(NC+MK+1,-NJET,ECMC)
75028 if(parj(200).eq.1.) CALL PYSHOWQ(NC+MK+1,-NJET,ECMC)
75030 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
75031 IF(MSTJ(105).GE.0) MSTU(28)=0
75034 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
75037 C...Generate fragmentation. Information for PYTABU:
75038 IF(MSTJ(105).EQ.1) CALL PYEXEC
75039 MSTU(161)=110*KFLC+3
75045 C*********************************************************************
75048 C...Books a histogram.
75050 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
75052 C...Double precision declaration.
75053 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75054 IMPLICIT INTEGER(I-N)
75056 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75058 C...Local character variables.
75059 CHARACTER TITLE*(*), TITFX*60
75061 C...Check that input is sensible. Find initial address in memory.
75062 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
75063 &'(PYBOOK:) not allowed histogram number')
75064 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
75065 &'(PYBOOK:) not allowed number of bins')
75066 IF(XL.GE.XU) CALL PYERRM(28,
75067 &'(PYBOOK:) x limits in wrong order')
75069 IHIST(4)=IHIST(4)+28+NX
75070 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
75071 &'(PYBOOK:) out of histogram space')
75074 C...Store histogram size and reset contents.
75078 BIN(IS+4)=(XU-XL)/NX
75081 C...Store title by conversion to integer to double precision.
75084 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
75085 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
75091 C*********************************************************************
75094 C...Fills entry in histogram.
75096 SUBROUTINE PYFILL(ID,X,W)
75098 C...Double precision declaration.
75099 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75100 IMPLICIT INTEGER(I-N)
75102 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75105 C...Find initial address in memory. Increase number of entries.
75106 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
75107 &'(PYFILL:) not allowed histogram number')
75109 IF(IS.EQ.0) CALL PYERRM(28,
75110 &'(PYFILL:) filling unbooked histogram')
75111 BIN(IS+5)=BIN(IS+5)+1D0
75113 C...Find bin in x, including under/overflow, and fill.
75114 IF(X.LT.BIN(IS+2)) THEN
75115 BIN(IS+6)=BIN(IS+6)+W
75116 ELSEIF(X.GE.BIN(IS+3)) THEN
75117 BIN(IS+8)=BIN(IS+8)+W
75119 BIN(IS+7)=BIN(IS+7)+W
75120 IX=(X-BIN(IS+2))/BIN(IS+4)
75121 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
75122 BIN(IS+9+IX)=BIN(IS+9+IX)+W
75128 C*********************************************************************
75131 C...Multiplies histogram contents by factor.
75133 SUBROUTINE PYFACT(ID,F)
75135 C...Double precision declaration.
75136 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75137 IMPLICIT INTEGER(I-N)
75139 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75142 C...Find initial address in memory. Multiply all contents bins.
75143 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
75144 &'(PYFACT:) not allowed histogram number')
75146 IF(IS.EQ.0) CALL PYERRM(28,
75147 &'(PYFACT:) scaling unbooked histogram')
75148 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
75155 C*********************************************************************
75158 C...Performs operations between histograms.
75160 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
75162 C...Double precision declaration.
75163 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75164 IMPLICIT INTEGER(I-N)
75166 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75168 C...Character variable.
75171 C...Find initial addresses in memory, and histogram size.
75172 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
75173 &'(PYFACT:) not allowed histogram number')
75175 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
75176 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
75177 NX=NINT(BIN(IS3+1))
75178 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
75180 C...Update info on number of histogram entries.
75181 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
75182 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
75183 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
75184 BIN(IS3+5)=BIN(IS1+5)
75187 C...Operations on pair of histograms: addition, subtraction,
75188 C...multiplication, division.
75189 IF(OPER.EQ.'+') THEN
75191 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
75193 ELSEIF(OPER.EQ.'-') THEN
75195 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
75197 ELSEIF(OPER.EQ.'*') THEN
75199 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
75201 ELSEIF(OPER.EQ.'/') THEN
75204 IF(ABS(FA2).LE.1D-20) THEN
75207 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
75211 C...Operations on single histogram: multiplication+addition,
75212 C...square root+addition, logarithm+addition.
75213 ELSEIF(OPER.EQ.'A') THEN
75215 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
75217 ELSEIF(OPER.EQ.'S') THEN
75219 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
75221 ELSEIF(OPER.EQ.'L') THEN
75224 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
75225 & ZMIN=0.8D0*BIN(IS1+IX)
75228 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
75231 C...Operation on two or three histograms: average and
75232 C...standard deviation.
75233 ELSEIF(OPER.EQ.'M') THEN
75235 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
75238 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
75241 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
75244 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
75248 BIN(IS1+IX)=F1*BIN(IS1+IX)
75255 C*********************************************************************
75258 C...Prints and resets all histograms.
75262 C...Double precision declaration.
75263 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75264 IMPLICIT INTEGER(I-N)
75266 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75269 C...Loop over histograms, print and reset used ones.
75270 DO 100 ID=1,IHIST(1)
75272 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
75281 C*********************************************************************
75284 C...Prints a histogram (but does not reset it).
75286 SUBROUTINE PYPLOT(ID)
75288 C...Double precision declaration.
75289 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75290 IMPLICIT INTEGER(I-N)
75292 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75293 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75294 SAVE /PYDAT1/,/PYBINS/
75295 C...Local arrays and character variables.
75296 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
75297 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
75299 C...Steps in histogram scale. Character sequence.
75300 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
75301 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
75303 C...Find initial address in memory; skip if empty histogram.
75304 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
75307 IF(NINT(BIN(IS+5)).LE.0) THEN
75308 WRITE(MSTU(11),5000) ID
75312 C...Number of histogram lines and x bins.
75316 C...Extract title by conversion from double precision via integer.
75318 IEQ=NINT(BIN(IS+8+NX+IT))
75319 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
75320 & //CHAR(MOD(IEQ,256))
75323 C...Find time; print title.
75325 IF(IDATI(1).GT.0) THEN
75326 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
75328 WRITE(MSTU(11),5200) ID, TITLE
75331 C...Find minimum and maximum bin content.
75334 DO 110 IX=IS+10,IS+8+NX
75335 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
75336 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
75339 C...Determine scale and step size for y axis.
75340 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
75341 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
75342 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
75343 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
75344 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
75345 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
75348 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
75352 C...Convert bin contents to integer form; fractional fill in top row.
75354 CTA=ABS(BIN(IS+8+IX))/DY
75355 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
75356 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
75358 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
75359 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
75361 C...Print histogram row by row.
75362 DO 150 IR=IRMA,IRMI,-1
75363 IF(IR.EQ.0) GOTO 150
75366 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
75367 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
75369 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
75372 C...Print sign and value of bin contents.
75373 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
75376 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
75377 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
75379 WRITE(MSTU(11),5400) OUT
75382 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
75384 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
75387 C...Print sign and value of lower bin edge.
75388 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
75392 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
75393 & OUT(IX:IX)=CHA(11)
75394 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
75396 WRITE(MSTU(11),5600) OUT
75399 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
75401 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
75405 C...Calculate and print statistics.
75410 CTA=ABS(BIN(IS+8+IX))
75411 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
75414 CXXSUM=CXXSUM+CTA*X**2
75416 XMEAN=CXSUM/MAX(CSUM,1D-20)
75417 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
75418 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
75419 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
75421 C...Formats for output.
75422 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
75423 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
75425 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
75426 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
75427 5400 FORMAT(/8X,'Contents',3X,A100)
75428 5500 FORMAT(9X,'*10**',I2,3X,A100)
75429 5600 FORMAT(/8X,'Low edge',3X,A100)
75430 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
75431 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
75432 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
75437 C*********************************************************************
75440 C...Resets bin contents of a histogram.
75442 SUBROUTINE PYNULL(ID)
75444 C...Double precision declaration.
75445 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75446 IMPLICIT INTEGER(I-N)
75448 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75451 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
75454 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
75461 C*********************************************************************
75464 C...Dumps histogram contents on file for reading by other program.
75465 C...Can also read back own dump.
75467 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
75469 C...Double precision declaration.
75470 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75471 IMPLICIT INTEGER(I-N)
75473 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75475 C...Local arrays and character variables.
75476 DIMENSION IHI(*),ISS(100),VAL(5)
75477 CHARACTER TITLE*60,FORMAT*13
75479 C...Dump all histograms that have been booked,
75480 C...including titles and ranges, one after the other.
75481 IF(MDUMP.EQ.1) THEN
75483 C...Loop over histograms and find which are wanted and booked.
75498 C...Write title, histogram size, filling statistics.
75501 IEQ=NINT(BIN(IS+8+NX+IT))
75502 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
75503 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
75505 WRITE(LFN,5100) ID,TITLE
75506 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
75507 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
75511 C...Write histogram contents, in groups of five.
75512 DO 120 IXG=1,(NX+4)/5
75516 VAL(IXV)=BIN(IS+8+IX)
75521 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
75524 C...Go to next histogram; finish.
75525 ELSEIF(NHI.GT.0) THEN
75526 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
75530 C...Read back in histograms dumped MDUMP=1.
75531 ELSEIF(MDUMP.EQ.2) THEN
75533 C...Read histogram number, title and range, and book.
75534 140 READ(LFN,5100,END=170) ID,TITLE
75535 READ(LFN,5200) NX,XL,XU
75536 CALL PYBOOK(ID,TITLE,NX,XL,XU)
75539 C...Read filling statistics.
75540 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
75541 BIN(IS+5)=DBLE(NENTRY)
75543 C...Read histogram contents, in groups of five.
75544 DO 160 IXG=1,(NX+4)/5
75545 READ(LFN,5400) (VAL(IXV),IXV=1,5)
75548 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
75552 C...Go to next histogram; finish.
75556 C...Write histogram contents in column format,
75557 C...convenient e.g. for GNUPLOT input.
75558 ELSEIF(MDUMP.EQ.3) THEN
75560 C...Find addresses to wanted histograms.
75574 IF(IS.NE.0.AND.NSS.LT.100) THEN
75577 ELSEIF(NSS.GE.100) THEN
75578 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
75579 ELSEIF(NHI.GT.0) THEN
75580 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
75584 C...Check that they have common number of x bins. Fix format.
75585 NX=NINT(BIN(ISS(1)+1))
75587 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
75588 CALL PYERRM(8,'(PYDUMP:) different number of bins')
75592 FORMAT='(1P,000E12.4)'
75593 WRITE(FORMAT(5:7),'(I3)') NSS+1
75595 C...Write histogram contents; first column x values.
75597 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
75598 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
75603 C...Formats for output.
75604 5100 FORMAT(I5,5X,A60)
75605 5200 FORMAT(I5,1P,2D12.4)
75606 5300 FORMAT(I12,1P,3D12.4)
75607 5400 FORMAT(1P,5D12.4)
75612 C*********************************************************************
75615 C...Allows users to handle STOP statemens
75617 SUBROUTINE PYSTOP(MCOD)
75619 C...Double precision and integer declarations.
75620 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75621 IMPLICIT INTEGER(I-N)
75622 INTEGER PYK,PYCHGE,PYCOMP
75624 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75628 C...Write message, then stop
75629 WRITE(MSTU(11),5000) MCOD
75633 C...Formats for output.
75634 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
75638 C*********************************************************************
75641 C...Dummy routine, which the user can replace in order to make cuts on
75642 C...the kinematics on the parton level before the matrix elements are
75643 C...evaluated and the event is generated. The cross-section estimates
75644 C...will automatically take these cuts into account, so the given
75645 C...values are for the allowed phase space region only. MCUT=0 means
75646 C...that the event has passed the cuts, MCUT=1 that it has failed.
75648 SUBROUTINE PYKCUT(MCUT)
75650 C...Double precision and integer declarations.
75651 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75652 IMPLICIT INTEGER(I-N)
75653 INTEGER PYK,PYCHGE,PYCOMP
75655 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75656 COMMON/PYINT1/MINT(400),VINT(400)
75657 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
75658 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
75660 C...Set default value (accepting event) for MCUT.
75663 C...Read out subprocess number.
75667 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
75671 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
75673 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
75675 C...Calculate x_1, x_2, x_F.
75676 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
75677 X1=SQRT(TAU)*EXP(YST)
75678 X2=SQRT(TAU)*EXP(-YST)
75680 X1=SQRT(TAUP)*EXP(YST)
75681 X2=SQRT(TAUP)*EXP(-YST)
75685 C...Calculate shat, that, uhat, p_T^2.
75691 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
75692 RPTS=4D0*VINT(71)**2/SHAT
75693 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
75696 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
75697 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
75698 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
75699 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
75701 C...Decisions by user to be put here.
75703 C...Stop program if this routine is ever called.
75704 C...You should not copy these lines to your own routine.
75705 WRITE(MSTU(11),5000)
75708 C...Format for error printout.
75709 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
75710 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
75711 &1X,'Execution stopped!')
75716 C*********************************************************************
75717 c This dummy routine is commented out; a implemtation for AliRoot
75718 c resides in $ALICE_ROOT/PYTHIA6/pyevwt.f
75721 C...Dummy routine, which the user can replace in order to multiply the
75722 C...standard PYTHIA differential cross-section by a process- and
75723 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
75724 C...to generation of weighted events, with weight 1/WTXS, while for
75725 C...MSTP(142)=2 it corresponds to a modification of the underlying
75728 c SUBROUTINE PYEVWT(WTXS)
75730 C...Double precision and integer declarations.
75731 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75732 c IMPLICIT INTEGER(I-N)
75733 c INTEGER PYK,PYCHGE,PYCOMP
75735 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75736 c COMMON/PYINT1/MINT(400),VINT(400)
75737 c COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
75738 c SAVE /PYDAT1/,/PYINT1/,/PYINT2/
75740 C...Set default weight for WTXS.
75743 C...Read out subprocess number.
75747 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
75751 c IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
75753 c IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
75755 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
75764 C...Modifications by user to be put here.
75766 C...Stop program if this routine is ever called.
75767 C...You should not copy these lines to your own routine.
75768 c WRITE(MSTU(11),5000)
75771 C...Format for error printout.
75772 c 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
75773 c &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
75774 c &1X,'Execution stopped!')
75779 C*********************************************************************
75782 C...Dummy routine, to be replaced by a user implementing external
75783 C...processes. Is supposed to fill the HEPRUP commonblock with info
75784 C...on incoming beams and allowed processes.
75786 C...New example: handles a standard Les Houches Events File.
75790 C...Double precision and integer declarations.
75791 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75792 IMPLICIT INTEGER(I-N)
75794 C...PYTHIA commonblock: only used to provide read unit MSTP(161).
75795 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75798 C...User process initialization commonblock.
75800 PARAMETER (MAXPUP=100)
75801 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
75802 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
75803 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
75804 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
75808 C...Lines to read in assumed never longer than 200 characters.
75809 PARAMETER (MAXLEN=200)
75810 CHARACTER*(MAXLEN) STRING
75812 C...Format for reading lines.
75815 WRITE(STRFMT(3:5),'(I3)') MAXLEN
75817 C...Loop until finds line beginning with "<init>" or "<init ".
75818 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
75821 C...Allow indentation.
75822 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
75823 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
75824 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
75826 C...Read first line of initialization info.
75827 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
75828 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
75830 C...Read NPRUP subsequent lines with information on each process.
75832 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
75833 & XMAXUP(IPR),LPRUP(IPR)
75837 C...Error exit: give up if initalization does not work.
75838 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
75839 WRITE(*,*) ' Event generation will be stopped.'
75845 C...Old example: handles a simple Pythia 6.4 initialization file.
75847 c SUBROUTINE UPINIT
75849 C...Double precision and integer declarations.
75850 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75851 c IMPLICIT INTEGER(I-N)
75854 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75855 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75856 c SAVE /PYDAT1/,/PYPARS/
75858 C...User process initialization commonblock.
75860 c PARAMETER (MAXPUP=100)
75861 c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
75862 c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
75863 c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
75864 c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
75868 C...Read info from file.
75869 c IF(MSTP(161).GT.0) THEN
75870 c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
75871 c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
75872 c DO 100 IPR=1,NPRUP
75873 c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
75874 c & XMAXUP(IPR),LPRUP(IPR)
75877 C...Error or prematurely reached end of file.
75878 c 110 WRITE(MSTU(11),5000)
75881 C...Else not implemented.
75883 c WRITE(MSTU(11),5100)
75887 C...Format for error printout.
75888 c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
75889 c &1X,'Execution stopped!')
75890 c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
75891 c &1X,'Dummy routine in PYTHIA file called instead.'/
75892 c &1X,'Execution stopped!')
75897 C*********************************************************************
75900 C...Dummy routine, to be replaced by a user implementing external
75901 C...processes. Depending on cross section model chosen, it either has
75902 C...to generate a process of the type IDPRUP requested, or pick a type
75903 C...itself and generate this event. The event is to be stored in the
75904 C...HEPEUP commonblock, including (often) an event weight.
75906 C...New example: handles a standard Les Houches Events File.
75910 C...Double precision and integer declarations.
75911 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75912 IMPLICIT INTEGER(I-N)
75914 C...PYTHIA commonblock: only used to provide read unit MSTP(162).
75915 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75918 C...User process event common block.
75920 PARAMETER (MAXNUP=500)
75921 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
75922 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
75923 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
75924 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
75925 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
75928 C...Lines to read in assumed never longer than 200 characters.
75929 PARAMETER (MAXLEN=200)
75930 CHARACTER*(MAXLEN) STRING
75932 C...Format for reading lines.
75935 WRITE(STRFMT(3:5),'(I3)') MAXLEN
75937 C...Loop until finds line beginning with "<event>" or "<event ".
75938 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
75941 C...Allow indentation.
75942 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
75943 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
75944 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
75946 C...Read first line of event info.
75947 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
75950 C...Read NUP subsequent lines with information on each particle.
75952 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
75953 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
75954 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
75958 C...Error exit, typically when no more events.
75959 130 WRITE(*,*) ' Failed to read LHEF event information.'
75960 WRITE(*,*) ' Will assume end of file has been reached.'
75967 C...Old example: handles a simple Pythia 6.4 event file.
75969 c SUBROUTINE UPEVNT
75971 C...Double precision and integer declarations.
75972 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75973 c IMPLICIT INTEGER(I-N)
75976 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75977 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75978 c SAVE /PYDAT1/,/PYPARS/
75980 C...User process event common block.
75982 c PARAMETER (MAXNUP=500)
75983 c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
75984 c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
75985 c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
75986 c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
75987 c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
75990 C...Read info from file.
75991 c IF(MSTP(162).GT.0) THEN
75992 c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
75995 c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
75996 c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
75997 c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
76000 C...Special when reached end of file or other error.
76003 C...Else not implemented.
76005 c WRITE(MSTU(11),5000)
76009 C...Format for error printout.
76010 c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
76011 c &1X,'Dummy routine in PYTHIA file called instead.'/
76012 c &1X,'Execution stopped!')
76017 C*********************************************************************
76020 C...Dummy routine, to be replaced by user, to veto event generation
76021 C...on the parton level, after parton showers but before multiple
76022 C...interactions, beam remnants and hadronization is added.
76023 C...If resonances like W, Z, top, Higgs and SUSY particles are handed
76024 C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
76025 C...be undecayed at this stage; if decayed their decay products will
76026 C...have been allowed to shower.
76028 C...All partons at the end of the shower phase are stored in the
76029 C...HEPEVT commonblock. The interesting information is
76030 C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
76031 C...IDHEP(I) = the particle ID code according to PDG conventions,
76032 C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
76033 C...All ISTHEP entries are 1, while the rest is zeroed.
76035 C...The user decision is to be conveyed by the IVETO value.
76036 C...IVETO = 0 : retain current event and generate in full;
76037 C... = 1 : abort generation of current event and move to next.
76039 SUBROUTINE UPVETO(IVETO)
76041 C...HEPEVT commonblock.
76042 PARAMETER (NMXHEP=4000)
76043 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
76044 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
76045 DOUBLE PRECISION PHEP,VHEP
76048 C...Next few lines allow you to see what info PYVETO extracted from
76049 C...the full event record for the first two events.
76050 C...Delete if you don't want it.
76053 IF(NLIST.LE.2) THEN
76054 WRITE(*,*) ' Full event record at time of UPVETO call:'
76056 WRITE(*,*) ' Part of event record made available to UPVETO:'
76061 C...Make decision here.
76067 C*********************************************************************
76069 C*********************************************************************
76072 C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
76074 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
76075 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76076 IMPLICIT INTEGER(I-N)
76077 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
76080 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76083 C...Stop program if this routine is ever called.
76084 WRITE(MSTU(11),5000)
76087 C...Format for error printout.
76088 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
76089 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
76090 &1X,'Execution stopped!')
76095 C*********************************************************************
76098 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
76101 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76102 IMPLICIT INTEGER(I-N)
76103 CHARACTER*40 VISAJE
76106 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76109 C...Assign default value.
76112 C...Stop program if this routine is ever called.
76113 WRITE(MSTU(11),5000)
76116 C...Format for error printout.
76117 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
76118 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
76119 &1X,'Execution stopped!')
76124 C*********************************************************************
76127 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
76129 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
76130 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
76131 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
76133 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76134 IMPLICIT INTEGER(I-N)
76135 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
76136 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
76137 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
76139 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76142 C...Stop program if this routine is ever called.
76143 WRITE(MSTU(11),5000)
76146 C...Format for error printout.
76147 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
76148 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
76149 &1X,'Execution stopped!')
76153 C*********************************************************************
76156 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
76158 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
76159 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76160 IMPLICIT INTEGER(I-N)
76161 Cmssmpart = 4 # full MSSM [recommended]
76162 Cfieldren = 0 # MSbar field ren. [strongly recommended]
76163 Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
76164 Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
76165 Cp2approx = 0 # no approximation [recommended]
76166 Clooplevel= 2 # include 2-loop corrections
76167 Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
76168 Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
76171 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76174 C...Stop program if this routine is ever called.
76175 WRITE(MSTU(11),5000)
76178 C...Format for error printout.
76179 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
76180 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
76181 &1X,'Execution stopped!')
76185 C*********************************************************************
76188 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
76190 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
76191 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
76192 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
76193 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
76194 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76195 IMPLICIT INTEGER(I-N)
76197 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
76198 DOUBLE COMPLEX DMU,
76199 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
76203 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76206 C...Stop program if this routine is ever called.
76207 WRITE(MSTU(11),5000)
76210 C...Format for error printout.
76211 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
76212 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
76213 &1X,'Execution stopped!')
76217 C*********************************************************************
76220 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
76222 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
76223 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76224 IMPLICIT INTEGER(I-N)
76226 C...FeynHiggs variables
76227 DOUBLE PRECISION RMHIGG(4)
76228 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
76229 DOUBLE COMPLEX DMU,
76230 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
76234 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76237 C...Stop program if this routine is ever called.
76238 WRITE(MSTU(11),5000)
76241 C...Format for error printout.
76242 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
76243 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
76244 &1X,'Execution stopped!')
76248 C*********************************************************************
76251 C...Dummy routine, to be replaced by user, to handle the decay of a
76252 C...polarized tau lepton.
76254 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
76255 C...IORIG is the position where the mother of the tau is stored;
76256 C... is 0 when the mother is not stored.
76257 C...KFORIG is the flavour of the mother of the tau;
76258 C... is 0 when the mother is not known.
76259 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
76260 C... e.g. in B hadron semileptonic decays the W propagator
76261 C... is not explicitly stored but the W code is still unambiguous.
76263 C...NDECAY is the number of decay products in the current tau decay.
76264 C...These decay products should be added to the /PYJETS/ common block,
76265 C...in positions N+1 through N+NDECAY. For each product I you must
76266 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
76267 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
76269 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
76271 C...Double precision and integer declarations.
76272 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76273 IMPLICIT INTEGER(I-N)
76274 INTEGER PYK,PYCHGE,PYCOMP
76276 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76277 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76278 SAVE /PYJETS/,/PYDAT1/
76280 C...Stop program if this routine is ever called.
76281 C...You should not copy these lines to your own routine.
76282 NDECAY=ITAU+IORIG+KFORIG
76283 WRITE(MSTU(11),5000)
76286 C...Format for error printout.
76287 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
76288 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
76289 &1X,'Execution stopped!')
76294 C*********************************************************************
76297 C...Finds current date and time.
76298 C...Since this task is not standardized in Fortran 77, the routine
76299 C...is dummy, to be replaced by the user. Examples are given for
76300 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
76301 C...you do not have access to suitable routines.
76303 SUBROUTINE PYTIME(IDATI)
76305 C...Double precision and integer declarations.
76306 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76307 IMPLICIT INTEGER(I-N)
76308 INTEGER PYK,PYCHGE,PYCOMP
76311 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
76313 C...Example 0: if you do not have suitable routines.
76318 C...Example 1: Fortran 90 routine.
76319 C CALL DATE_AND_TIME(VALUES=IVAL)
76327 C...Example 2: DEC Fortran 77. AIX.
76328 C CALL IDATE(IMON,IDAY,IYEAR)
76332 C CALL ITIME(IHOUR,IMIN,ISEC)
76337 C...Example 3: DEC Fortran, IRIX, IRIX64.
76338 C CALL IDATE(IMON,IDAY,IYEAR)
76346 C READ(ATIME(1:2),'(I2)') IHOUR
76347 C READ(ATIME(4:5),'(I2)') IMIN
76348 C READ(ATIME(7:8),'(I2)') ISEC
76353 C...Example 4: GNU LINUX libU77, SunOS.
76354 C CALL IDATE(IDTEMP)
76355 C IDATI(1)=IDTEMP(3)
76356 C IDATI(2)=IDTEMP(2)
76357 C IDATI(3)=IDTEMP(1)
76358 C CALL ITIME(IDTEMP)
76359 C IDATI(4)=IDTEMP(1)
76360 C IDATI(5)=IDTEMP(2)
76361 C IDATI(6)=IDTEMP(3)
76363 C...Common code to ensure right century.
76364 IDATI(1)=2000+MOD(IDATI(1),100)
76369 C... ALICE interface to PDFLIB with possibility to select nuclear structure
76372 C... The MSTP array in the PYPARS common block is used to enable and
76373 C... select the nuclear structure functions.
76374 C... MSTP(52) : (D=1) choice of proton and nuclear structure-function library
76375 C... =1: internal PYTHIA acording to MSTP(51)
76376 C... =2: PDFLIB proton s.f., with MSTP(51) = 1000xNGROUP+NSET
76377 C... MSTP( 51) = 1000xNPGROUP+NPSET
76378 C... MSTP(151) = 1000xNAGROUP+NASET
76379 C... MSTP(192) : Mass number of nucleus side 1
76380 C... MSTP(193) : Mass number of nucleus side 2
76383 C... MINT(124) : side (1 or 2)
76386 SUBROUTINE PDFSET_ALICE(PARM, VALUE)
76388 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76389 IMPLICIT INTEGER(I-N)
76390 C...Interface to PDFLIB.
76391 COMMON/LW50512/QCDL4,QCDL5
76393 DOUBLE PRECISION QCDL4,QCDL5
76394 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
76396 DOUBLE PRECISION XMIN,XMAX,Q2MIN,Q2MAX
76398 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76399 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
76400 DOUBLE PRECISION VALUE(20)
76401 CHARACTER*20 PARM(20)
76402 write(6,*) MSTP(52)
76406 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
76410 VALUE(6)=MSTP(191)/1000
76412 VALUE(7)=MOD(MSTP(191),1000)
76413 CALL PDFSET(PARM,VALUE,
76414 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
76416 > XMIN,XMAX,Q2MIN,Q2MAX)
76417 IF (MSTP(194) .EQ. 0) THEN
76418 CALL SETLHAPARM("EKS98")
76420 CALL SETLHAPARM("EPS08")
76423 write(6,*) "-> pdfset"
76424 CALL PDFSET(PARM,VALUE,
76425 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
76427 > XMIN,XMAX,Q2MIN,Q2MAX)
76434 SUBROUTINE STRUCTM_ALICE
76435 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
76437 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76438 IMPLICIT INTEGER(I-N)
76439 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
76440 COMMON/PYINT1/MINT(400),VINT(400)
76441 A=MSTP(191+MINT(124))
76443 CALL STRUCTA(XX,QQ,A,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
76445 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
git://git.uio.no / u / mrichter / AliRoot.git / blob