1 C*********************************************************************
2 C*********************************************************************
6 C* The Lund Monte Carlo **
8 C* PYTHIA version 6.4 **
10 C* Torbjorn Sjostrand **
11 C* Department of Theoretical Physics **
13 C* Solvegatan 14A, S-223 62 Lund, Sweden **
14 C* E-mail torbjorn@thep.lu.se **
16 C* SUSY and Technicolor parts by **
18 C* Computing Division **
19 C* Generators and Detector Simulation Group **
20 C* Fermi National Accelerator Laboratory **
21 C* MS 234, Batavia, IL 60510, USA **
22 C* phone + 1 - 630 - 840 - 2556 **
23 C* E-mail mrenna@fnal.gov **
25 C* New multiple interactions and more SUSY parts by **
27 C* Theoretical Physics Department **
28 C* Fermi National Accelerator Laboratory **
29 C* MS 106, Batavia, IL 60510, USA **
31 C* CERN/PH, CH-1211 Geneva, Switzerland **
32 C* phone +41 - 22 - 767 24 59 **
33 C* E-mail skands@fnal.gov **
35 C* Several parts are written by Hans-Uno Bengtsson **
36 C* PYSHOW is written together with Mats Bengtsson **
37 C* PYMAEL is written by Emanuel Norrbin **
38 C* advanced popcorn baryon production written by Patrik Eden **
39 C* code for virtual photons mainly written by Christer Friberg **
40 C* code for low-mass strings mainly written by Emanuel Norrbin **
41 C* Bose-Einstein code mainly written by Leif Lonnblad **
42 C* CTEQ parton distributions are by the CTEQ collaboration **
43 C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
44 C* SaS photon parton distributions together with Gerhard Schuler **
45 C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
46 C* MSSM Higgs mass calculation code by M. Carena, **
47 C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
48 C* UED implementation by M. Elkacimi, D. Goujdami, H. Przysiezniak **
49 C* PYGAUS adapted from CERN library (K.S. Kolbig) **
50 C* NRQCD/colour octet production of onium by S. Wolf **
52 C* The latest program version and documentation is found on WWW **
53 C* http://www.thep.lu.se/~torbjorn/Pythia.html **
55 C* Copyright Torbjorn Sjostrand, Lund (and CERN) 2008 **
57 C*********************************************************************
58 C*********************************************************************
60 C List of subprograms in order of appearance, with main purpose *
61 C (S = subroutine, F = function, B = block data) *
63 C B PYDATA to contain all default values *
64 C S PYCKBD to check that BLOCK DATA has been correctly loaded *
65 C S PYTEST to test the proper functioning of the package *
66 C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
68 C S PYINIT to administer the initialization procedure *
69 C S PYEVNT to administer the generation of an event *
70 C S PYEVNW ditto, for new multiple interactions scenario *
71 C S PYSTAT to print cross-section and other information *
72 C S PYUPEV to administer the generation of an LHA hard process *
73 C S PYUPIN to provide initialization needed for LHA input *
74 C S PYLHEF to produce a Les Houches Event File from run *
75 C S PYINRE to initialize treatment of resonances *
76 C S PYINBM to read in beam, target and frame choices *
77 C S PYINKI to initialize kinematics of incoming particles *
78 C S PYINPR to set up the selection of included processes *
79 C S PYXTOT to give total, elastic and diffractive cross-sect. *
80 C S PYMAXI to find differential cross-section maxima *
81 C S PYPILE to select multiplicity of pileup events *
82 C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
83 C S PYGAGA to handle lepton -> lepton + gamma branchings *
84 C S PYRAND to select subprocess and kinematics for event *
85 C S PYSCAT to set up kinematics and colour flow of event *
86 C S PYEVOL handler for pT-ordered ISR and multiple interactions *
87 C S PYSSPA to simulate initial state spacelike showers *
88 C S PYPTIS to do pT-ordered initial state spacelike showers *
89 C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum *
90 C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction *
91 C S PYPTMI to do pT-ordered multiple interactions *
92 C F PYFCMP to give companion quark x*f distribution *
93 C F PYPCMP to calculate momentum integral for companion quarks *
94 C S PYUPRE to rearranges contents of the HEPEUP commonblock *
95 C S PYADSH to administrate sequential final-state showers *
96 C S PYVETO to allow the generation of an event to be aborted *
97 C S PYRESD to perform resonance decays *
98 C S PYMULT to generate multiple interactions - old scheme *
99 C S PYREMN to add on target remnants - old scheme *
100 C S PYMIGN to generate multiple interactions - new scheme *
101 C S PYMIHK to connect colours in mult. int. - new scheme *
102 C S PYCTTR to translate PYTHIA colour information to LHA1 tags *
103 C S PYMIHG to collapse two pairs of LHA1 colour tags. *
104 C S PYMIRM to add on target remnants in mult. int.- new scheme *
105 C S PYFSCR to perform final state colour reconnections - -"- *
106 C S PYDIFF to set up kinematics for diffractive events *
107 C S PYDISG to set up kinematics, remnant and showers for DIS *
108 C S PYDOCU to compute cross-sections and handle documentation *
109 C S PYFRAM to perform boosts between different frames *
110 C S PYWIDT to calculate full and partial widths of resonances *
111 C S PYOFSH to calculate partial width into off-shell channels *
112 C S PYRECO to handle colour reconnection in W+W- events *
113 C S PYKLIM to calculate borders of allowed kinematical region *
114 C S PYKMAP to construct value of kinematical variable *
115 C S PYSIGH to calculate differential cross-sections *
116 C S PYSGQC auxiliary to PYSIGH for QCD processes *
117 C S PYSGHF auxiliary to PYSIGH for heavy flavour processes *
118 C S PYSGWZ auxiliary to PYSIGH for W and Z processes *
119 C S PYSGHG auxiliary to PYSIGH for Higgs processes *
120 C S PYSGSU auxiliary to PYSIGH for supersymmetry processes *
121 C S PYSGTC auxiliary to PYSIGH for technicolor processes *
122 C S PYSGEX auxiliary to PYSIGH for various exotic processes *
123 C S PYPDFU to evaluate parton distributions *
124 C S PYPDFL to evaluate parton distributions at low x and Q^2 *
125 C S PYPDEL to evaluate electron parton distributions *
126 C S PYPDGA to evaluate photon parton distributions (generic) *
127 C S PYGGAM to evaluate photon parton distributions (SaS sets) *
128 C S PYGVMD to evaluate VMD part of photon parton distributions *
129 C S PYGANO to evaluate anomalous part of photon PDFs *
130 C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs *
131 C S PYGDIR to evaluate direct contribution to photon PDFs *
132 C S PYPDPI to evaluate pion parton distributions *
133 C S PYPDPR to evaluate proton parton distributions *
134 C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
135 C S PYGRVL to evaluate the GRV 94L proton parton distributions *
136 C S PYGRVM to evaluate the GRV 94M proton parton distributions *
137 C S PYGRVD to evaluate the GRV 94D proton parton distributions *
138 C F PYGRVV auxiliary to the PYGRV* routines *
139 C F PYGRVW auxiliary to the PYGRV* routines *
140 C F PYGRVS auxiliary to the PYGRV* routines *
141 C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
142 C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
143 C S PYPDPO to evaluate old proton parton distributions *
144 C F PYHFTH to evaluate threshold factor for heavy flavour *
145 C S PYSPLI to find flavours left in hadron when one removed *
146 C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
147 C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
148 C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
149 C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
150 C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
151 C S PYSTBH to evaluate matrix element for t + b + H processes *
152 C S PYTBHB auxiliary to PYSTBH *
153 C S PYTBHG auxiliary to PYSTBH *
154 C S PYTBHQ auxiliary to PYSTBH *
155 C F PYTBHS auxiliary to PYSTBH *
157 C S PYMSIN to initialize the supersymmetry simulation *
158 C S PYSLHA to interface to SUSY spectrum and decay calculators *
159 C S PYAPPS to determine MSSM parameters from SUGRA input *
160 C S PYSUGI to determine MSSM parameters using ISASUSY *
161 C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS *
162 C F PYRNMQ to determine running squark masses *
163 C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
164 C S PYINOM to calculate neutralino/chargino mass eigenstates *
165 C F PYRNM3 to determine running M3, gluino mass *
166 C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
167 C S PYHGGM to determine Higgs mass spectrum *
168 C S PYSUBH to determine Higgs masses in the MSSM *
169 C S PYPOLE to determine Higgs masses in the MSSM *
170 C S PYRGHM auxiliary to PYPOLE *
171 C S PYGFXX auxiliary to PYRGHM *
172 C F PYFINT auxiliary to PYPOLE *
173 C F PYFISB auxiliary to PYFINT *
174 C S PYSFDC to calculate sfermion decay partial widths *
175 C S PYGLUI to calculate gluino decay partial widths *
176 C S PYTBBN to calculate 3-body decay of gluino to neutralino *
177 C S PYTBBC to calculate 3-body decay of gluino to chargino *
178 C S PYNJDC to calculate neutralino decay partial widths *
179 C S PYCJDC to calculate chargino decay partial widths *
180 C F PYXXZ6 auxiliary for ino 3-body decays *
181 C F PYXXGA auxiliary for ino -> ino + gamma decay *
182 C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
183 C F PYX2XH auxiliary for ino -> ino + Higgs decay *
184 C S PYHEXT to calculate non-SM Higgs decay partial widths *
185 C F PYH2XX auxiliary for H -> ino + ino decay *
186 C F PYGAUS to perform Gaussian integration *
187 C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
188 C F PYSIMP to perform Simpson integration *
189 C F PYLAMF to evaluate the lambda kinematics function *
190 C S PYTBDY to perform 3-body decay of gauginos *
191 C S PYTECM to calculate techni_rho/omega masses *
192 C S PYXDIN to initialize Universal Extra Dimensions *
193 C S PYUEDC to compute UED mass radiative corrections *
194 C S PYXUED to compute UED cross sections *
195 C S PYGRAM to generate UED G* (excited graviton) mass spectrum *
196 C F PYGRAW to compute UED partial widths to G* *
197 C F PYWDKK to compute UED differential partial widths to G* *
198 C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
199 C S PYCMQR auxiliary to PYEICG *
200 C S PYCMQ2 auxiliary to PYEICG *
201 C S PYCDIV auxiliary to PYCMQR *
202 C S PYCSRT auxiliary to PYCMQR *
203 C S PYTHAG auxiliary to PYCMQR *
204 C S PYCBAL auxiliary to PYEICG *
205 C S PYCBA2 auxiliary to PYEICG *
206 C S PYCRTH auxiliary to PYEICG *
207 C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
208 C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
209 C S PYWIDX to calculate decay widths from within PYWIDT *
210 C S PYRVSF to calculate R-violating sfermion decay widths *
211 C S PYRVNE to calculate R-violating neutralino decay widths *
212 C S PYRVCH to calculate R-violating chargino decay widths *
213 C S PYRVGL to calculate R-violating gluino decay widths *
214 C F PYRVSB auxiliary to PYRVSF *
215 C S PYRVGW to calculate R-Violating 3-body widths *
216 C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
217 C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
218 C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
219 C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
220 C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
221 C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
222 C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
223 C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
224 C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
226 C S PY1ENT to fill one entry (= parton or particle) *
227 C S PY2ENT to fill two entries *
228 C S PY3ENT to fill three entries *
229 C S PY4ENT to fill four entries *
230 C S PY2FRM to interface to generic two-fermion generator *
231 C S PY4FRM to interface to generic four-fermion generator *
232 C S PY6FRM to interface to generic six-fermion generator *
233 C S PY4JET to generate a shower from a given 4-parton config *
234 C S PY4JTW to evaluate the weight od a shower history for above *
235 C S PY4JTS to set up the parton configuration for above *
236 C S PYJOIN to connect entries with colour flow information *
237 C S PYGIVE to fill (or query) commonblock variables *
238 C S PYONOF to allow easy control of particle decay modes *
239 C S PYTUNE to select a predefined 'tune' for min-bias and UE *
240 C S PYEXEC to administrate fragmentation and decay chain *
241 C S PYPREP to rearrange showered partons along strings *
242 C S PYSTRF to do string fragmentation of jet system *
243 C S PYJURF to find boost to string junction rest frame *
244 C S PYINDF to do independent fragmentation of one or many jets *
245 C S PYDECY to do the decay of a particle *
246 C S PYDCYK to select parton and hadron flavours in decays *
247 C S PYKFDI to select parton and hadron flavours in fragm *
248 C S PYNMES to select number of popcorn mesons *
249 C S PYKFIN to calculate falvour prod. ratios from input params. *
250 C S PYPTDI to select transverse momenta in fragm *
251 C S PYZDIS to select longitudinal scaling variable in fragm *
252 C S PYSHOW to do m-ordered timelike parton shower evolution *
253 C S PYPTFS to do pT-ordered timelike parton shower evolution *
254 C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's *
255 C S PYBOEI to include Bose-Einstein effects (crudely) *
256 C S PYBESQ auxiliary to PYBOEI *
257 C F PYMASS to give the mass of a particle or parton *
258 C F PYMRUN to give the running MSbar mass of a quark *
259 C S PYNAME to give the name of a particle or parton *
260 C F PYCHGE to give three times the electric charge *
261 C F PYCOMP to compress standard KF flavour code to internal KC *
262 C S PYERRM to write error messages and abort faulty run *
263 C F PYALEM to give the alpha_electromagnetic value *
264 C F PYALPS to give the alpha_strong value *
265 C F PYANGL to give the angle from known x and y components *
266 C F PYR to provide a random number generator *
267 C S PYRGET to save the state of the random number generator *
268 C S PYRSET to set the state of the random number generator *
269 C S PYROBO to rotate and/or boost an event *
270 C S PYEDIT to remove unwanted entries from record *
271 C S PYLIST to list event record or particle data *
272 C S PYLOGO to write a logo *
273 C S PYUPDA to update particle data *
274 C F PYK to provide integer-valued event information *
275 C F PYP to provide real-valued event information *
276 C S PYSPHE to perform sphericity analysis *
277 C S PYTHRU to perform thrust analysis *
278 C S PYCLUS to perform three-dimensional cluster analysis *
279 C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
280 C S PYJMAS to give high and low jet mass of event *
281 C S PYFOWO to give Fox-Wolfram moments *
282 C S PYTABU to analyze events, with tabular output *
284 C S PYEEVT to administrate the generation of an e+e- event *
285 C S PYXTEE to give the total cross-section at given CM energy *
286 C S PYRADK to generate initial state photon radiation *
287 C S PYXKFL to select flavour of primary qqbar pair *
288 C S PYXJET to select (matrix element) jet multiplicity *
289 C S PYX3JT to select kinematics of three-jet event *
290 C S PYX4JT to select kinematics of four-jet event *
291 C S PYXDIF to select angular orientation of event *
292 C S PYONIA to perform generation of onium decay to gluons *
294 C S PYBOOK to book a histogram *
295 C S PYFILL to fill an entry in a histogram *
296 C S PYFACT to multiply histogram contents by a factor *
297 C S PYOPER to perform operations between histograms *
298 C S PYHIST to print and reset all histograms *
299 C S PYPLOT to print a single histogram *
300 C S PYNULL to reset contents of a single histogram *
301 C S PYDUMP to dump histogram contents onto a file *
303 C S PYSTOP routine to handle Fortran STOP condition *
305 C S PYKCUT dummy routine for user kinematical cuts *
306 C S PYEVWT dummy routine for weighting events *
307 C S UPINIT dummy routine to initialize user processes *
308 C S UPEVNT dummy routine to generate a user process event *
309 C S UPVETO dummy routine to abort event at parton level *
310 C S PDFSET dummy routine to be removed when using PDFLIB *
311 C S STRUCTM dummy routine to be removed when using PDFLIB *
312 C S STRUCTP dummy routine to be removed when using PDFLIB *
313 C S SUGRA dummy routine to be removed when linking with ISAJET *
314 C F VISAJE dummy functn. to be removed when linking with ISAJET *
315 C S SSMSSM dummy routine to be removed when linking with ISAJET *
316 C S FHSETFLAGS dummy routine -"- FEYNHIGGS *
317 C S FHSETPARA dummy routine -"- FEYNHIGGS *
318 C S FHHIGGSCORR dummy routine -"- FEYNHIGGS *
319 C S PYTAUD dummy routine for interface to tau decay libraries *
320 C S PYTIME dummy routine for giving date and time *
322 C*********************************************************************
325 C...Default values for switches and parameters,
326 C...and particle, decay and process data.
330 C...Double precision and integer declarations.
331 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
332 IMPLICIT INTEGER(I-N)
333 INTEGER PYK,PYCHGE,PYCOMP
335 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
336 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
337 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
338 COMMON/PYDAT4/CHAF(500,2)
340 COMMON/PYDATR/MRPY(6),RRPY(100)
341 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
342 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
343 COMMON/PYINT1/MINT(400),VINT(400)
344 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
345 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
346 COMMON/PYINT4/MWID(500),WIDS(500,5)
347 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
348 COMMON/PYINT6/PROC(0:500)
350 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
351 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
352 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
353 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
354 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
355 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
356 COMMON/PYPUED/IUED(0:99),RUED(0:99)
357 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
358 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
359 & AU(3,3),AD(3,3),AE(3,3)
360 COMMON/PYLH3C/CPRO(2),CVER(2)
361 CHARACTER CPRO*12,CVER*12
362 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
363 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
364 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYPUED/,
365 &/PYBINS/,/PYLH3P/,/PYLH3C/
367 C...PYDAT1, containing status codes and most parameters.
369 & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
370 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
371 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
372 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
373 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
374 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
375 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
377 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
378 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
380 DATA (PARU(I),I=1,100)/
381 & 3.141592653589793D0, 6.283185307179586D0,
382 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
383 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
384 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
385 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
386 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
387 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
388 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
390 DATA (PARU(I),I=101,200)/
391 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
392 & 0D0, 0D0, 0D0, 0D0, 0D0,
393 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
394 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
395 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
396 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
397 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
398 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
399 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
400 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
401 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
402 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
404 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
405 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
406 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
407 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
408 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
409 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
411 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
412 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
415 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
416 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
417 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
418 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
419 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
420 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
421 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
422 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
423 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
424 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
425 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
426 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
427 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
428 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
429 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
430 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
431 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
435 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
436 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
437 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
438 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
441 C...PYDAT2, with particle data and flavour treatment parameters.
442 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
443 &-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,
444 &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,
445 &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,
446 &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,
447 &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,
448 &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,
449 &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,
450 &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,
452 C...UED singlet and doublet quarks, leptons, and KK g, gamma, Z, and W
453 &81*0,-1,2,-1,2,-1,2,-1,2,-1,2,-1,2,
454 &3*-3,0,-3,0,-3,0,-3,
457 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
458 &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,
459 &-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,
460 &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,
461 &83*0,12*1,9*0,2,3*0,25*0/
462 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
463 &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,
464 &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,
465 &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,
466 &81*0,21*1,3*0,1,25*0/
467 DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
468 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
469 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
470 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
471 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
472 &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
473 &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
474 &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
475 &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
476 &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
477 &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
478 &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
479 &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
480 &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
481 &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
482 &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
483 &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
484 &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
485 &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
486 &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
487 DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
488 &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
489 &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
490 &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
491 &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
492 &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
493 &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
494 &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
495 &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
496 &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,
499 C...UED singlet and doublet quarks and leptons, and KK g, gamma, Z, and W.
500 &6100001,6100002,6100003,6100004,6100005,6100006,
501 &5100001,5100002,5100003,5100004,5100005,5100006,
502 &6100011,6100013,6100015,
503 &5100012,5100011,5100014,5100013,5100016,5100015,
504 &5100021,5100022,5100023,5100024,
506 DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
507 &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
508 &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
509 &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
510 &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
511 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
512 &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
513 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
514 &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
515 &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
516 &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
517 &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
518 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
519 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
520 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
521 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
522 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
523 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
524 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
525 &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
526 DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
527 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
528 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
529 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
530 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
531 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
532 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
533 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
534 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
535 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
536 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
537 &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
538 &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0,
542 &586.,588.,586.,588.,586.,586.,6*598.,
543 &3*505.,6*516.,640.,501.,536.,536.,25*0.D0/
544 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
545 &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
546 &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
547 &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
548 &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
549 &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
550 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
551 &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
552 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
553 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
554 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
555 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
556 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
557 &0.0208D0,0.01195D0,0.03705D0,0.09511D0,1.89978D0,1.60746D0,
558 &0.13396D0,200.47294D0,0.02296D0,0.18886D0,94.66794D0,6.08718D0,
559 &0D0,2.17482D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
560 &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
561 &7*0D0,6*0.01D0,0.25499D0,0.28446D0,131*0D0/
562 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
563 &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
564 &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
565 &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
566 &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
567 &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
568 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
569 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
570 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
571 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
572 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
573 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
574 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
575 &0.20797D0,0.11949D0,0.37048D0,0.95114D0,18.99785D0,16.07463D0,
576 &1.33964D0,450D0,0.22959D0,1.88863D0,360D0,60.8718D0,0D0,
577 &21.74824D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
578 &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
579 &8.80013D0,13*0D0,2.54987D0,2.84456D0,
582 &12*0.2D0,9*0.1D0,0.2,10.,0.07,0.3,25*0.D0/
583 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
584 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
585 &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
586 &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
587 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
588 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
589 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
590 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,120*0D0,131*0D0/
593 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
594 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
595 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
596 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
597 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
598 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
599 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
600 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
601 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
602 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0,
603 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
604 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
605 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
607 4 0.2D0, 0.5D0, 8*0D0,
609 DATA ((VCKM(I,J),J=1,4),I=1,4)/
610 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
611 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
612 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
613 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
615 C...PYDAT3, with particle decay parameters and data.
616 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
617 &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,
618 &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,
619 &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,
622 &5*1,0,5*1,0,13*1,25*0/
623 DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
624 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
625 &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
626 &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
627 &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
628 &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
629 &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
630 &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
631 &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
632 &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
633 &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
634 &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
635 &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
636 &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
637 &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
638 &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
639 &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
640 &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
641 &3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036,
642 &4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/
643 DATA (MDCY(I,2),I= 352, 500)/4185,4197,4204,7*0,4211,4212,4213,
644 &4214,4215,4216,4296,4322,
647 %5001,5003,5005,5007,5009,5011,5013,5016,5019,5022,5025,5028,
649 &5034,5035,5036,5037,5038,5039,5040,5064,5065,5083,
651 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
652 &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,
653 &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,
654 &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,
655 &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,
656 &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,
657 &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,
658 &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
659 &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,
660 &3*22,15,12,2*7,7*0,6*1,26,30,
663 &6*2,6*3,9*1,24,1,18,6,25*0/
664 DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
665 &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,
666 &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,
667 &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,
668 &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,
669 &3*1,-1,3*1,-1,1,18*1,4*1,2*-1,2*1,-1,1249*1,2*-1,377*1,2*-1,
670 &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,
671 &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,
675 &10*1,2*0,15*1,3*0,9*1,5*1,0,5*1,0,5*1,0,5*1,0,
677 DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
678 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
679 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
680 &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
681 &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,
682 &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,
683 &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,
684 &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
685 &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,
686 &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,
687 &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,
688 &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,
689 &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,
690 &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,
691 &9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0,
694 &653*0,30*0,9*0,12*0,37*0,2912*0/
695 DATA (BRAT(I) ,I= 1, 348)/43*0D0,0.00003D0,0.001765D0,
696 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
697 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
698 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
699 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
700 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
701 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
702 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
703 &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
704 &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
705 &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
706 &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
707 &0.108087D0,0D0,0.000001D0,0D0,0.000353D0,0.04359D0,0.795274D0,
708 &4*0D0,0.000339D0,0.095746D0,0D0,0.060724D0,0.003054D0,0.000919D0,
709 &64*0D0,0.145835D0,0.113276D0,0.145835D0,0.113271D0,0.145781D0,
710 &0.049002D0,2*0D0,0.032025D0,0.063642D0,0.032025D0,0.063642D0,
711 &0.032022D0,0.063642D0,8*0D0,0.251225D0,0.0129D0,0.000006D0,0D0,
712 &0.0129D0,0.250764D0,0.00038D0,0D0,0.000008D0,0.000465D0,
713 &0.215418D0,5*0D0,2*0.085312D0,0.08531D0,7*0D0,0.000029D0,
714 &0.000536D0,5*0D0,0.000074D0,0D0,0.000417D0,0.000015D0,0.000061D0/
715 DATA (BRAT(I) ,I= 349, 655)/0.306789D0,0.689189D0,0D0,0.00289D0,
716 &69*0D0,0.000001D0,0.000072D0,0.001333D0,4*0D0,0.000001D0,
717 &0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0,
718 &66*0D0,0.000014D0,0.082234D0,2*0D0,0.000013D0,0.003746D0,0D0,
719 &0.913992D0,18*0D0,3*0.215119D0,0.214724D0,2*0D0,0.06996D0,
720 &0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,
721 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,
722 &0.998739D0,0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,
723 &0.144D0,0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,
724 &0.1256D0,2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,
725 &0.999877D0,0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,
726 &0.104D0,0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,
727 &0.0478D0,0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,
728 &0.0221D0,0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,
729 &0.023D0,2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,
730 &0.665D0,0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,
731 &0.043D0,0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,
732 &0.0173D0,0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,
733 &0.166D0,0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,
734 &2*0.002D0,0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0/
735 DATA (BRAT(I) ,I= 656, 831)/0.48947D0,0.34D0,3*0.043D0,0.027D0,
736 &0.0126D0,0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,
737 &0.104D0,2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,
738 &0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,
739 &0.066D0,0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,
740 &0.001D0,0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,
741 &0.006D0,0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,
742 &0.027D0,0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,
743 &0.022D0,0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,
744 &0.306D0,0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,
745 &0.04D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,
746 &0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,
747 &0.062D0,3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,
748 &0.0109D0,0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,
749 &2*0.0016D0,0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,
750 &0.0034D0,0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,
751 &0.022D0,0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,
752 &0.0511D0,0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,
753 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
754 &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
755 DATA (BRAT(I) ,I= 832, 997)/0.079D0,0.095D0,0.052D0,0.0078D0,
756 &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
757 &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
758 &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
759 &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
760 &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
761 &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
762 &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
763 &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
764 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
765 &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
766 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
767 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
768 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
769 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
770 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
771 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
772 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
773 &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
774 &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
775 DATA (BRAT(I) ,I= 998,1188)/0.122D0,0.006D0,0.012D0,0.035D0,
776 &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
777 &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
778 &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
779 &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
780 &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
781 &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
782 &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
783 &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
784 &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
785 &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
786 &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
787 &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
788 &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
789 &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
790 &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
791 &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
792 &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
793 &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
794 &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
795 DATA (BRAT(I) ,I=1189,1381)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
796 &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
797 &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
798 &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
799 &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
800 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
801 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
802 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
803 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
804 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,
805 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
806 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
807 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
808 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
809 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
810 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
811 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
812 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
813 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
814 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/
815 DATA (BRAT(I) ,I=1382,1582)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
816 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
817 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
818 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
819 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
820 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
821 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
822 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
823 &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
824 &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
825 &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
826 &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
827 &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
828 &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
829 &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
830 &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
831 &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
832 &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
833 &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
834 &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
835 DATA (BRAT(I) ,I=1583,4150)/0.008D0,0.024D0,0.425D0,0.02D0,
836 &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,0.024396D0,
837 &0.045285D0,0.83119D0,2*0D0,0.000349D0,0.09878D0,0D0,0.019884D0,
838 &0.02341D0,0.362776D0,0.550787D0,2*0D0,0.000152D0,0.042991D0,
839 &0.013695D0,0.025421D0,0.466595D0,2*0D0,0.000196D0,0.055451D0,
840 &0.438642D0,0.445781D0,0D0,0.554219D0,4*0.00335D0,0.522257D0,
841 &0.464343D0,6*0D0,1D0,6*0D0,1D0,4*0.013853D0,0.562703D0,
842 &0.376702D0,0.00518D0,4*0.006254D0,0.974985D0,7*0D0,4*0.148299D0,
843 &0.015351D0,0D0,0.182109D0,0.167099D0,0.042247D0,0.850973D0,
844 &0.005411D0,0.045025D0,0.098591D0,0.849898D0,0.021617D0,
845 &0.030018D0,0.098466D0,0.294448D0,0.10945D0,0.596102D0,0.389906D0,
846 &0.610094D0,3*0.0633D0,0.063299D0,0.063295D0,0.056281D0,2*0D0,
847 &6*0.020495D0,2*0D0,0.327919D0,0.04099D0,0.045236D0,0.090112D0,
848 &0.19874D0,0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0,
849 &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,
850 &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0,
851 &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0,
852 &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0,
853 &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,
854 &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0/
855 DATA (BRAT(I) ,I=4151,4281)/0.010236D0,0.198928D0,0.000149D0,
856 &0.000006D0,0.000368D0,0.080733D0,0.199344D0,0.010234D0,
857 &0.000003D0,0.010236D0,0.198928D0,0.000149D0,0.000006D0,
858 &0.000368D0,0.080733D0,4*0D0,0.184738D0,0.104588D0,0.184738D0,
859 &0.104587D0,0.184731D0,0.09582D0,0.022902D0,0.008429D0,0.015602D0,
860 &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0,
861 &0.015602D0,0.28959D0,0.01487D0,0.000008D0,0.01487D0,0.289061D0,
862 &0.000492D0,0.000009D0,0.000536D0,0.27911D0,2*0.037151D0,
863 &0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,0.001805D0,
864 &0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0,
865 &0.001808D0,0.81372D0,0D0,6*1D0,0.095602D0,2*0.338272D0,
866 &0.156896D0,0.019193D0,0.017993D0,0.001168D0,0.001462D0,
867 &0.009608D0,0.003306D0,0.002132D0,0.003127D0,0.002132D0,
868 &0.003127D0,0.00213D0,3*0D0,0.001411D0,0.00045D0,0.001411D0,
869 &0.00045D0,0.001411D0,0.00045D0,2*0D0,0.097996D0,0.399787D0,
870 &0.262464D0,0.185427D0,0.022683D0,0.007648D0,0.004259D0,
871 &0.005925D0,0.000304D0,2*0D0,0.000304D0,0.005914D0,0.000002D0,
872 &2*0D0,0.000011D0,0.001258D0,5*0D0,3*0.002005D0,0D0,0.272178D0,
873 &0.022112D0,0.255165D0,0.015534D0,2*0.108965D0,0.031557D0,
874 &0.005562D0,0.044965D0,0.004674D0,0.007637D0,0.020597D0/
875 DATA (BRAT(I) ,I=4282,8000)/0.007636D0,0.020595D0,0.007616D0,
876 &3*0D0,0.017298D0,0.004782D0,0.017298D0,0.004782D0,0.017297D0,
877 &0.004782D0,2*0D0,0.055332D0,2*0.319757D0,0.121576D0,2*0.001556D0,
878 &4*0D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,3*0D0,
879 &0.006071D0,0.01208D0,0.006071D0,0.01208D0,0.006069D0,0.01208D0,
880 &2*0D0,0.035891D0,0.209476D0,0.129084D0,0.286631D0,0.10742D0,
881 &0.109486D0,4*0D0,0.035282D0,0.001812D0,2*0D0,0.001812D0,
882 &0.035215D0,0.000021D0,0D0,0.000001D0,0.000065D0,0.011965D0,5*0D0,
883 &2*0.011947D0,0.011946D0,0D0,
886 &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0,
887 &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0,
888 &0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,
889 &0.33D0,0.66D0,0.01D0,0.98D0,0.D0,0.02D0,0.33D0,0.66D0,0.01D0,
897 DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
898 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
899 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
900 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
901 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
902 &-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,
903 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
904 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
905 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
906 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
907 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
908 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
909 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
910 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
911 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
912 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
913 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
914 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
915 &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
916 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
917 DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
918 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
919 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
920 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
921 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
922 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
923 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
924 &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
925 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
926 &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
927 &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
928 &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
929 &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
930 &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
931 &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
932 &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
933 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
934 &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
935 &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
936 &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
937 DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
938 &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
939 &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
940 &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
941 &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
942 &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
943 &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
944 &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
945 &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
946 &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
947 &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
948 &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
949 &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
950 &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
951 &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
952 &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
953 &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
954 &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
955 &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
956 &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
957 DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
958 &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
959 &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
960 &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
961 &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
962 &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
963 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
964 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
965 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
966 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
967 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
968 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
969 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
970 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
971 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
972 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
973 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
974 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
975 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
976 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
977 DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
978 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
979 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
980 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
981 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
982 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
983 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
984 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
985 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
986 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
987 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
988 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
989 &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
990 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
991 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
992 &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
993 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
994 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
995 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
996 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
997 DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,
998 &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
999 &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
1000 &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
1001 &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
1002 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
1003 &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1004 &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
1005 &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
1006 &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
1007 &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
1008 &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
1009 &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
1010 &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
1011 &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
1012 &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
1013 &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
1014 &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
1015 &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
1016 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
1017 DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,
1018 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1019 &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
1020 &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1021 &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
1022 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
1023 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
1024 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
1025 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
1026 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
1027 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
1028 &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
1029 &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
1030 &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
1031 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
1032 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
1033 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
1034 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
1035 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
1036 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
1037 DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1038 &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1039 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
1040 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
1041 &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
1042 &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
1043 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1044 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1045 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1046 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1047 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1048 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1049 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1050 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1051 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1052 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1053 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1054 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1055 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1056 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
1057 DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
1058 &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
1059 &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
1060 &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
1061 &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
1062 &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
1063 &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1064 &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
1065 &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
1066 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
1067 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
1068 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
1069 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
1070 &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
1071 &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
1072 &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
1073 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
1074 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
1075 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
1076 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
1077 DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,
1078 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1079 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1080 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1081 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1082 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1083 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1084 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1085 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1086 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1087 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1088 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1089 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1090 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1091 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
1092 &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1093 &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
1094 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1095 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
1096 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
1097 DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,
1098 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
1099 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
1100 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
1101 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
1102 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
1103 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
1104 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
1105 &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
1106 &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
1107 &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1108 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
1109 &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1110 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
1111 &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1112 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
1113 &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
1114 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
1115 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
1116 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
1117 DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,
1118 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
1119 &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1120 &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
1121 &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
1122 &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1123 &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1124 &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
1125 &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
1126 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
1127 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
1128 &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
1129 &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
1130 &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
1131 &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
1132 &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
1133 &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
1134 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
1135 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
1136 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
1137 DATA (KFDP(I,1),I=3783,4156)/1000039,1000024,1000037,1000022,
1138 &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
1139 &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1140 &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
1141 &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
1142 &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
1143 &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
1144 &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
1145 &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1146 &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1147 &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1148 &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1149 &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1150 &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
1151 &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
1152 &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
1153 &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,
1154 &5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,3100111,3200111,21,22,23,-24,21,
1155 &22,23,24,22,23,-24,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1156 &21,22,23,24,9*11,9*-11,11,-11,11,-11,9*13,9*-13,13,-13,13,-13,
1158 DATA (KFDP(I,1),I=4157,8000)/9*-15,15,-15,15,-15,1,2,3,4,5,6,11,
1159 &12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15,
1160 &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24,
1161 &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,
1162 &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,
1163 &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,
1164 &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,
1165 &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7,
1169 &5100023,5100022,5100023,5100022,5100023,5100022,
1170 &5100023,5100022,5100023,5100022,5100023,5100022,
1171 &5100023,-5100024,5100022,5100023,5100024,5100022,
1172 &5100023,-5100024,5100022,5100023,5100024,5100022,
1173 &5100023,-5100024,5100022,5100023,5100024,5100022,
1175 &6100001,6100002,6100003,6100004,6100005,6100006,
1176 &5100001,5100002,5100003,5100004,5100005,5100006,
1177 &-6100001,-6100002,-6100003,-6100004,-6100005,-6100006,
1178 &-5100001,-5100002,-5100003,-5100004,-5100005,-5100006,
1180 &6100011,6100013,6100015,
1181 &5100011,5100013,5100015,
1182 %5100012,5100014,5100016,
1183 &-6100011,-6100013,-6100015,
1184 &-5100011,-5100013,-5100015,
1185 %-5100012,-5100014,-5100016,
1186 &-5100011,-5100013,-5100015,
1187 &5100012,5100014,5100016,
1189 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,
1190 &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,
1191 &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,
1192 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1193 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1194 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1195 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1196 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1197 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1198 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1199 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1200 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1201 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1202 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1203 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1204 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1205 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1206 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1207 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1208 &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/
1209 DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1210 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1211 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1212 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1213 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1214 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1215 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1216 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1217 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1218 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1219 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1220 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1221 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1222 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1223 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1224 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1225 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1226 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1227 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1228 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1229 DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1230 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1231 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1232 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1233 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1234 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1235 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1236 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1237 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1238 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1239 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1240 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1241 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1242 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1243 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1244 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1245 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1246 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1247 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1248 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1249 DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1250 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1251 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1252 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1253 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1254 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1255 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1256 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1257 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1258 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1259 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1260 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1261 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1262 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1263 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1264 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1265 &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,
1266 &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,
1267 &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,
1268 &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/
1269 DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1270 &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,
1271 &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,
1272 &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,
1273 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1274 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1275 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1276 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1277 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1278 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1279 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1280 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1281 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1282 &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,
1283 &-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,
1284 &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,
1285 &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,
1286 &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,
1287 &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,
1288 &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/
1289 DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1290 &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,
1291 &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1292 &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,
1293 &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1294 &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,
1295 &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,
1296 &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,
1297 &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,
1298 &-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,
1299 &-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,
1300 &-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,
1301 &-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,
1302 &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1303 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1304 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1305 &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,
1306 &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,
1307 &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,
1308 &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/
1309 DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1310 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1311 &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1312 &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1313 &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1314 &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1315 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1316 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1317 &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,
1318 &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,
1319 &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,
1320 &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,
1321 &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1322 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1323 &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,
1324 &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1325 &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1326 &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1327 &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1328 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1329 DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1330 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1331 &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,
1332 &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,
1333 &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1334 &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1335 &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1336 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1337 &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1338 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1339 &-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,
1340 &-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,
1341 &-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,
1342 &-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,
1343 &-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,
1344 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1345 &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,
1346 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1347 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1348 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1349 DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1350 &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1351 &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1352 &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1353 &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,
1354 &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,
1355 &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,
1356 &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,
1357 &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1358 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1359 &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1360 &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1361 &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1362 &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1363 &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1364 &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1365 &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1366 &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1367 &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1368 &-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/
1369 DATA (KFDP(I,2),I=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1370 &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,
1371 &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,
1372 &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,
1373 &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,
1374 &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,
1375 &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,
1376 &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,
1377 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1378 &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,
1379 &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,
1380 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1381 &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1382 &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,
1383 &-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,
1384 &-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1385 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1386 &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,-13,13,-15,15,3*-1,3*-3,
1387 &3*-5,3*1,3*3,3*5,-11,11,-15,15,3*-1,3*-3,3*-5,3*1,3*3,3*5,-11,11,
1388 &-13,13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/
1389 DATA (KFDP(I,2),I=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012,
1390 &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15,
1391 &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111,
1392 &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,
1393 &-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8,
1394 &2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211,
1395 &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
1396 &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213,
1397 &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1398 &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113,
1399 &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
1402 &1,1,2,2,3,3,4,4,5,5,6,6,
1403 &1,2,1,2,1,2,3,4,3,4,3,4,5,6,5,6,5,6,
1404 &11,13,15,12,11,14,13,16,15,
1405 &-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,
1406 &1,2,3,4,5,6,1,2,3,4,5,6,
1408 &-11,-13,-15,-11,-13,-15,-12,-14,-16,
1409 &11,13,15,11,13,15,12,14,16,
1410 &12,14,16,-11,-13,-15,
1412 DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1413 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1414 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1415 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1416 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1417 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1418 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1419 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1420 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1421 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1422 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1423 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1424 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1425 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1426 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1427 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1428 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1429 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1430 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1431 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1432 DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1433 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1434 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1435 &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,
1436 &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,
1437 &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,
1438 &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,
1439 &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,
1440 &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,
1441 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1442 &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1443 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1444 &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,
1445 &-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,
1446 &-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,
1447 &-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,
1448 &-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,
1449 &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1450 &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1451 &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1452 DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1453 &-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,
1454 &-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,
1455 &-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,
1456 &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1457 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1458 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1459 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1460 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1461 &-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,
1462 &-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,
1463 &-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,
1464 &-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,
1465 &-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,
1466 &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1467 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1468 &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1469 &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,
1470 &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,
1471 &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/
1472 DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1473 &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,
1474 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1475 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1476 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1477 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1478 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1479 &-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,
1480 &-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,
1481 &-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,
1482 &-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,
1483 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1484 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1485 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1486 &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1487 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1488 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1489 &-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,
1490 &-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,
1491 &-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/
1492 DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1493 &-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,
1494 &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1495 &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,
1496 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1497 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1498 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1499 &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,
1500 &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,
1501 &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,
1502 &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,
1503 &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,
1504 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,
1505 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,
1506 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/
1507 DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1508 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1509 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1510 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1511 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1512 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1513 &-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,
1514 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1515 &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,
1516 &162*81,31*0,-211,111,6516*0/
1517 DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1518 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1519 &3*111,-211,111,7193*0/
1521 C...PYDAT4, with particle names (character strings).
1522 DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''',
1523 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1524 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1525 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1526 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1527 &'junction',' ','system','cluster','string','indep.','CMshower',
1528 &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',
1529 &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',
1530 &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1531 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1532 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1533 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1534 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1535 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1536 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1537 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1538 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1539 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1540 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1541 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1542 DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1543 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1544 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1545 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1546 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1547 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1548 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1549 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1550 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1551 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1552 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1553 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1554 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1555 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1556 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1557 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1558 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1559 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1560 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1561 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1562 DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1563 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1564 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1565 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1566 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1567 &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',
1568 &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+',
1571 &'d*_S','u*_S','s*_S','c*_S','b*_S','t*_S',
1572 &'d*_D','u*_D','s*_D','c*_D','b*_D','t*_D',
1573 &'e*_S-','mu*_S-','tau*_S-',
1574 &'nu*_eD','e*_D-','nu*_muD','mu*_D-','nu*_tauD','tau*_D-',
1575 &'g*','gamma*','Z*0','W*+',25*' '/
1576 DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1577 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1578 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1579 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1580 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1581 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1582 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1583 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1584 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1585 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1586 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1587 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1588 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1589 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1590 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1591 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1592 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1593 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1594 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1595 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1596 DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1597 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1598 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1599 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1600 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1601 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1602 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1603 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1604 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1605 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1606 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1607 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1608 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1609 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1610 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1611 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1612 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1613 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1614 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1615 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1616 DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1617 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1618 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1619 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-',
1622 &'d*_Sbar','u*_Sbar','s*_Sbar','c*_Sbar','b*_Sbar','t*_Sbar',
1623 &'d*_Dbar','u*_Dbar','s*_Dbar','c*_Dbar','b*_Dbar','t*_Dbar',
1624 &'e*_Sbar+','mu*_Sbar+','tau*_Sbar+',
1625 &'nu*_eDbar','e*_Dbar+',
1626 &'nu*_muDbar','mu*_Dbar+',
1627 &'nu*_tauDbar','tau*_Dbar+',
1628 &'g*','gamma*','Z*0','W*-',25*' '/
1630 C...PYDATR, with initial values for the random number generator.
1631 DATA MRPY/19780503,0,0,97,33,0/
1633 C...Default values for allowed processes and kinematics constraints.
1636 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1637 &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,
1640 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1641 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1642 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1643 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1644 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1645 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1646 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1647 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1648 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1649 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1650 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1651 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1652 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1653 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1654 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1655 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1658 C...Default values for main switches and parameters. Reset information.
1659 DATA (MSTP(I),I=1,100)/
1660 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1661 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1662 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1663 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1664 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1665 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1666 6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0,
1667 7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1668 8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0,
1669 9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/
1670 DATA (MSTP(I),I=101,200)/
1671 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1672 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1673 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1674 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1675 4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
1676 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1677 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1678 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1679 8 6, 421, 2009, 07, 13, 0, 0, 0, 0, 0,
1680 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1681 DATA (PARP(I),I=1,100)/
1682 & 0.25D0, 10D0, 8*0D0,
1683 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1685 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
1686 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1688 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1689 7 4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0,
1690 8 1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0,
1691 8 0.95D0, 0.7D0, 0.5D0, 1800D0, 0.25D0,
1692 9 2.0D0,0.40D0,5.0D0,1.0D0,0.0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1693 DATA (PARP(I),I=101,200)/
1694 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1695 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1696 2 1.0D0, 0.4D0, 8*0D0,
1698 4 1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0,
1699 4 9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0,
1700 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1701 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1702 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1703 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1705 9 0.64D0, 5.0D0, 1.0D4, 1.0D4, 6*0D0/
1711 C...Constants for the generation of the various processes.
1712 DATA (ISET(I),I=1,100)/
1713 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1714 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1715 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1716 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1717 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1718 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1719 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1720 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1721 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1722 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1723 DATA (ISET(I),I=101,200)/
1724 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1725 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1726 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1727 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1728 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1729 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1730 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1731 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1732 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1733 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1734 DATA (ISET(I),I=201,300)/
1735 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1736 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1737 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1738 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1739 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1740 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1741 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1742 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1743 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1744 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1745 DATA (ISET(I),I=301,500)/
1746 & 2, 9*-2, 9*2, 21*-2,
1747 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1748 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1749 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1750 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1751 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1752 9 1, 1, 2, 2, 2, 5*-2,
1754 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1755 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2,
1756 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1757 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2/
1758 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1759 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1760 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1761 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1762 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1763 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1764 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1765 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1766 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1767 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1768 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1769 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1770 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1771 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1772 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1773 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1774 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1775 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1776 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1777 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1778 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1779 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1780 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1781 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1782 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1783 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1784 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1785 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1786 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1787 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1788 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1789 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1790 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1791 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1792 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1793 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1794 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1795 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1796 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1797 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1798 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1799 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1800 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1801 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1802 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1803 & 1000011, 1000011, 2000011, 2000011, 1000011,
1804 & 2000011, 1000013, 1000013, 2000013, 2000013,
1805 & 1000013, 2000013, 1000015, 1000015, 2000015,
1806 & 2000015, 1000015, 2000015, 1000011, 1000012,
1807 1 1000015, 1000016, 2000015, 1000016, 1000012,
1808 1 1000012, 1000016, 1000016, 0, 0,
1809 1 1000022, 1000022, 1000023, 1000023, 1000025,
1810 1 1000025, 1000035, 1000035, 1000022, 1000023,
1811 2 1000022, 1000025, 1000022, 1000035, 1000023,
1812 2 1000025, 1000023, 1000035, 1000025, 1000035,
1813 2 1000024, 1000024, 1000037, 1000037, 1000024,
1814 2 1000037, 1000022, 1000024, 1000023, 1000024,
1815 3 1000025, 1000024, 1000035, 1000024, 1000022,
1816 3 1000037, 1000023, 1000037, 1000025, 1000037,
1817 3 1000035, 1000037, 1000021, 1000022, 1000021,
1818 3 1000023, 1000021, 1000025, 1000021, 1000035/
1819 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1820 4 1000021, 1000024, 1000021, 1000037, 1000021,
1821 4 1000021, 1000021, 1000021, 0, 0,
1822 4 1000002, 1000022, 2000002, 1000022, 1000002,
1823 4 1000023, 2000002, 1000023, 1000002, 1000025,
1824 5 2000002, 1000025, 1000002, 1000035, 2000002,
1825 5 1000035, 1000001, 1000024, 2000005, 1000024,
1826 5 1000001, 1000037, 2000005, 1000037, 1000002,
1827 5 1000021, 2000002, 1000021, 0, 0,
1828 6 1000006, 1000006, 2000006, 2000006, 1000006,
1829 6 2000006, 1000006, 1000006, 2000006, 2000006,
1832 7 1000002, 1000002, 2000002, 2000002, 1000002,
1833 7 2000002, 1000002, 1000002, 2000002, 2000002,
1834 7 1000002, 2000002, 1000002, 1000002, 2000002,
1835 7 2000002, 1000002, 1000002, 2000002, 2000002/
1836 DATA ((KFPR(I,J),J=1,2),I=281,350)/
1837 8 1000005, 1000002, 2000005, 2000002, 1000005,
1838 8 2000002, 1000005, 1000002, 2000005, 2000002,
1839 8 1000005, 2000002, 1000005, 1000005, 2000005,
1840 8 2000005, 1000005, 1000005, 2000005, 2000005,
1841 9 1000005, 1000005, 2000005, 2000005, 1000005,
1842 9 2000005, 1000005, 1000021, 2000005, 1000021,
1843 9 1000005, 2000005, 37, 25, 37,
1844 9 35, 36, 25, 36, 35,
1850 & 5100002, -5100002,
1851 & 5100002, -5100002,
1852 & 5100002, -6100001,
1853 & 5100002, -5100001,
1855 & 5100001, -5100001,
1857 4 9900041, 0, 9900042, 0, 9900041,
1858 4 11, 9900042, 11, 9900041, 13,
1859 4 9900042, 13, 9900041, 15, 9900042,
1860 4 15, 9900041, 9900041, 9900042, 9900042/
1861 DATA ((KFPR(I,J),J=1,2),I=351,400)/
1862 5 9900041, 0, 9900042, 0, 9900023,
1863 5 0, 9900024, 0, 0, 0,
1866 6 24, 24, 24, 3000211, 3000211,
1867 6 3000211, 22, 3000111, 22, 3000221,
1868 6 23, 3000111, 23, 3000221, 24,
1869 6 3000211, 0, 0, 24, 23,
1870 7 24, 3000111, 3000211, 23, 3000211,
1871 7 3000111, 22, 3000211, 23, 3000211,
1872 7 24, 3000111, 24, 3000221, 22,
1873 7 24, 22, 23, 23, 23,
1874 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1875 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1876 9 5000039, 0, 5000039, 0, 21,
1877 9 5000039, 0, 5000039, 21, 5000039,
1879 DATA ((KFPR(I,J),J=1,2),I=401,500)/
1880 & 37, 6, 37, 6, 36*0,
1881 2 443, 21, 9900443, 21, 9900441,
1882 2 21, 9910441, 21, 0, 9900443,
1883 2 0, 9900441, 0, 9910441, 21,
1884 2 9900443, 21, 9900441, 21, 9910441,
1885 3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443,
1886 3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0,
1887 6 553, 21, 9900553, 21, 9900551,
1888 6 21, 9910551, 21, 0, 9900553,
1889 6 0, 9900551, 0, 9910551, 21,
1890 6 9900553, 21, 9900551, 21, 9910551,
1891 7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553,
1892 7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/
1893 DATA COEF/10000*0D0/
1894 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1895 &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,
1896 &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,
1897 &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,
1898 &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,
1899 &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,
1900 &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,
1901 &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,
1902 &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,
1903 &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,
1904 &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/
1906 C...Treatment of resonances.
1907 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1908 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1,
1909 &81*0,21*1,4*1,25*0/
1911 C...Character constants: name of processes.
1912 DATA PROC(0)/ 'All included subprocesses '/
1913 DATA (PROC(I),I=1,20)/
1914 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1915 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1916 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1917 &' ', 'W+ + W- -> h0 ',
1918 &' ', 'f + f'' -> f + f'' (QFD) ',
1919 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1920 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1921 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1922 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1923 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1924 DATA (PROC(I),I=21,40)/
1925 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1926 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1927 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1928 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1929 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1930 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1931 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1932 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1933 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1934 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1935 DATA (PROC(I),I=41,60)/
1936 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1937 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1938 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1939 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1940 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1941 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1942 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1943 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1944 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1945 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1946 DATA (PROC(I),I=61,80)/
1947 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1948 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1949 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1950 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1951 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1952 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1953 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1954 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1955 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1956 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1957 DATA (PROC(I),I=81,100)/
1958 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1959 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1960 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1961 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1962 8'g + g -> chi_2c + g ', ' ',
1963 9'Elastic scattering ', 'Single diffractive (XB) ',
1964 9'Single diffractive (AX) ', 'Double diffractive ',
1965 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1967 9'q + gamma* -> q ', ' '/
1968 DATA (PROC(I),I=101,120)/
1969 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1970 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1971 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1972 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1973 &' ', 'f + fbar -> gamma + h0 ',
1974 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1975 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1976 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1977 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1979 DATA (PROC(I),I=121,140)/
1980 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1981 2'f + f'' -> f + f'' + h0 ',
1982 2'f + f'' -> f" + f"'' + h0 ',
1986 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1987 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1988 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1989 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1990 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1991 DATA (PROC(I),I=141,160)/
1992 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1993 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1994 4'q + l -> LQ ', 'e + gamma -> e* ',
1995 4'd + g -> d* ', 'u + g -> u* ',
1996 4'g + g -> eta_tc ', ' ',
1997 5'f + fbar -> H0 ', 'g + g -> H0 ',
1998 5'gamma + gamma -> H0 ', ' ',
1999 5' ', 'f + fbar -> A0 ',
2000 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
2002 DATA (PROC(I),I=161,180)/
2003 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
2004 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
2005 6'f + fbar -> f'' + fbar'' (g/Z)',
2006 6'f +fbar'' -> f" + fbar"'' (W) ',
2007 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
2008 6'q + qbar -> e + e* ', ' ',
2009 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
2010 7'f + f'' -> f + f'' + H0 ',
2011 7'f + f'' -> f" + f"'' + H0 ',
2012 7' ', 'f + fbar -> Z0 + A0 ',
2013 7'f + fbar'' -> W+/- + A0 ',
2014 7'f + f'' -> f + f'' + A0 ',
2015 7'f + f'' -> f" + f"'' + A0 ',
2017 DATA (PROC(I),I=181,200)/
2018 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
2019 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
2020 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
2021 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
2022 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
2023 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
2024 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
2025 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
2028 DATA (PROC(I),I=201,220)/
2029 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
2030 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
2031 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
2032 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
2033 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
2034 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
2035 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
2036 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
2037 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
2038 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
2039 DATA (PROC(I),I=221,240)/
2040 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
2041 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
2042 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
2043 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
2044 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
2045 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
2046 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
2047 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
2048 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
2049 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
2050 DATA (PROC(I),I=241,260)/
2051 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
2052 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
2053 4' ', 'qj + g -> ~qj_L + ~chi1 ',
2054 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
2055 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
2056 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
2057 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
2058 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
2059 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
2060 5'qj + g -> ~qj_R + ~g ', ' '/
2061 DATA (PROC(I),I=261,300)/
2062 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
2063 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
2064 6'g + g -> ~t_2 + ~t_2bar ', ' ',
2067 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
2068 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
2069 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
2070 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
2071 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
2072 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
2073 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
2074 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
2075 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
2076 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
2077 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
2078 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
2079 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
2080 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
2081 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
2082 DATA (PROC(I),I=301,340)/
2083 &'f + fbar -> H+ + H- ',
2084 &9*' ', 'g + g -> g* + g* ',
2085 &'q + g -> q*_D + g* ', 'qi + qj -> q*_Di + q*_Dj ',
2086 &'g + g -> q*_D + q*_Dbar ', 'q + qbar -> q*_D + q*_Dbar ',
2087 &'qi + qbarj -> q*Di + q*Sbarj', 'qi + qjbar -> q*Di + q*Dbarj',
2088 &'qi + qj -> q*_Di + q*_Sj ', 'qi + qibar -> q*Dj + q*Dbarj',
2090 DATA (PROC(I),I=341,380)/
2091 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
2092 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
2093 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
2094 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
2095 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
2096 5'f + f -> f'' + f'' + H_L++/-- ',
2097 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
2098 5'f + fbar'' -> W_R+/- ',5*' ',
2099 6' ', 'f + fbar -> W_L+ W_L- ',
2100 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
2101 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
2102 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
2103 6'f + fbar -> W+/- pi_T-/+ ', ' ',
2104 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
2105 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
2106 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
2107 7'f + fbar'' -> W+/- pi_T0 ',
2108 7'f + fbar'' -> W+/- pi_T0'' ',
2109 7'f + fbar'' -> gamma W+/-(ETC)','f + fbar -> gamma Z0 (ETC)',
2110 7'f + fbar -> Z0 Z0 (ETC) '/
2111 DATA (PROC(I),I=381,420)/
2112 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
2113 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
2114 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
2115 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
2117 9'f + fbar -> G* ', 'g + g -> G* ',
2118 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
2119 9'g + g -> g + G* ', ' ',
2121 &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
2123 DATA (PROC(I),I=421,460)/
2124 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
2125 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
2126 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
2127 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
2128 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
2129 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
2130 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
2131 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
2132 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
2133 3'q + q~ -> g + cc~[3P2(1)] ',
2135 DATA (PROC(I),I=461,500)/
2136 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
2137 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
2138 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
2139 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
2140 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
2141 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
2142 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
2143 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
2144 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
2145 7'q + q~ -> g + bb~[3P2(1)] ',
2148 C...Cross sections and slope offsets.
2151 C...Supersymmetry switches and parameters.
2153 & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
2156 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
2157 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
2158 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
2162 C...Initial values for R-violating SUSY couplings.
2163 C...Should not be changed here. See PYMSIN.
2168 C...Technicolor switches and parameters
2170 & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2173 & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
2174 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2175 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
2176 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2177 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0,
2180 C...UED switches and parameters.
2181 C... IUED(0) empty IUED vector element
2182 C... IUED(1) UED ON(=1)/OFF(=0) switch
2183 C... IUED(2) ON(=1)/OFF(=0) switch for gravity mediated decays
2184 C... IUED(3) NFLAVOURS Number of KK excitation quark flavours
2185 C... IUED(4) N the number of large extra dimensions
2186 C... IUED(5) Selects whether the code takes Lambda (=0)
2187 C... or Lambda*R (=1) as input.
2188 C... IUED(6) With radiative corrections to the masses (=1)
2189 C... or without (=0)
2191 C... RUED(0) empty RUED vector element
2192 C... RUED(1) RINV (1/R) the curvature of the extra dimension
2193 C... RUED(2) XMD the (4+N)-dimensional Planck scale
2194 C... RUED(3) LAMUED (Lambda cutoff scale)
2195 C... RUED(4) LAMUED/RINV (feasible values are order of 10-20)
2197 DATA IUED/0,0,0,5,6,0,1,93*0/
2198 DATA RUED/0.D0,1000D0,5000D0,20000.,20.,95*0D0/
2200 C...Data for histogramming routines.
2201 DATA IHIST/1000,20000,55,1/
2204 C...Data for SUSY Les Houches Accord.
2205 DATA CPRO/'PYTHIA ','PYTHIA '/
2206 DATA CVER/'6.4 ','6.4 '/
2208 DATA PARMIN/100*0D0/
2209 DATA RMSOFT/101*0D0/
2216 C*********************************************************************
2219 C...Check that BLOCK DATA PYDATA has been loaded.
2220 C...Should not be required, except that some compilers/linkers
2221 C...are pretty buggy in this respect.
2225 C...Double precision and integer declarations.
2226 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2227 IMPLICIT INTEGER(I-N)
2228 INTEGER PYK,PYCHGE,PYCOMP
2230 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2231 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2232 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2233 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2234 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2235 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2236 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2238 C...Check a few variables to see they have been sensibly initialized.
2239 IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
2240 &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
2242 C...If not, abort the run right away.
2243 WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
2244 WRITE(*,*) 'The program execution is stopped now!'
2251 C*********************************************************************
2254 C...A simple program (disguised as subroutine) to run at installation
2255 C...as a check that the program works as intended.
2257 SUBROUTINE PYTEST(MTEST)
2259 C...Double precision and integer declarations.
2260 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2261 IMPLICIT INTEGER(I-N)
2262 INTEGER PYK,PYCHGE,PYCOMP
2264 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2265 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2266 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2267 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2268 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2269 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2270 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2272 DIMENSION PSUM(5),PINI(6),PFIN(6)
2274 C...Save defaults for values that are changed.
2291 C...First part: loop over simple events to be generated.
2292 IF(MTEST.GE.1) CALL PYTABU(20)
2296 C...Reset parameter values. Switch on some nonstandard features.
2311 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
2313 C...Ten events each for some single jets configurations.
2317 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
2318 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
2319 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
2320 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
2321 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
2322 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
2324 C...Ten events each for some simple jet systems; string fragmentation.
2325 ELSEIF(IEV.LE.130) THEN
2327 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
2328 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
2329 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
2330 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
2331 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
2332 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
2333 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
2334 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
2335 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2337 C...Seventy events with independent fragmentation and momentum cons.
2338 ELSEIF(IEV.LE.200) THEN
2340 MSTJ(2)=1+MOD(IEV-131,4)
2341 MSTJ(3)=1+MOD((IEV-131)/4,4)
2342 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
2343 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
2344 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
2345 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2346 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
2347 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2349 C...A hundred events with random jets (check invariant mass).
2350 ELSEIF(IEV.LE.300) THEN
2357 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
2358 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
2359 EJET=5D0+20D0*PYR(0)
2360 THETA=ACOS(2D0*PYR(0)-1D0)
2362 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
2363 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
2364 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
2365 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
2367 PSUM(J)=PSUM(J)+P(I,J)
2370 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2371 & (PSUM(5)+PARJ(32))**2) GOTO 100
2373 C...Fifty e+e- continuum events with matrix elements.
2374 ELSEIF(IEV.LE.350) THEN
2378 C...Fifty e+e- continuum event with varying shower options.
2379 ELSEIF(IEV.LE.400) THEN
2380 MSTJ(42)=1+MOD(IEV,2)
2381 MSTJ(43)=1+MOD(IEV/2,4)
2382 MSTJ(44)=MOD(IEV/8,3)
2385 C...Fifty e+e- continuum events with coherent shower.
2386 ELSEIF(IEV.LE.450) THEN
2387 CALL PYEEVT(0,500D0)
2389 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2391 CALL PYONIA(5,9.46D0)
2394 C...Generate event. Find total momentum, energy and charge.
2405 C...Check conservation of energy, momentum and charge;
2406 C...usually exact, but only approximate for single jets.
2409 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2411 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2412 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2413 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2416 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2418 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2420 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2421 & (PFIN(J),J=1,4),PFIN(6)
2423 C...Check that all KF codes are known ones, and that partons/particles
2424 C...satisfy energy-momentum-mass relation. Store particle statistics.
2426 IF(K(I,1).GT.20) GOTO 170
2427 IF(PYCOMP(K(I,2)).EQ.0) THEN
2428 WRITE(MSTU(11),5100) I
2431 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2432 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2434 WRITE(MSTU(11),5200) I
2438 IF(MTEST.GE.1) CALL PYTABU(21)
2440 C...List all erroneous events and some normal ones.
2441 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2442 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2444 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2448 C...Stop execution if too many errors.
2449 IF(MERR.NE.0) NERR=NERR+1
2451 WRITE(MSTU(11),6300)
2457 C...Summarize result of run.
2458 IF(MTEST.GE.1) CALL PYTABU(22)
2460 C...Reset commonblock variables changed during run.
2477 C...Second part: complete events of various kinds.
2478 C...Common initial values. Loop over initiating conditions.
2479 MSTP(122)=MAX(0,MIN(2,MTEST))
2480 MDCY(PYCOMP(111),1)=0
2483 C...Reset process type, kinematics cuts, and the flags used.
2500 C...Prompt photon production at fixed target.
2503 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2507 CALL PYINIT('FIXT','pi+','p',PZSUM)
2509 C...QCD processes at ISR energies.
2510 ELSEIF(IPROC.EQ.2) THEN
2516 CALL PYINIT('CMS','p','p',PESUM)
2518 C...W production + multiple interactions at CERN Collider.
2519 ELSEIF(IPROC.EQ.3) THEN
2528 CALL PYINIT('CMS','p','pbar',PESUM)
2530 C...W/Z gauge boson pairs + pileup events at the Tevatron.
2531 ELSEIF(IPROC.EQ.4) THEN
2543 CALL PYINIT('CMS','p','pbar',PESUM)
2545 C...Higgs production at LHC.
2546 ELSEIF(IPROC.EQ.5) THEN
2558 CALL PYINIT('CMS','p','p',PESUM)
2560 C...Z' production at SSC.
2561 ELSEIF(IPROC.EQ.6) THEN
2570 CALL PYINIT('CMS','p','p',PESUM)
2572 C...W pair production at 1 TeV e+e- collider.
2573 ELSEIF(IPROC.EQ.7) THEN
2580 CALL PYINIT('CMS','e+','e-',PESUM)
2582 C...Deep inelastic scattering at a LEP+LHC ep collider.
2583 ELSEIF(IPROC.EQ.8) THEN
2596 CALL PYINIT('3MOM','p','e-',PESUM)
2599 C...Generate 20 events of each required type.
2603 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2605 C...Check conservation of energy/momentum/flavour.
2616 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2617 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2618 DEVQ=ABS(PFIN(6)-PINI(6))
2619 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2620 & DEVQ.GT.0.1D0) MERR=1
2621 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2622 & (PFIN(J),J=1,4),PFIN(6)
2624 C...Check that all KF codes are known ones, and that partons/particles
2625 C...satisfy energy-momentum-mass relation.
2627 IF(K(I,1).GT.20) GOTO 210
2628 IF(PYCOMP(K(I,2)).EQ.0) THEN
2629 WRITE(MSTU(11),5100) I
2632 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2634 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2635 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2636 WRITE(MSTU(11),5200) I
2641 C...Listing of erroneous events, and first event of each type.
2642 IF(MERR.GE.1) NERR=NERR+1
2644 WRITE(MSTU(11),6300)
2648 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2649 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2654 C...List statistics for each process type.
2655 IF(MTEST.GE.1) CALL PYSTAT(1)
2658 C...Summarize result of run.
2659 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2660 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2662 C...Format statements for output.
2663 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2664 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2665 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2666 &4(1X,F12.5),1X,F8.2)
2667 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2668 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2670 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2671 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2672 6400 FORMAT(5X,'Faulty event follows:')
2673 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2674 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2675 &5X,'This should not have happened!')
2680 C*********************************************************************
2683 C...Converts PYTHIA event record contents to or from
2684 C...the standard event record commonblock.
2686 SUBROUTINE PYHEPC(MCONV)
2688 C...Double precision and integer declarations.
2689 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2690 IMPLICIT INTEGER(I-N)
2691 INTEGER PYK,PYCHGE,PYCOMP
2693 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2694 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2695 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2696 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2697 C...HEPEVT commonblock.
2698 PARAMETER (NMXHEP=4000)
2699 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2700 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2701 DOUBLE PRECISION PHEP,VHEP
2704 C...Store HEPEVT commonblock size (for interfacing issues).
2707 C...Conversion from PYTHIA to standard, the easy part.
2710 IF(N.GT.NMXHEP) CALL PYERRM(8,
2711 & '(PYHEPC:) no more space in /HEPEVT/')
2715 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2716 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2717 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2718 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2722 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2736 C...Check if new event (from pileup).
2740 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2743 C...Fill in missing mother information.
2744 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2746 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0)
2753 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2756 IF(I1.GE.I) CALL PYERRM(8,
2757 & '(PYHEPC:) translation of inconsistent event history')
2758 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130
2760 IF(I1.LT.I.AND.KC.EQ.0) GOTO 130
2761 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130
2763 ELSEIF(K(I,2).EQ.94) THEN
2765 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2766 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2767 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2768 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2769 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2772 C...Fill in missing daughter information.
2773 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2774 DO 140 I1=JDAHEP(1,I),JDAHEP(2,I)
2775 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2779 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150
2781 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150
2782 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150
2783 IF(JDAHEP(1,I1).EQ.0) THEN
2790 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160
2791 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2794 C...Conversion from standard to PYTHIA, the easy part.
2796 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2797 & '(PYHEPC:) no more space in /PYJETS/')
2803 IF(ISTHEP(I).EQ.1) K(I,1)=1
2804 IF(ISTHEP(I).EQ.2) K(I,1)=11
2805 IF(ISTHEP(I).EQ.3) K(I,1)=21
2817 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2819 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2820 & PHEP(5,I)/PHEP(4,I)
2823 C...Fill in missing information on colour connection in jet systems.
2824 IF(ISTHEP(I).EQ.1) THEN
2827 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2828 IF(KQ.NE.0) NKQ=NKQ+1
2829 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2830 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2832 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2833 IF(K(I+1,2).EQ.21) K(I,1)=2
2837 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2838 & '(PYHEPC:) input parton configuration not colour singlet')
2843 C*********************************************************************
2846 C...Initializes the generation procedure; finds maxima of the
2847 C...differential cross-sections to be used for weighting.
2849 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2851 C...Double precision and integer declarations.
2852 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2853 IMPLICIT INTEGER(I-N)
2854 INTEGER PYK,PYCHGE,PYCOMP
2856 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2857 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2858 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2859 COMMON/PYDAT4/CHAF(500,2)
2861 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2862 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2863 COMMON/PYINT1/MINT(400),VINT(400)
2864 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2865 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2866 COMMON/PYPUED/IUED(0:99),RUED(0:99)
2867 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2868 &/PYINT1/,/PYINT2/,/PYINT5/,/PYPUED/
2869 C...Local arrays and character variables.
2870 DIMENSION ALAMIN(20),NFIN(20)
2871 CHARACTER*(*) FRAME,BEAM,TARGET
2872 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2874 C...Interface to PDFLIB.
2875 COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS
2876 COMMON/W50512/QCDL4,QCDL5
2877 SAVE /W50511/,/W50512/
2878 DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
2879 CHARACTER*20 PARM(20)
2880 DATA VALUE/20*0D0/,PARM/20*' '/
2882 C...Data:Lambda and n_f values for parton distributions..
2883 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2884 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2886 DATA CHLH/'lepton','hadron'/
2888 C...Check that BLOCK DATA PYDATA has been loaded.
2891 C...Reset MINT and VINT arrays. Write headers.
2897 IF(MSTU(12).NE.12345) CALL PYLIST(0)
2898 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2900 C...Reset error counters.
2905 C...Reset processes that should not be on.
2909 C...Select global FSR/ISR/UE parameter set = 'tune'
2910 C...See routine PYTUNE for details
2911 IF (MSTP(5).NE.0) THEN
2916 C...Call user process initialization routine.
2917 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2923 C...Maximum 4 generations; set maximum number of allowed flavours.
2924 MSTP(1)=MIN(4,MSTP(1))
2925 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2926 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2928 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2932 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2935 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2936 IPM=(5-ISIGN(1,I))/2
2938 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2939 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2941 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2946 C...Initialize parton distributions: PDFLIB.
2947 IF(MSTP(52).EQ.2) THEN
2951 VALUE(2)=MSTP(51)/1000
2953 VALUE(3)=MOD(MSTP(51),1000)
2956 CALL PDFSET_ALICE(PARM,VALUE)
2957 MINT(93)=1000000+MSTP(51)
2960 C...Choose Lambda value to use in alpha-strong.
2962 IF(MSTP(3).GE.2) THEN
2965 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2966 ALAM=ALAMIN(MSTP(51))
2968 ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
2971 ELSEIF(MSTP(52).EQ.2) THEN
2980 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2983 C...Initialize the UED masses and widths
2984 IF (IUED(1).EQ.1) CALL PYXDIN
2986 C...Initialize the SUSY generation: couplings, masses,
2987 C...decay modes, branching ratios, and so on.
2989 C...Initialize widths and partial widths for resonances.
2991 C...Set Z0 mass and width for e+e- routines.
2992 PARJ(123)=PMAS(23,1)
2993 PARJ(124)=PMAS(23,2)
2995 C...Identify beam and target particles and frame of process.
2999 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
3000 IF(MINT(65).EQ.1) GOTO 170
3002 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
3003 C...For e-gamma allow 2 alternatives.
3005 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3006 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3007 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
3008 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
3009 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3010 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
3011 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3012 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3013 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
3014 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
3015 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3016 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3017 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
3018 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
3019 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3020 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3021 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
3022 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
3025 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
3026 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
3027 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
3028 IF(MSTP(14).EQ.11) MINT(123)=0
3029 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
3030 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
3031 IF(MSTP(14).EQ.15) MINT(123)=2
3032 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
3033 IF(MSTP(14).EQ.19) MINT(123)=3
3034 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
3035 IF(MSTP(14).EQ.21) MINT(123)=0
3036 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
3037 IF(MSTP(14).EQ.24) MINT(123)=1
3038 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
3039 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
3040 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
3043 C...Set up kinematics of process.
3046 C...Set up kinematics for photons inside leptons.
3047 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
3049 C...Precalculate flavour selection weights.
3052 C...Loop over gamma-p or gamma-gamma alternatives.
3055 DO 160 IGA=1,MINT(121)
3059 C...Select partonic subprocesses to be included in the simulation.
3066 C...Count number of subprocesses on.
3069 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
3070 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
3072 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
3073 & MSUB(ISUB).EQ.1) THEN
3074 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
3076 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
3077 WRITE(MSTU(11),5300) ISUB
3079 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
3080 WRITE(MSTU(11),5400) ISUB
3082 ELSEIF(MSUB(ISUB).EQ.1) THEN
3087 C...Stop or raise warning flag if no subprocesses on.
3088 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
3089 IF(MSTP(127).NE.1) THEN
3090 WRITE(MSTU(11),5500)
3093 WRITE(MSTU(11),5700)
3097 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
3098 MSAV48=MSAV48+MINT(48)
3100 C...Reset variables for cross-section calculation.
3108 C...Find parametrized total cross-sections.
3112 C...Maxima of differential cross-sections.
3113 IF(MSTP(121).LE.1) CALL PYMAXI
3115 C...Initialize possibility of pileup events.
3116 IF(MINT(121).GT.1) MSTP(131)=0
3117 IF(MSTP(131).NE.0) CALL PYPILE(1)
3119 C...Initialize multiple interactions with variable impact parameter.
3120 IF(MINT(50).EQ.1) THEN
3121 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
3122 IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
3123 & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
3124 IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
3132 C...Save results for gamma-p and gamma-gamma alternatives.
3133 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
3136 C...Initialization finished.
3137 IF(MSAV48.EQ.0) THEN
3138 IF(MSTP(127).NE.1) THEN
3139 WRITE(MSTU(11),5500)
3142 WRITE(MSTU(11),5700)
3146 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
3148 C...Formats for initialization information.
3149 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
3150 &'routines',1X,17('*'))
3151 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
3152 &'-',A6,' interactions.'/1X,'Execution stopped!')
3153 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
3154 &1X,'Execution stopped!')
3155 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
3156 &1X,'Execution stopped!')
3157 5500 FORMAT(1X,'Error: no subprocess switched on.'/
3158 &1X,'Execution stopped.')
3159 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
3161 5700 FORMAT(1X,'Error: no subprocess switched on.'/
3162 &1X,'Execution will stop if you try to generate events.')
3167 C*********************************************************************
3170 C...Administers the generation of a high-pT event via calls to
3171 C...a number of subroutines.
3175 C...Double precision and integer declarations.
3176 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3177 IMPLICIT INTEGER(I-N)
3178 INTEGER PYK,PYCHGE,PYCOMP
3179 PARAMETER (MAXNUR=1000)
3181 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
3182 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3183 COMMON/PYCTAG/NCT,MCT(4000,2)
3184 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3185 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3186 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3187 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3188 COMMON/PYINT1/MINT(400),VINT(400)
3189 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3190 COMMON/PYINT4/MWID(500),WIDS(500,5)
3191 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3192 SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
3193 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
3197 C...Optionally let PYEVNW do the whole job.
3198 IF(MSTP(81).GE.20) THEN
3203 C...Stop if no subprocesses on.
3204 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3205 WRITE(MSTU(11),5100)
3209 C...Initial values for some counters.
3222 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3226 C...Let called routines know call is from PYEVNT (not PYEVNW).
3228 IF (MSTP(81).GE.10) MINT(35)=2
3230 C...If variable energies: redo incoming kinematics and cross-section.
3232 IF(MSTP(171).EQ.1) THEN
3234 IF(MSTI(61).EQ.1) THEN
3238 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3242 C...Loop over number of pileup events; check space left.
3243 IF(MSTP(131).LE.0) THEN
3249 DO 270 IPILE=1,NPILE
3250 IF(MINT(84)+100.GE.MSTU(4)) THEN
3252 & '(PYEVNT:) no more space in PYJETS for pileup events')
3253 IF(MSTU(21).GE.1) GOTO 280
3257 C...Generate variables of hard scattering.
3261 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3267 IF(MSTI(61).EQ.1) THEN
3271 IF(MINT(51).EQ.2) RETURN
3273 IF(MSTP(111).EQ.-1) GOTO 260
3275 C...Loopback point if PYPREP fails, especially for junction topologies.
3281 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3282 C...Hard scattering (including low-pT):
3283 C...reconstruct kinematics and colour flow of hard scattering.
3288 IF(MINT(51).EQ.1) GOTO 100
3291 IF(ISUB.EQ.95) GOTO 140
3293 C...Reset statistics on activity in event.
3299 C...Showering of initial state partons (optional).
3303 IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
3304 & CALL PYSSPA(IPU1,IPU2)
3306 IF(MINT(51).EQ.1) GOTO 100
3308 C...pT-ordered FSR off ISR (optional, must have at least 2 partons)
3309 IF (NPART.GE.2.AND.(MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12)) THEN
3310 PTMAX=0.5*SQRT(PARP(71))*VINT(55)
3311 CALL PYPTFS(3,PTMAX,0D0,PTGEN)
3314 C...Showering of final state partons (optional).
3317 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
3321 IF(ISET(ISUB).EQ.5) IPU4=-3
3323 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3324 CALL PYSHOW(IPU3,IPU4,QMAX)
3325 ELSEIF(ISET(ISUB).EQ.11) THEN
3330 C...Allow possibility for user to abort event generation.
3332 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
3333 IF(IVETO.EQ.1) GOTO 100
3335 C...Decay of final state resonances.
3337 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
3338 IF(MINT(51).EQ.1) GOTO 100
3342 C...Multiple interactions - PYTHIA 6.3 intermediate style.
3343 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
3344 IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
3346 IF(MINT(51).EQ.1) GOTO 100
3349 C...Beam remnant flavour and colour assignments - new scheme.
3351 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3353 IF(MINT(51).EQ.1) GOTO 100
3355 C...Primordial kT and beam remnant momentum sharing - new scheme.
3357 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3359 IF(MINT(51).EQ.1) GOTO 100
3360 IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
3362 C...Multiple interactions - PYTHIA 6.2 style.
3363 ELSEIF(MINT(111).NE.12) THEN
3364 IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
3369 C...Hadron remnants and primordial kT.
3370 CALL PYREMN(IPU1,IPU2)
3371 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3373 IF(MINT(51).EQ.1) GOTO 100
3376 ELSEIF(ISUB.NE.99) THEN
3377 C...Diffractive and elastic scattering.
3381 C...DIS scattering (photon flux external).
3383 IF(MINT(51).EQ.1) GOTO 100
3386 C...Check that no odd resonance left undecayed.
3388 IF(MSTP(111).GE.1) THEN
3390 DO 150 I=MINT(84)+1,NFIX
3391 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3392 & K(I,2).NE.22) THEN
3394 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3396 IF(MINT(51).EQ.1) GOTO 100
3402 C...Boost hadronic subsystem to overall rest frame.
3403 C..(Only relevant when photon inside lepton beam.)
3404 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3406 C...Recalculate energies from momenta and masses (if desired).
3407 IF(MSTP(113).GE.1) THEN
3408 DO 160 I=MINT(83)+1,N
3409 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3410 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3415 C...Colour reconnection before string formation
3416 IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
3418 C...Rearrange partons along strings, check invariant mass cuts.
3420 IF(MSTP(111).LE.0) MSTJ(14)=-1
3421 CALL PYPREP(MINT(84)+1)
3423 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3427 IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
3428 IF (MINT(51).EQ.1) GOTO 100
3429 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3430 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3431 DO 190 I=MINT(84)+1,N
3432 IF(K(I,2).EQ.94) THEN
3433 DO 180 I1=I+1,MIN(N,I+10)
3434 IF(K(I1,3).EQ.I) THEN
3435 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3436 IF(K(I1,3).EQ.0) THEN
3437 DO 170 II=MINT(84)+1,I-1
3438 IF(K(II,2).EQ.K(I1,2)) THEN
3439 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3440 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3443 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3451 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3452 IF(MSTP(125).EQ.0) MINT(4)=0
3453 DO 210 I=MINT(83)+1,N
3454 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3456 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3457 IF(K(I1,3).EQ.I) K(I,5)=I1
3463 C...Introduce separators between sections in PYLIST event listing.
3464 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3467 ELSEIF(IPILE.EQ.1) THEN
3474 C...Go back to lab frame (needed for vertices, also in fragmentation).
3477 C...Set nonvanishing production vertex (optional).
3478 IF(MSTP(151).EQ.1) THEN
3480 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3481 & SIN(PARU(2)*PYR(0))
3483 DO 240 I=MINT(83)+1,N
3485 V(I,J)=V(I,J)+VTX(J)
3490 C...Perform hadronization (if desired).
3491 IF(MSTP(111).GE.1) THEN
3493 IF(MSTU(24).NE.0) GOTO 100
3495 IF(MSTP(113).GE.1) THEN
3497 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3498 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3501 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3503 C...Store event information and calculate Monte Carlo estimates of
3504 C...subprocess cross-sections.
3505 260 IF(IPILE.EQ.1) CALL PYDOCU
3507 C...Set counters for current pileup event and loop to next one.
3509 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3510 IF(MSTU70.LT.10) THEN
3515 MINT(84)=N+MSTP(126)
3516 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3519 C...Generic information on pileup events. Reconstruct missing history.
3520 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3524 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3528 C...Transform to the desired coordinate frame.
3529 280 CALL PYFRAM(MSTP(124))
3534 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3535 &1X,'Execution stopped.')
3540 C*********************************************************************
3543 C...Administers the generation of a high-pT event via calls to
3544 C...a number of subroutines for the new multiple interactions and
3545 C...showering framework.
3549 C...Double precision and integer declarations.
3550 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3551 IMPLICIT INTEGER(I-N)
3552 INTEGER PYK,PYCHGE,PYCOMP
3553 PARAMETER (MAXNUR=1000)
3555 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
3557 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3558 COMMON/PYCTAG/NCT,MCT(4000,2)
3559 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3560 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3561 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3562 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3563 COMMON/PYINT1/MINT(400),VINT(400)
3564 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3565 COMMON/PYINT4/MWID(500),WIDS(500,5)
3566 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3567 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
3568 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
3569 & XMI(2,240),PT2MI(240),IMISEP(0:240)
3570 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
3571 & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
3575 C...Stop if no subprocesses on.
3576 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3577 WRITE(MSTU(11),5100)
3581 C...Initial values for some counters.
3594 C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3597 C...Zero counters for pT-ordered showers (failsafe)
3601 C...Let called routines know call is from PYEVNW (not PYEVNT).
3604 C...If variable energies: redo incoming kinematics and cross-section.
3606 IF(MSTP(171).EQ.1) THEN
3608 IF(MSTI(61).EQ.1) THEN
3612 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3616 C...Loop over number of pileup events; check space left.
3617 IF(MSTP(131).LE.0) THEN
3623 DO 300 IPILE=1,NPILE
3624 IF(MINT(84)+100.GE.MSTU(4)) THEN
3626 & '(PYEVNW:) no more space in PYJETS for pileup events')
3627 IF(MSTU(21).GE.1) GOTO 310
3631 C...Generate variables of hard scattering.
3637 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3638 IF(LOOPHS.GE.10) THEN
3639 CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or '
3640 & //'multiple interactions. Returning.')
3650 IF(MSTI(61).EQ.1) THEN
3654 IF(MINT(51).EQ.2) RETURN
3656 IF(MSTP(111).EQ.-1) GOTO 290
3658 C...Loopback point if PYPREP fails, especially for junction topologies.
3664 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3665 C...Hard scattering (including low-pT):
3666 C...reconstruct kinematics and colour flow of hard scattering.
3671 IF(MINT(51).EQ.1) GOTO 100
3675 C...Intertwined initial state showers and multiple interactions.
3676 C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3677 C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3679 IF (MINT(47).LT.2) MSTP(61)=0
3681 IF (MINT(50).EQ.0) MSTP(81)=0
3682 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3683 & MINT(111).NE.12) THEN
3684 C...Absolute max pT2 scale for evolution: phase space limit.
3685 PT2MXS=0.25D0*VINT(2)
3686 C...Check if more constrained by ISR and MI max scales:
3687 PT2MXS=MIN(PT2MXS,MAX(VINT(56),VINT(62)))
3688 C...Loopback point in case of failure in evolution.
3692 IF(LOOP.GT.100) THEN
3693 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3694 & //'multiple interactions. Trying new point.')
3699 C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3700 C...once per event. (E.g. compute constants and save variables to be
3701 C...restored later in case of failure.)
3702 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3704 C...Initialize interleaved MI/ISR/JI evolution.
3705 C...PT2MAX: absolute upper limit for evolution - Initialization may
3706 C... return a PT2MAX which is lower than this.
3707 C...PT2MIN: absolute lower limit for evolution - Initialization may
3708 C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3711 CALL PYEVOL(0,PT2MAX,PT2MIN)
3712 C...If failed to initialize evolution, generate a new hard process
3713 IF (MINT(51).EQ.1) GOTO 100
3715 C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3716 C...In principle factorized, so can be stopped and restarted.
3717 C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3718 C PT2MED=MAX(10D0**2,PT2MIN)
3719 C CALL PYEVOL(1,PT2MAX,PT2MED)
3720 C IF (MINT(51).EQ.1) GOTO 160
3722 CALL PYEVOL(1,PT2MAX,PT2MIN)
3723 C...If fatal error (e.g., massive hard-process initiator, but no available
3724 C...phase space for creation), generate a new hard process
3725 IF (MINT(51).EQ.2) GOTO 100
3726 C...If smaller error, just try running evolution again
3727 IF (MINT(51).EQ.1) GOTO 130
3729 C...Finalize interleaved MI/ISR/JI evolution.
3730 CALL PYEVOL(2,PT2MAX,PT2MIN)
3731 IF (MINT(51).EQ.1) GOTO 130
3736 IF(MINT(51).EQ.1) GOTO 100
3737 C...(MINT(52) is actually obsolete in this routine. Set anyway
3738 C...to ensure PYDOCU stable.)
3742 C...Beam remnants - new scheme.
3743 140 IF(MINT(50).EQ.1) THEN
3744 IF (ISUB.EQ.95) MINT(31)=1
3746 C...Beam remnant flavour and colour assignments - new scheme.
3748 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3750 IF(MINT(51).EQ.1) GOTO 100
3752 C...Primordial kT and beam remnant momentum sharing - new scheme.
3754 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3756 IF(MINT(51).EQ.1) GOTO 100
3757 IF (ISUB.EQ.95) MINT(31)=0
3758 ELSEIF(MINT(111).NE.12) THEN
3759 C...Hadron remnants and primordial kT - old model.
3760 C...Happens e.g. for direct photon on one side.
3763 CALL PYREMN(IPU1,IPU2)
3764 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3766 IF(MINT(51).EQ.1) GOTO 100
3767 C...PYREMN does not set colour tags for BRs, so needs to be done now.
3768 DO 160 I=MINT(53)+1,N
3770 IDA=MOD(K(I,KCS),MSTU(5))
3772 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3778 C...Instruct PYPREP to use colour tags
3782 DO 350 I=MINT(84)+1,N
3784 C...Look for coloured string endpoint, or (later) leftover gluon.
3785 IF (K(I,1).NE.3) GOTO 350
3787 IF(KC.EQ.0) GOTO 350
3789 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
3791 C... Pick up loose string end with no previous tag.
3793 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
3794 IF(MCT(I,KCS-3).NE.0) GOTO 350
3796 CALL PYCTTR(I,KCS,I)
3797 IF(MINT(51).NE.0) RETURN
3801 C...Now delete any colour processing information if set (since partons
3802 C...otherwise not FS showered!)
3803 DO 170 I=MINT(84)+1,N
3805 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3806 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3811 C...Showering of final state partons (optional).
3814 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3817 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3818 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3819 C...External processes: handle successive showers.
3820 ELSEIF(ISET(ISUB).EQ.11) THEN
3825 C...Allow possibility for user to abort event generation.
3827 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
3829 C...........No reason to count this as an error
3835 C...Decay of final state resonances.
3837 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3839 IF(MINT(51).NE.0) GOTO 100
3842 IF(MINT(51).EQ.1) GOTO 100
3844 ELSEIF(ISUB.NE.99) THEN
3845 C...Diffractive and elastic scattering.
3849 C...DIS scattering (photon flux external).
3851 IF(MINT(51).EQ.1) GOTO 100
3854 C...Check that no odd resonance left undecayed.
3856 IF(MSTP(111).GE.1) THEN
3858 DO 180 I=MINT(84)+1,NFIX
3859 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3860 & K(I,2).NE.22) THEN
3862 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3864 IF(MINT(51).EQ.1) GOTO 100
3870 C...Boost hadronic subsystem to overall rest frame.
3871 C..(Only relevant when photon inside lepton beam.)
3872 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3874 C...Recalculate energies from momenta and masses (if desired).
3875 IF(MSTP(113).GE.1) THEN
3876 DO 190 I=MINT(83)+1,N
3877 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3878 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3883 C...Colour reconnection before string formation
3884 CALL PYFSCR(MINT(84)+1)
3886 C...Rearrange partons along strings, check invariant mass cuts.
3888 IF(MSTP(111).LE.0) MSTJ(14)=-1
3889 CALL PYPREP(MINT(84)+1)
3891 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3895 IF(MINT(51).EQ.1) GOTO 110
3896 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3897 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3898 DO 220 I=MINT(84)+1,N
3899 IF(K(I,2).EQ.94) THEN
3900 DO 210 I1=I+1,MIN(N,I+10)
3901 IF(K(I1,3).EQ.I) THEN
3902 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3903 IF(K(I1,3).EQ.0) THEN
3904 DO 200 II=MINT(84)+1,I-1
3905 IF(K(II,2).EQ.K(I1,2)) THEN
3906 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3907 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3910 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3914 CC...Also collapse particles decaying to themselves (if same KS)
3915 ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0
3916 & .AND.K(I,4).LT.N) THEN
3918 IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN
3925 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3926 IF(MSTP(125).EQ.0) MINT(4)=0
3927 DO 240 I=MINT(83)+1,N
3928 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3930 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3931 IF(K(I1,3).EQ.I) K(I,5)=I1
3937 C...Introduce separators between sections in PYLIST event listing.
3938 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3941 ELSEIF(IPILE.EQ.1) THEN
3948 C...Go back to lab frame (needed for vertices, also in fragmentation).
3951 C...Set nonvanishing production vertex (optional).
3952 IF(MSTP(151).EQ.1) THEN
3954 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3955 & SIN(PARU(2)*PYR(0))
3957 DO 270 I=MINT(83)+1,N
3959 V(I,J)=V(I,J)+VTX(J)
3964 C...Perform hadronization (if desired).
3965 IF(MSTP(111).GE.1) THEN
3967 IF(MSTU(24).NE.0) GOTO 100
3969 IF(MSTP(113).GE.1) THEN
3971 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3972 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3975 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3977 C...Store event information and calculate Monte Carlo estimates of
3978 C...subprocess cross-sections.
3979 290 IF(IPILE.EQ.1) CALL PYDOCU
3981 C...Set counters for current pileup event and loop to next one.
3983 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3984 IF(MSTU70.LT.10) THEN
3989 MINT(84)=N+MSTP(126)
3990 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3993 C...Generic information on pileup events. Reconstruct missing history.
3994 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3998 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
4002 C...Transform to the desired coordinate frame.
4003 310 CALL PYFRAM(MSTP(124))
4008 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4009 &1X,'Execution stopped.')
4015 C***********************************************************************
4018 C...Prints out information about cross-sections, decay widths, branching
4019 C...ratios, kinematical limits, status codes and parameter values.
4021 SUBROUTINE PYSTAT(MSTAT)
4023 C...Double precision and integer declarations.
4024 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4025 IMPLICIT INTEGER(I-N)
4026 INTEGER PYK,PYCHGE,PYCOMP
4027 C...Parameter statement to help give large particle numbers.
4028 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
4029 &KEXCIT=4000000,KDIMEN=5000000)
4030 PARAMETER (EPS=1D-3)
4032 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4033 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4034 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4035 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4036 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4037 COMMON/PYINT1/MINT(400),VINT(400)
4038 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4039 COMMON/PYINT4/MWID(500),WIDS(500,5)
4040 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4041 COMMON/PYINT6/PROC(0:500)
4042 CHARACTER PROC*28, CHTMP*16
4043 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
4044 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
4045 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4046 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
4047 C...Local arrays, character variables and data.
4048 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
4049 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
4050 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
4051 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
4052 CHARACTER*24 CHD0, CHDC(10)
4053 CHARACTER*6 DNAME(3)
4055 &'VMD/hadron * VMD ','VMD/hadron * direct ',
4056 &'VMD/hadron * anomalous ','direct * direct ',
4057 &'direct * anomalous ','anomalous * anomalous '/
4058 DATA DISGA/'e * VMD','e * anomalous'/
4060 &'direct * direct ','direct * VMD ',
4061 &'direct * anomalous ','VMD * direct ',
4062 &'VMD * VMD ','VMD * anomalous ',
4063 &'anomalous * direct ','anomalous * VMD ',
4064 &'anomalous * anomalous ','DIS * VMD ',
4065 &'DIS * anomalous ','VMD * DIS ',
4066 &'anomalous * DIS '/
4068 &'direct * direct ','direct * resolved ',
4069 &'resolved * direct ','resolved * resolved '/
4071 &'direct * hadron ','resolved * hadron '/
4073 &'VMD * hadron ','direct * hadron ',
4074 &'anomalous * hadron ','DIS * hadron '/
4075 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
4076 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
4077 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
4078 &' y*_small ',' eta*_large ',' eta*_small ',
4079 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
4080 &' x_2 ',' x_F ',' cos(theta_hard) ',
4081 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
4082 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
4084 DATA DNAME /'q ','lepton','nu '/
4088 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
4089 WRITE(MSTU(11),5000)
4090 WRITE(MSTU(11),5100)
4091 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
4093 IF(MSUB(I).NE.1) GOTO 100
4094 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
4096 IF(MINT(121).GT.1) THEN
4097 WRITE(MSTU(11),5300)
4098 DO 110 IGA=1,MINT(121)
4100 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4101 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
4103 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4104 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
4106 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
4107 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
4109 ELSEIF(MINT(121).EQ.4) THEN
4110 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
4112 ELSEIF(MINT(121).EQ.2) THEN
4113 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
4116 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
4122 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
4123 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
4125 C...Decay widths and branching ratios.
4126 ELSEIF(MSTAT.EQ.2) THEN
4127 WRITE(MSTU(11),5500)
4128 WRITE(MSTU(11),5600)
4131 CALL PYNAME(KF,CHKF)
4134 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
4135 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
4136 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
4137 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
4138 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
4140 IF(MWID(KC).LE.0) GOTO 140
4141 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
4142 & KF/KSUSY1.EQ.2)) GOTO 140
4144 C...Off-shell branchings.
4147 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
4148 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
4149 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
4150 DO 120 J=1,MDCY(KC,3)
4153 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4154 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4156 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4157 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4158 CALL PYNAME(KFDP(IDC,1),CHD1)
4159 CALL PYNAME(KFDP(IDC,2),CHD2)
4160 IF(KFDP(IDC,3).EQ.0) THEN
4161 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4162 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4163 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4165 CALL PYNAME(KFDP(IDC,3),CHD3)
4166 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4167 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4168 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4171 C...On-shell decays.
4173 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
4175 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
4176 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
4177 & STATE(MDCY(KC,1)),BRFIN
4178 DO 130 J=1,MDCY(KC,3)
4181 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4182 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4184 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4185 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4187 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
4189 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
4190 CALL PYNAME(KFDP(IDC,1),CHD1)
4191 CALL PYNAME(KFDP(IDC,2),CHD2)
4192 IF(KFDP(IDC,3).EQ.0) THEN
4193 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4194 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4195 & CHD2(1:10),WDTP(J),BRPRI,
4196 & STATE(MDME(IDC,1)),BRFIN
4198 CALL PYNAME(KFDP(IDC,3),CHD3)
4199 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4200 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4201 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
4202 & STATE(MDME(IDC,1)),BRFIN
4207 WRITE(MSTU(11),6000)
4209 C...Allowed incoming partons/particles at hard interaction.
4210 ELSEIF(MSTAT.EQ.3) THEN
4211 WRITE(MSTU(11),6100)
4212 CALL PYNAME(MINT(11),CHAU)
4214 CALL PYNAME(MINT(12),CHAU)
4216 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
4220 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
4221 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
4223 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
4226 WRITE(MSTU(11),6400)
4228 C...User-defined limits on kinematical variables.
4229 ELSEIF(MSTAT.EQ.4) THEN
4230 WRITE(MSTU(11),6500)
4231 WRITE(MSTU(11),6600)
4233 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
4234 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
4235 PTHMIN=MAX(CKIN(3),CKIN(5))
4237 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
4238 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
4239 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
4241 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
4244 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
4245 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
4246 WRITE(MSTU(11),7000)
4248 C...Status codes and parameter values.
4249 ELSEIF(MSTAT.EQ.5) THEN
4250 WRITE(MSTU(11),7100)
4251 WRITE(MSTU(11),7200)
4253 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4257 C...List of all processes implemented in the program.
4258 ELSEIF(MSTAT.EQ.6) THEN
4259 WRITE(MSTU(11),7400)
4260 WRITE(MSTU(11),7500)
4262 IF(ISET(I).LT.0) GOTO 180
4263 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4265 WRITE(MSTU(11),7700)
4267 ELSEIF(MSTAT.EQ.7) THEN
4268 WRITE (MSTU(11),8000)
4274 KFSUSY=ILR*KSUSY1+KFSM
4277 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4283 CALL PYNAME(KFSUSY,CHTMP)
4285 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4286 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4287 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4289 DO 200 J=1,MDCY(KC,3)
4291 ID1=IABS(KFDP(IDC,1))
4292 ID2=IABS(KFDP(IDC,2))
4293 IF (KFDP(IDC,3).EQ.0) THEN
4294 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4295 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4296 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4297 NMODES(1)=NMODES(1)+1
4298 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4299 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4300 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4301 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4302 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4303 NMODES(2)=NMODES(2)+1
4304 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4305 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4306 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4307 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4308 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4309 NMODES(3)=NMODES(3)+1
4310 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4311 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4317 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4323 CALL PYNAME(KFSUSY,CHTMP)
4325 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4326 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4328 DO 220 J=1,MDCY(KC,3)
4330 ID1=IABS(KFDP(IDC,1))
4331 ID2=IABS(KFDP(IDC,2))
4332 IF (KFDP(IDC,3).EQ.0) THEN
4333 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4334 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4335 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4336 NMODES(1)=NMODES(1)+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.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4340 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4341 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4342 NMODES(2)=NMODES(2)+1
4343 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4344 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4350 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4356 CALL PYNAME(KFSUSY,CHTMP)
4358 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4359 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4361 DO 240 J=1,MDCY(KC,3)
4363 ID1=IABS(KFDP(IDC,1))
4364 ID2=IABS(KFDP(IDC,2))
4365 IF (KFDP(IDC,3).EQ.0) THEN
4366 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4367 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4368 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4369 NMODES(1)=NMODES(1)+1
4370 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4371 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4373 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4374 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4375 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4376 NMODES(2)=NMODES(2)+1
4377 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4378 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4383 C...SNEUTRINO DECAYS
4384 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4391 CALL PYNAME(KFSUSY,CHTMP)
4393 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4394 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4396 DO 260 J=1,MDCY(KC,3)
4398 ID1=IABS(KFDP(IDC,1))
4399 ID2=IABS(KFDP(IDC,2))
4400 IF (KFDP(IDC,3).EQ.0) THEN
4401 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4402 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4403 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4404 NMODES(1)=NMODES(1)+1
4405 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4406 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4408 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4409 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4410 NMODES(2)=NMODES(2)+1
4411 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4412 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4413 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4418 IF (NRVDC.NE.0) THEN
4420 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4421 NMODES(0)=NMODES(0)+NMODES(I)
4429 C...NEUTRALINO DECAYS
4430 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4436 CALL PYNAME(KFSUSY,CHTMP)
4438 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4439 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4440 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4441 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4443 DO 310 J=1,MDCY(KC,3)
4445 ID1=IABS(KFDP(IDC,1))
4446 ID2=IABS(KFDP(IDC,2))
4447 ID3=IABS(KFDP(IDC,3))
4448 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4449 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4450 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4451 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4452 NMODES(1)=NMODES(1)+1
4453 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4454 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4455 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4456 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4457 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4458 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4459 NMODES(2)=NMODES(2)+1
4460 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4461 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4462 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4463 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4464 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4465 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4466 NMODES(3)=NMODES(3)+1
4467 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4468 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4469 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4470 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4471 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4472 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4473 NMODES(4)=NMODES(4)+1
4474 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4475 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4480 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4486 CALL PYNAME(KFSUSY,CHTMP)
4488 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4489 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4490 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4491 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4492 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4494 DO 330 J=1,MDCY(KC,3)
4496 ID1=IABS(KFDP(IDC,1))
4497 ID2=IABS(KFDP(IDC,2))
4498 ID3=IABS(KFDP(IDC,3))
4499 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4500 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4501 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4502 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4503 NMODES(1)=NMODES(1)+1
4504 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4505 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4506 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4507 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4508 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4509 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4510 NMODES(1)=NMODES(1)+1
4511 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4512 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4513 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4514 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4515 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4516 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4517 NMODES(2)=NMODES(2)+1
4518 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4519 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4520 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4521 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4522 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4523 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4524 NMODES(3)=NMODES(3)+1
4525 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4526 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4527 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4528 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4529 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4530 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4531 NMODES(3)=NMODES(3)+1
4532 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4533 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4534 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4535 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4536 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4537 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4538 NMODES(4)=NMODES(4)+1
4539 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4540 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4541 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4542 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4543 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4544 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4545 NMODES(4)=NMODES(4)+1
4546 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4547 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4548 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4549 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4550 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4551 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4552 NMODES(5)=NMODES(5)+1
4553 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4554 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4555 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4556 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4557 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4558 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4559 NMODES(5)=NMODES(5)+1
4560 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4561 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4566 IF (KFSM.EQ.21) THEN
4572 CALL PYNAME(KFSUSY,CHTMP)
4574 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4575 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4576 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4578 DO 350 J=1,MDCY(KC,3)
4580 ID1=IABS(KFDP(IDC,1))
4581 ID2=IABS(KFDP(IDC,2))
4582 ID3=IABS(KFDP(IDC,3))
4583 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4584 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4585 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4586 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4587 NMODES(1)=NMODES(1)+1
4588 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4589 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4590 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4591 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4592 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4593 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4594 NMODES(2)=NMODES(2)+1
4595 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4596 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4597 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4598 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4599 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4600 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4601 NMODES(3)=NMODES(3)+1
4602 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4603 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4608 IF (NRVDC.NE.0) THEN
4610 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4611 NMODES(0)=NMODES(0)+NMODES(I)
4615 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4617 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4618 WRITE (MSTU(11),8500)
4622 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4623 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4627 WRITE (MSTU(11),8600)
4631 C...Formats for printouts.
4632 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4633 &'Events and Cross-sections',1X,9('*'))
4634 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4635 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4636 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4637 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4638 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4639 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4641 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4643 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4644 &1X,'I',34X,'I',28X,'I',12X,'I')
4645 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4646 &1X,'********* Total number of errors, excluding junctions =',
4647 &1X,I8,' *************'/
4648 &1X,'********* Total number of errors, including junctions =',
4649 &1X,I8,' *************'/
4650 &1X,'********* Total number of warnings = ',
4651 &1X,I8,' *************'/
4652 &1X,'********* Fraction of events that fail fragmentation ',
4653 &'cuts =',1X,F8.5,' *********'/)
4654 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4655 &'Ratios',1X,27('*'))
4656 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4657 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4658 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4659 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4661 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4662 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4663 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4664 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4665 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4666 &1P,D10.3,0P,1X,'I')
4667 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4668 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4669 &1P,D10.3,0P,1X,'I')
4670 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4671 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4672 &'Particles at Hard Interaction',1X,7('*'))
4673 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4674 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4675 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4676 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4677 &78('=')/1X,'I',38X,'I',37X,'I')
4678 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4679 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4680 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4681 &'Kinematical Variables',1X,12('*'))
4682 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4683 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4685 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4686 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4687 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4688 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4689 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4690 &'Parameter Values',1X,12('*'))
4691 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4693 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4694 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4696 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4697 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4698 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4699 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4700 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4702 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4703 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4704 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4705 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4706 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4707 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4708 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4709 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4710 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4712 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4713 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4714 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4716 & 1X,'R-Violating couplings',1X/ 1X /
4718 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4719 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4720 & ,'I',15X,'I',15X,'I',15X,'I')
4721 8600 FORMAT(1X,55('='))
4722 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4723 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4728 C*********************************************************************
4731 C...Administers the hard-process generation required for output to the
4732 C...Les Houches event record.
4736 C...Double precision and integer declarations.
4737 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4738 IMPLICIT INTEGER(I-N)
4739 INTEGER PYK,PYCHGE,PYCOMP
4742 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4743 COMMON/PYCTAG/NCT,MCT(4000,2)
4744 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4745 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4746 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4747 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4748 COMMON/PYINT1/MINT(400),VINT(400)
4749 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4750 COMMON/PYINT4/MWID(500),WIDS(500,5)
4751 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4752 &/PYINT1/,/PYINT2/,/PYINT4/
4754 C...HEPEUP for output.
4756 PARAMETER (MAXNUP=500)
4757 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4758 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4759 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4760 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4761 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4764 C...Stop if no subprocesses on.
4765 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4766 WRITE(MSTU(11),5100)
4770 C...Special flags for hard-process generation only.
4776 C...Initial values for some counters.
4787 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4790 C...If variable energies: redo incoming kinematics and cross-section.
4792 IF(MSTP(171).EQ.1) THEN
4794 IF(MSTI(61).EQ.1) THEN
4798 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4802 C...Do not allow pileup events.
4805 C...Generate variables of hard scattering.
4809 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4814 IF(MSTI(61).EQ.1) THEN
4818 IF(MINT(51).EQ.2) RETURN
4821 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4822 C...Hard scattering (including low-pT):
4823 C...reconstruct kinematics and colour flow of hard scattering.
4828 IF(MINT(51).EQ.1) GOTO 100
4832 C...Decay of final state resonances.
4834 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4836 IF(MINT(51).EQ.1) GOTO 100
4839 C...Longitudinal boost of hard scattering.
4840 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4841 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4843 ELSEIF(ISUB.NE.99) THEN
4844 C...Diffractive and elastic scattering.
4848 C...DIS scattering (photon flux external).
4850 IF(MINT(51).EQ.1) GOTO 100
4853 C...Check that no odd resonance left undecayed.
4856 DO 120 I=MINT(84)+1,NFIX
4857 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4858 & K(I,2).NE.22) THEN
4860 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4862 IF(MINT(51).EQ.1) GOTO 100
4867 C...Boost hadronic subsystem to overall rest frame.
4868 C..(Only relevant when photon inside lepton beam.)
4869 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4871 C...Store event information and calculate Monte Carlo estimates of
4872 C...subprocess cross-sections.
4875 C...Transform to the desired coordinate frame.
4876 140 CALL PYFRAM(MSTP(124))
4880 C...Restore special flags for hard-process generation only.
4884 C...Trace colour tags; convert to LHA style labels.
4886 DO 150 I=MINT(84)+1,N
4890 DO 160 I=MINT(84)+1,N
4891 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4892 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4893 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4895 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4896 IDA=MOD(K(I,4),MSTU(5))
4897 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4898 & MCT(IMO,2).NE.0) THEN
4900 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4901 & MCT(IMO,1).NE.0) THEN
4903 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4904 & MCT(IDA,2).NE.0) THEN
4911 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4913 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4914 IDA=MOD(K(I,5),MSTU(5))
4915 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4916 & MCT(IMO,1).NE.0) THEN
4918 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4919 & MCT(IMO,2).NE.0) THEN
4921 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4922 & MCT(IDA,1).NE.0) THEN
4932 C...Put event in HEPEUP commonblock.
4940 IDUP(I)=K(I+MINT(84),2)
4945 ELSEIF(K(I+4,3).EQ.0) THEN
4951 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4954 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4955 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4956 ICOLUP(1,I)=MCT(I+MINT(84),1)
4957 ICOLUP(2,I)=MCT(I+MINT(84),2)
4959 PUP(J,I)=P(I+MINT(84),J)
4965 C...Optionally write out event to disk. Minimal size for time/spin fields.
4966 IF(MSTP(162).GT.0) THEN
4967 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4969 IF(VTIMUP(I).EQ.0D0) THEN
4970 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4971 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4974 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4975 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4980 C...Optional extra line with parton-density information.
4981 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4982 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4985 C...Error messages and other print formats.
4986 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4987 &1X,'Execution stopped.')
4988 5200 FORMAT(1P,2I6,4E14.6)
4989 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
4990 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
4991 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
4996 C*********************************************************************
4999 C...Fills the HEPRUP commonblock with info on incoming beams and allowed
5000 C...processes, and optionally stores that information on file.
5004 C...Double precision and integer declarations.
5005 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5006 IMPLICIT INTEGER(I-N)
5009 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5010 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5011 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5012 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5013 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
5015 C...User process initialization commonblock.
5017 PARAMETER (MAXPUP=100)
5018 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5019 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5020 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5021 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5025 C...Store info on incoming beams.
5035 C...Event weighting strategy.
5038 C...Info on individual processes.
5041 IF(MSUB(ISUB).EQ.1) THEN
5043 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
5044 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
5050 C...Write info to file.
5051 IF(MSTP(161).GT.0) THEN
5052 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
5053 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5055 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
5060 C...Formats for printout.
5061 5100 FORMAT(1P,2I8,2E14.6,6I6)
5062 5200 FORMAT(1P,3E14.6,I6)
5068 C*********************************************************************
5070 C...Combine the two old-style Pythia initialization and event files
5071 C...into a single Les Houches Event File.
5075 C...Double precision and integer declarations.
5076 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5077 IMPLICIT INTEGER(I-N)
5079 C...PYTHIA commonblock: only used to provide read/write units and version.
5080 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5083 C...User process initialization commonblock.
5085 PARAMETER (MAXPUP=100)
5086 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5087 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5088 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5089 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5093 C...User process event common block.
5095 PARAMETER (MAXNUP=500)
5096 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
5097 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
5098 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
5099 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
5100 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
5103 C...Lines to read in assumed never longer than 200 characters.
5104 PARAMETER (MAXLEN=200)
5105 CHARACTER*(MAXLEN) STRING
5107 C...Format for reading lines.
5110 WRITE(STRFMT(3:5),'(I3)') MAXLEN
5112 C...Rewind initialization and event files.
5116 C...Write header info.
5117 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
5118 WRITE(MSTP(163),'(A)') '<!--'
5119 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
5120 &MSTP(181),'.',MSTP(182)
5121 WRITE(MSTP(163),'(A)') '-->'
5123 C...Read first line of initialization info and get number of processes.
5124 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5125 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
5126 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5128 C...Copy initialization lines, omitting trailing blanks.
5129 C...Embed in <init> ... </init> block.
5130 WRITE(MSTP(163),'(A)') '<init>'
5132 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5135 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
5136 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5138 WRITE(MSTP(163),'(A)') '</init>'
5140 C...Begin event loop. Read first line of event info or already done.
5141 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
5144 C...Look at first line to know number of particles in event.
5145 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
5147 C...Begin an <event> block. Copy event lines, omitting trailing blanks.
5148 WRITE(MSTP(163),'(A)') '<event>'
5150 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
5153 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
5154 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5157 C...Copy trailing comment lines - with a # in the first column - as is.
5158 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
5159 IF(STRING(1:1).EQ.'#') THEN
5162 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
5163 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5167 C..End the <event> block. Loop back to look for next event.
5168 WRITE(MSTP(163),'(A)') '</event>'
5171 C...Successfully reached end of event loop: write closing tag
5172 C...and remove temporary intermediate files (unless asked not to).
5173 300 WRITE(MSTP(163),'(A)') '</event>'
5174 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
5175 IF(MSTP(164).EQ.1) RETURN
5176 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
5177 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
5181 400 WRITE(*,*) ' PYLHEF file joining failed!'
5186 C*********************************************************************
5189 C...Calculates full and effective widths of gauge bosons, stores
5190 C...masses and widths, rescales coefficients to be used for
5191 C...resonance production generation.
5195 C...Double precision and integer declarations.
5196 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5197 IMPLICIT INTEGER(I-N)
5198 INTEGER PYK,PYCHGE,PYCOMP
5199 C...Parameter statement to help give large particle numbers.
5200 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5201 &KEXCIT=4000000,KDIMEN=5000000)
5203 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5204 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5205 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5206 COMMON/PYDAT4/CHAF(500,2)
5208 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5209 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5210 COMMON/PYINT1/MINT(400),VINT(400)
5211 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5212 COMMON/PYINT4/MWID(500),WIDS(500,5)
5213 COMMON/PYINT6/PROC(0:500)
5215 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5216 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
5217 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
5218 C...Local arrays and data.
5219 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
5220 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
5222 C...Born level couplings in MSSM Higgs doublet sector.
5225 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
5227 IF(MSTP(4).EQ.2) THEN
5229 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
5233 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
5234 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
5236 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
5237 WRITE(MSTU(11),5000)
5240 PMAS(35,1)=SQRT(SQMHP)
5241 PMAS(36,1)=SQRT(SQMA)
5242 PMAS(37,1)=SQRT(SQMHC)
5243 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5248 PARU(161)=-SIN(ALSU)/COS(BESU)
5249 PARU(162)=COS(ALSU)/SIN(BESU)
5251 PARU(164)=SIN(BESU-ALSU)
5253 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5254 PARU(171)=COS(ALSU)/COS(BESU)
5255 PARU(172)=SIN(ALSU)/SIN(BESU)
5257 PARU(174)=COS(BESU-ALSU)
5259 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5261 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5262 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5268 PARU(186)=COS(BESU-ALSU)
5269 PARU(187)=SIN(BESU-ALSU)
5273 PARU(195)=COS(BESU-ALSU)
5276 C...Reset effective widths of gauge bosons.
5283 C...Order resonances by increasing mass (except Z0 and W+/-).
5287 IF(KF.EQ.0) GOTO 140
5288 IF(MWID(KC).EQ.0) GOTO 140
5289 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5290 IF(MSTP(1).LE.3) GOTO 140
5292 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5293 IF(IMSS(1).LE.0) GOTO 140
5297 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5298 DO 120 I1=NRES-1,1,-1
5299 IF(PMRES.GE.PMORD(I1)) GOTO 130
5300 KCORD(I1+1)=KCORD(I1)
5301 PMORD(I1+1)=PMORD(I1)
5307 C...Loop over possible resonances.
5312 C...Check that no fourth generation channels on by mistake.
5313 IF(MSTP(1).LE.3) THEN
5314 DO 150 J=1,MDCY(KC,3)
5316 KFA1=IABS(KFDP(IDC,1))
5317 KFA2=IABS(KFDP(IDC,2))
5318 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5319 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5324 C...Check that no supersymmetric channels on by mistake.
5325 IF(IMSS(1).LE.0) THEN
5326 DO 160 J=1,MDCY(KC,3)
5328 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5329 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5330 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5335 C...Find mass and evaluate width.
5337 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5338 IF(MWID(KC).EQ.3) MINT(63)=1
5339 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5342 C...Evaluate suppression factors due to non-simulated channels.
5343 IF(KCHG(KC,3).EQ.0) THEN
5345 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5346 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5347 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5348 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5349 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5354 IF(MWID(KC).EQ.3) MINT(63)=1
5355 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5358 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5359 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5360 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5361 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5362 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5363 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5364 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5365 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5366 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5367 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5368 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5369 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5370 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5373 C...Set resonance widths and branching ratios;
5374 C...also on/off switch for decays.
5375 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5377 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5378 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5379 DO 170 J=1,MDCY(KC,3)
5382 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5387 C...Flavours of leptoquark: redefine charge and name.
5388 KFLQQ=KFDP(MDCY(42,2),1)
5389 KFLQL=KFDP(MDCY(42,2),2)
5390 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5391 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5393 IF(IABS(KFLQL).EQ.13) LL=2
5394 IF(IABS(KFLQL).EQ.15) LL=3
5395 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5396 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5397 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5399 C...Special cases in treatment of gamma*/Z0: redefine process name.
5400 IF(MSTP(43).EQ.1) THEN
5401 PROC(1)='f + fbar -> gamma*'
5402 PROC(15)='f + fbar -> g + gamma*'
5403 PROC(19)='f + fbar -> gamma + gamma*'
5404 PROC(30)='f + g -> f + gamma*'
5405 PROC(35)='f + gamma -> f + gamma*'
5406 ELSEIF(MSTP(43).EQ.2) THEN
5407 PROC(1)='f + fbar -> Z0'
5408 PROC(15)='f + fbar -> g + Z0'
5409 PROC(19)='f + fbar -> gamma + Z0'
5410 PROC(30)='f + g -> f + Z0'
5411 PROC(35)='f + gamma -> f + Z0'
5412 ELSEIF(MSTP(43).EQ.3) THEN
5413 PROC(1)='f + fbar -> gamma*/Z0'
5414 PROC(15)='f + fbar -> g + gamma*/Z0'
5415 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5416 PROC(30)='f + g -> f + gamma*/Z0'
5417 PROC(35)='f + gamma -> f + gamma*/Z0'
5420 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5421 IF(MSTP(44).EQ.1) THEN
5422 PROC(141)='f + fbar -> gamma*'
5423 ELSEIF(MSTP(44).EQ.2) THEN
5424 PROC(141)='f + fbar -> Z0'
5425 ELSEIF(MSTP(44).EQ.3) THEN
5426 PROC(141)='f + fbar -> Z''0'
5427 ELSEIF(MSTP(44).EQ.4) THEN
5428 PROC(141)='f + fbar -> gamma*/Z0'
5429 ELSEIF(MSTP(44).EQ.5) THEN
5430 PROC(141)='f + fbar -> gamma*/Z''0'
5431 ELSEIF(MSTP(44).EQ.6) THEN
5432 PROC(141)='f + fbar -> Z0/Z''0'
5433 ELSEIF(MSTP(44).EQ.7) THEN
5434 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5437 C...Special cases in treatment of WW -> WW: redefine process name.
5438 IF(MSTP(45).EQ.1) THEN
5439 PROC(77)='W+ + W+ -> W+ + W+'
5440 ELSEIF(MSTP(45).EQ.2) THEN
5441 PROC(77)='W+ + W- -> W+ + W-'
5442 ELSEIF(MSTP(45).EQ.3) THEN
5443 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5446 C...Format for error information.
5447 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5448 &'combination'/1X,'Execution stopped!')
5453 C*********************************************************************
5456 C...Identifies the two incoming particles and the choice of frame.
5458 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5460 C...Double precision and integer declarations.
5461 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5462 IMPLICIT INTEGER(I-N)
5463 INTEGER PYK,PYCHGE,PYCOMP
5465 C...User process initialization commonblock.
5467 PARAMETER (MAXPUP=100)
5468 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5469 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5470 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5471 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5476 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5477 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5478 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5479 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5480 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5481 COMMON/PYINT1/MINT(400),VINT(400)
5482 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5484 C...Local arrays, character variables and data.
5485 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5486 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5487 DIMENSION LEN(3),KCDE(39),PM(2)
5488 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5489 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5490 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5491 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5492 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5493 &'nu_taubar ','pi+ ','pi- ','n0 ',
5494 &'nbar0 ','p+ ','pbar- ','gamma ',
5495 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5496 &'xi- ','xi0 ','omega- ','pi0 ',
5497 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5498 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5499 &'k+ ','k- ','ks0 ','kl0 '/
5500 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5501 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5502 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5504 C...Store initial energy. Default frame.
5508 C...Special user process initialization; convert to normal input.
5509 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5511 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5512 CALL PYNAME(IDBMUP(1),CHNAME)
5514 CALL PYNAME(IDBMUP(2),CHNAME)
5518 C...Convert character variables to lowercase and find their length.
5525 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5527 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5533 C...Fix up bar, underscore and charge in particle name (if needed).
5535 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5537 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5540 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5542 CHIDNT(I)='nu_'//CHTEMP(3:7)
5543 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5544 CHIDNT(I)(1:3)='n0 '
5545 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5546 CHIDNT(I)(1:5)='nbar0'
5547 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5548 CHIDNT(I)(1:3)='p+ '
5549 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5550 & CHIDNT(I)(1:2).EQ.'p-') THEN
5551 CHIDNT(I)(1:5)='pbar-'
5552 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5554 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5555 CHIDNT(I)(1:7)='reggeon'
5556 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5557 CHIDNT(I)(1:7)='pomeron'
5561 C...Identify free initialization.
5562 IF(CHCOM(1)(1:2).EQ.'no') THEN
5567 C...Identify incoming beam and target particles.
5570 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5572 PM(I)=PYMASS(MINT(10+I))
5575 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5576 CHTEMP=CHIDNT(I+1)(7:12)//' '
5578 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5580 PM(I)=PYMASS(MINT(140+I))
5584 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5585 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5586 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
5588 C...Identify choice of frame and input energies.
5591 C...Events defined in the CM frame.
5592 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5595 IF(MSTP(122).GE.1) THEN
5596 IF(CHCOM(2)(1:1).NE.'e') THEN
5597 LOFFS=(31-(LEN(2)+LEN(3)))/2
5598 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5599 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5602 LOFFS=(30-(LEN(2)+LEN(3)))/2
5603 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5604 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5607 WRITE(MSTU(11),5200) CHINIT
5608 WRITE(MSTU(11),5300) WIN
5611 C...Events defined in fixed target frame.
5612 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5614 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5615 IF(MSTP(122).GE.1) THEN
5616 LOFFS=(29-(LEN(2)+LEN(3)))/2
5617 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5618 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5619 & ' fixed target'//' '
5620 WRITE(MSTU(11),5200) CHINIT
5621 WRITE(MSTU(11),5400) WIN
5622 WRITE(MSTU(11),5500) SQRT(S)
5625 C...Frame defined by user three-vectors.
5626 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5630 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5631 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5632 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5633 & (P(1,3)+P(2,3))**2
5634 IF(MSTP(122).GE.1) THEN
5635 LOFFS=(22-(LEN(2)+LEN(3)))/2
5636 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5637 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5638 & ' user configuration'//' '
5639 WRITE(MSTU(11),5200) CHINIT
5640 WRITE(MSTU(11),5600)
5641 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5642 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5643 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5646 C...Frame defined by user four-vectors.
5647 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5649 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5650 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5651 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5652 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5653 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5654 & (P(1,3)+P(2,3))**2
5655 IF(MSTP(122).GE.1) THEN
5656 LOFFS=(22-(LEN(2)+LEN(3)))/2
5657 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5658 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5659 & ' user configuration'//' '
5660 WRITE(MSTU(11),5200) CHINIT
5661 WRITE(MSTU(11),5600)
5662 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5663 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5664 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5667 C...Frame defined by user five-vectors.
5668 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5670 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5671 & (P(1,3)+P(2,3))**2
5672 IF(MSTP(122).GE.1) THEN
5673 LOFFS=(22-(LEN(2)+LEN(3)))/2
5674 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5675 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5676 & ' user configuration'//' '
5677 WRITE(MSTU(11),5200) CHINIT
5678 WRITE(MSTU(11),5600)
5679 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5680 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5681 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5684 C...Frame defined by HEPRUP common block.
5685 ELSEIF(MINT(111).GE.11) THEN
5686 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5687 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5688 IF(MSTP(122).GE.1) THEN
5689 LOFFS=(22-(LEN(2)+LEN(3)))/2
5690 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5691 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5692 & ' user configuration'//' '
5693 WRITE(MSTU(11),5200) CHINIT
5694 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5695 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5698 C...Unknown frame. Error for too low CM energy.
5700 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5703 IF(S.LT.PARP(2)**2) THEN
5704 WRITE(MSTU(11),5900) SQRT(S)
5708 C...Formats for initialization and error information.
5709 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5710 &1X,'Execution stopped!')
5711 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5712 &1X,'Execution stopped!')
5713 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5714 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5715 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5716 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5717 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5718 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5719 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5720 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5721 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5722 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5723 &1X,'Execution stopped!')
5724 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5725 &'generation.'/1X,'Execution stopped!')
5726 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5727 &'GeV beam energies',13X,'I')
5732 C*********************************************************************
5735 C...Sets up kinematics, including rotations and boosts to/from CM frame.
5737 SUBROUTINE PYINKI(MODKI)
5739 C...Double precision and integer declarations.
5740 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5741 IMPLICIT INTEGER(I-N)
5742 INTEGER PYK,PYCHGE,PYCOMP
5744 C...User process initialization commonblock.
5746 PARAMETER (MAXPUP=100)
5747 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5748 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5749 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5750 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5755 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5756 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5757 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5758 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5759 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5760 COMMON/PYINT1/MINT(400),VINT(400)
5761 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5763 C...Set initial flavour state.
5768 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5771 C...Reset boost. Do kinematics for various cases.
5776 C...Set up kinematics for events defined in CM frame.
5777 IF(MINT(111).EQ.1) THEN
5779 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5783 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5784 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5789 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5792 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5793 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5795 C...Set up kinematics for fixed target events.
5796 ELSEIF(MINT(111).EQ.2) THEN
5798 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5801 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5802 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5808 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5811 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5812 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5813 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5815 C...Set up kinematics for events in user-defined frame.
5816 ELSEIF(MINT(111).EQ.3) THEN
5819 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5820 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5821 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5822 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5824 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5826 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5827 VINT(7)=PYANGL(P(1,1),P(1,2))
5828 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5829 VINT(6)=PYANGL(P(1,3),P(1,1))
5830 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5831 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5833 C...Set up kinematics for events with user-defined four-vectors.
5834 ELSEIF(MINT(111).EQ.4) THEN
5835 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5836 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5837 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5838 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5840 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5842 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5843 VINT(7)=PYANGL(P(1,1),P(1,2))
5844 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5845 VINT(6)=PYANGL(P(1,3),P(1,1))
5846 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5847 S=(P(1,4)+P(2,4))**2
5849 C...Set up kinematics for events with user-defined five-vectors.
5850 ELSEIF(MINT(111).EQ.5) THEN
5852 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5854 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5855 VINT(7)=PYANGL(P(1,1),P(1,2))
5856 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5857 VINT(6)=PYANGL(P(1,3),P(1,1))
5858 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5859 S=(P(1,4)+P(2,4))**2
5861 C...Set up kinematics for events with external user processes.
5862 ELSEIF(MINT(111).GE.11) THEN
5865 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5866 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5871 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5872 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5875 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5876 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5877 S=(P(1,4)+P(2,4))**2
5880 C...Return or error for too low CM energy.
5881 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5882 IF(MSTP(172).LE.1) THEN
5884 & '(PYINKI:) too low invariant mass in this event')
5891 C...Save information on incoming particles.
5894 IF(MINT(111).GE.4) THEN
5895 IF(MINT(141).EQ.0) THEN
5897 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5901 IF(MINT(142).EQ.0) THEN
5903 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5909 IF(MODKI.EQ.0) VINT(289)=S
5917 C...Store pT cut-off and related constants to be used in generation.
5918 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5919 IF(MSTP(82).LE.1) THEN
5920 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5922 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5924 VINT(149)=4D0*PTMN**2/S
5930 C*********************************************************************
5933 C...Selects partonic subprocesses to be included in the simulation.
5937 C...Double precision and integer declarations.
5938 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5939 IMPLICIT INTEGER(I-N)
5940 INTEGER PYK,PYCHGE,PYCOMP
5942 C...User process initialization commonblock.
5944 PARAMETER (MAXPUP=100)
5945 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5946 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5947 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5948 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5952 C...Commonblocks and character variables.
5953 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5954 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5955 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5956 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5957 COMMON/PYINT1/MINT(400),VINT(400)
5958 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5959 COMMON/PYINT6/PROC(0:500)
5961 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
5965 C...Reset processes to be included.
5972 C...Set running pTmin scale.
5973 IF(MSTP(82).LE.1) THEN
5974 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5976 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5979 C...Begin by assuming incoming photon to enter subprocess.
5980 IF(MINT(11).EQ.22) MINT(15)=22
5981 IF(MINT(12).EQ.22) MINT(16)=22
5983 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
5984 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
5986 MINT(123)=MINT(122)+1
5988 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
5990 C...Here also set a few parameters otherwise normally not touched.
5991 ELSEIF(MINT(121).GT.1) THEN
5993 C...Parton distributions dampened at small Q2; go to low energies,
5994 C...alpha_s <1; no minimum pT cut-off a priori.
5995 IF(MSTP(18).EQ.2) THEN
6003 C...Define pT cut-off parameters and whether run involves low-pT.
6007 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6009 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
6010 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
6012 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
6013 IF(MSEL.EQ.2) IPTL=1
6015 C...Set up for p/gamma * gamma; real or virtual photons.
6016 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
6017 & MSTP(14).EQ.30)) THEN
6019 C...Set up for p/VMD * VMD.
6020 IF(MINT(122).EQ.1) THEN
6028 IF(IPTL.EQ.1) MSUB(95)=1
6035 IF(IPTL.EQ.1) CKIN(3)=0D0
6037 C...Set up for p/VMD * direct gamma.
6038 ELSEIF(MINT(122).EQ.2) THEN
6040 IF(MINT(121).EQ.6) MINT(123)=5
6045 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6047 C...Set up for p/VMD * anomalous gamma.
6048 ELSEIF(MINT(122).EQ.3) THEN
6050 IF(MINT(121).EQ.6) MINT(123)=7
6057 IF(IPTL.EQ.1) MSUB(95)=1
6064 IF(IPTL.EQ.1) CKIN(3)=0D0
6066 C...Set up for DIS * p.
6067 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
6068 & IABS(MINT(12)).GT.100)) THEN
6070 IF(IPTL.EQ.1) MSUB(99)=1
6072 C...Set up for direct * direct gamma (switch off leptons).
6073 ELSEIF(MINT(122).EQ.4) THEN
6079 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6080 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6082 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6084 C...Set up for direct * anomalous gamma.
6085 ELSEIF(MINT(122).EQ.5) THEN
6091 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6093 C...Set up for anomalous * anomalous gamma.
6094 ELSEIF(MINT(122).EQ.6) THEN
6102 IF(IPTL.EQ.1) MSUB(95)=1
6109 IF(IPTL.EQ.1) CKIN(3)=0D0
6112 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
6113 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6115 C...Set up for direct * direct gamma (switch off leptons).
6116 IF(MINT(122).EQ.1) THEN
6122 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6123 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6125 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6127 C...Set up for direct * VMD and VMD * direct gamma.
6128 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
6134 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6136 C...Set up for direct * anomalous and anomalous * direct gamma.
6137 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
6143 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6145 C...Set up for VMD*VMD.
6146 ELSEIF(MINT(122).EQ.5) THEN
6154 IF(IPTL.EQ.1) MSUB(95)=1
6161 IF(IPTL.EQ.1) CKIN(3)=0D0
6163 C...Set up for VMD * anomalous and anomalous * VMD gamma.
6164 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
6172 IF(IPTL.EQ.1) MSUB(95)=1
6179 IF(IPTL.EQ.1) CKIN(3)=0D0
6181 C...Set up for anomalous * anomalous gamma.
6182 ELSEIF(MINT(122).EQ.9) THEN
6190 IF(IPTL.EQ.1) MSUB(95)=1
6197 IF(IPTL.EQ.1) CKIN(3)=0D0
6199 C...Set up for DIS * VMD and VMD * DIS gamma.
6200 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
6202 IF(IPTL.EQ.1) MSUB(99)=1
6204 C...Set up for DIS * anomalous and anomalous * DIS gamma.
6205 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
6207 IF(IPTL.EQ.1) MSUB(99)=1
6210 C...Set up for gamma* * p; virtual photons = dir, res.
6211 ELSEIF(MINT(121).EQ.2) THEN
6213 C...Set up for direct * p.
6214 IF(MINT(122).EQ.1) THEN
6220 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6222 C...Set up for resolved * p.
6223 ELSEIF(MINT(122).EQ.2) THEN
6231 IF(IPTL.EQ.1) MSUB(95)=1
6238 IF(IPTL.EQ.1) CKIN(3)=0D0
6241 C...Set up for gamma* * gamma*; virtual photons = dir, res.
6242 ELSEIF(MINT(121).EQ.4) THEN
6244 C...Set up for direct * direct gamma (switch off leptons).
6245 IF(MINT(122).EQ.1) THEN
6251 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6252 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6254 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6256 C...Set up for direct * resolved and resolved * direct gamma.
6257 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6263 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6265 C...Set up for resolved * resolved gamma.
6266 ELSEIF(MINT(122).EQ.4) THEN
6274 IF(IPTL.EQ.1) MSUB(95)=1
6281 IF(IPTL.EQ.1) CKIN(3)=0D0
6284 C...End of special set up for gamma-p and gamma-gamma.
6289 C...Flavour information for individual beams.
6292 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6293 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6294 MINT(44+I)=MINT(40+I)
6295 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6296 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6299 C...If two real gammas, whereof one direct, pick the first.
6300 C...For two virtual photons, keep requested order.
6301 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6302 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6305 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6306 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6309 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6310 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6313 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6314 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6317 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6318 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6321 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6324 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6328 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6329 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6330 IF(MINT(11).EQ.22) THEN
6338 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6339 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6342 C...Flavour information on combination of incoming particles.
6343 MINT(43)=2*MINT(41)+MINT(42)-2
6345 IF(MINT(123).LE.0) THEN
6346 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6347 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6348 ELSEIF(MINT(123).LE.3) THEN
6349 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6350 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6351 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6355 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6356 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6357 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6358 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6360 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6363 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6364 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6366 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6368 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6369 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6370 & MINT(122).EQ.10) MINT(108)=2
6371 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6372 & MINT(122).EQ.11) MINT(108)=3
6373 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6374 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6375 IF(MINT(122).GE.3) MINT(107)=1
6376 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6377 ELSEIF(MINT(121).EQ.2) THEN
6378 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6379 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6381 IF(MINT(11).EQ.22) THEN
6383 IF(MINT(123).GE.4) MINT(107)=0
6384 IF(MINT(123).EQ.7) MINT(107)=2
6385 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6386 IF(MSTP(14).EQ.28) MINT(107)=2
6387 IF(MSTP(14).EQ.29) MINT(107)=3
6388 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6391 IF(MINT(12).EQ.22) THEN
6393 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6394 IF(MINT(123).EQ.7) MINT(108)=3
6395 IF(MSTP(14).EQ.26) MINT(108)=2
6396 IF(MSTP(14).EQ.27) MINT(108)=3
6397 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6398 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6401 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6402 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6408 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6409 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6411 C...Select default processes according to incoming beams
6412 C...(already done for gamma-p and gamma-gamma with
6413 C...MSTP(14) = 10, 20, 25 or 30).
6414 IF(MINT(121).GT.1) THEN
6415 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6417 IF(MINT(43).EQ.1) THEN
6418 C...Lepton + lepton -> gamma/Z0 or W.
6419 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6420 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6422 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6423 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6424 C...Unresolved photon + lepton: Compton scattering.
6428 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6429 & .OR.MINT(12).EQ.22)) THEN
6430 C...DIS as pure gamma* + f -> f process.
6433 ELSEIF(MINT(43).LE.3) THEN
6434 C...Lepton + hadron: deep inelastic scattering.
6437 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6438 & MINT(12).EQ.22) THEN
6439 C...Two unresolved photons: fermion pair production,
6440 C...exclude lepton pairs.
6444 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6445 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6448 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6449 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6450 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6452 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6453 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6454 & MINT(12).EQ.22)) THEN
6455 C...Unresolved photon + hadron: photon-parton scattering.
6460 ELSEIF(MSEL.EQ.1) THEN
6461 C...High-pT QCD processes:
6470 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6471 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6474 C...All QCD processes:
6488 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6489 C...Heavy quark production.
6493 DO 180 J=1,MIN(8,MDCY(21,3))
6494 MDME(MDCY(21,2)+J-1,1)=0
6496 MDME(MDCY(21,2)+MSEL-1,1)=1
6498 DO 190 J=1,MIN(12,MDCY(22,3))
6499 MDME(MDCY(22,2)+J-1,1)=0
6501 MDME(MDCY(22,2)+MSEL-1,1)=1
6503 ELSEIF(MSEL.EQ.10) THEN
6504 C...Prompt photon production:
6509 ELSEIF(MSEL.EQ.11) THEN
6510 C...Z0/gamma* production:
6513 ELSEIF(MSEL.EQ.12) THEN
6514 C...W+/- production:
6517 ELSEIF(MSEL.EQ.13) THEN
6522 ELSEIF(MSEL.EQ.14) THEN
6527 ELSEIF(MSEL.EQ.15) THEN
6528 C...Z0 & W+/- pair production:
6535 ELSEIF(MSEL.EQ.16) THEN
6543 ELSEIF(MSEL.EQ.17) THEN
6544 C...h0 & Z0 or W+/- pair production:
6548 ELSEIF(MSEL.EQ.18) THEN
6549 C...h0 production; interesting processes in e+e-.
6555 ELSEIF(MSEL.EQ.19) THEN
6556 C...h0, H0 and A0 production; interesting processes in e+e-.
6570 ELSEIF(MSEL.EQ.21) THEN
6574 ELSEIF(MSEL.EQ.22) THEN
6575 C...W'+/- production:
6578 ELSEIF(MSEL.EQ.23) THEN
6579 C...H+/- production:
6582 ELSEIF(MSEL.EQ.24) THEN
6586 ELSEIF(MSEL.EQ.25) THEN
6587 C...LQ (leptoquark) production.
6593 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6594 C...Production of one heavy quark (W exchange):
6596 DO 200 J=1,MIN(8,MDCY(21,3))
6597 MDME(MDCY(21,2)+J-1,1)=0
6599 MDME(MDCY(21,2)+MSEL-31,1)=1
6601 CMRENNA++Define SUSY alternatives.
6602 ELSEIF(MSEL.EQ.39) THEN
6603 C...Turn on all SUSY processes.
6604 IF(MINT(43).EQ.4) THEN
6605 C...Hadron-hadron processes.
6607 IF(ISET(I).GE.0) MSUB(I)=1
6609 ELSEIF(MINT(43).EQ.1) THEN
6610 C...Lepton-lepton processes: QED production of squarks.
6627 ELSEIF(MSEL.EQ.40) THEN
6628 C...Gluinos and squarks.
6629 IF(MINT(43).EQ.4) THEN
6641 ELSEIF(MINT(43).EQ.1) THEN
6646 ELSEIF(MSEL.EQ.41) THEN
6647 C...Stop production.
6651 IF(MINT(43).EQ.4) THEN
6656 ELSEIF(MSEL.EQ.42) THEN
6657 C...Slepton production.
6661 IF(MINT(43).NE.4) THEN
6667 ELSEIF(MSEL.EQ.43) THEN
6668 C...Neutralino/Chargino + Gluino/Squark.
6669 IF(MINT(43).EQ.4) THEN
6679 ELSEIF(MSEL.EQ.44) THEN
6680 C...Neutralino/Chargino pair production.
6681 IF(MINT(43).EQ.4) THEN
6685 ELSEIF(MINT(43).EQ.1) THEN
6691 ELSEIF(MSEL.EQ.45) THEN
6692 C...Sbottom production.
6695 IF(MINT(43).EQ.4) THEN
6701 ELSEIF(MSEL.EQ.50) THEN
6702 C...Pair production of technipions and gauge bosons.
6706 IF(MINT(43).EQ.4) THEN
6712 ELSEIF(MSEL.EQ.51) THEN
6713 C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6718 ELSEIF(MSEL.EQ.61) THEN
6719 C...Charmonium production in colour octet model, with recoiling parton.
6724 ELSEIF(MSEL.EQ.62) THEN
6725 C...Bottomonium production in colour octet model, with recoiling parton.
6730 ELSEIF(MSEL.EQ.63) THEN
6731 C...Charmonium and bottomonium production in colour octet model.
6738 C...Find heaviest new quark flavour allowed in processes 81-84.
6740 DO 350 I=1,MIN(8,MDCY(21,3))
6742 IF(MDME(IDC,1).LE.0) GOTO 350
6745 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6756 C...Find heaviest new fermion flavour allowed in process 85.
6758 DO 360 I=1,MIN(12,MDCY(22,3))
6760 IF(MDME(IDC,1).LE.0) GOTO 360
6763 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6764 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6769 C...Import relevant information on external user processes.
6770 IF(MINT(111).GE.11) THEN
6773 C...Find next empty PYTHIA process number slot and enable it.
6775 IF(IPYPR.GT.500) CALL PYERRM(26,
6776 & '(PYINPR.) no more empty slots for user processes')
6777 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6778 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6780 C...Overwrite KFPR with references back to process number and ID.
6782 KFPR(IPYPR,2)=LPRUP(IUP)
6784 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6787 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6789 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6790 C...Switch on process.
6798 C*********************************************************************
6801 C...Parametrizes total, elastic and diffractive cross-sections
6802 C...for different energies and beams. Donnachie-Landshoff for
6803 C...total and Schuler-Sjostrand for elastic and diffractive.
6804 C...Process code IPROC:
6811 C...= 7 : J/psi + p;
6812 C...= 11 : rho + rho;
6813 C...= 12 : rho + phi;
6814 C...= 13 : rho + J/psi;
6815 C...= 14 : phi + phi;
6816 C...= 15 : phi + J/psi;
6817 C...= 16 : J/psi + J/psi;
6818 C...= 21 : gamma + p (DL);
6819 C...= 22 : gamma + p (VDM).
6820 C...= 23 : gamma + pi (DL);
6821 C...= 24 : gamma + pi (VDM);
6822 C...= 25 : gamma + gamma (DL);
6823 C...= 26 : gamma + gamma (VDM).
6827 C...Double precision and integer declarations.
6828 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6829 IMPLICIT INTEGER(I-N)
6830 INTEGER PYK,PYCHGE,PYCOMP
6832 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6833 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6834 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6835 COMMON/PYINT1/MINT(400),VINT(400)
6836 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6837 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6838 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6840 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6841 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6842 &CEFFD(10,9),SIGTMP(6,0:5)
6844 C...Common constants.
6845 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6846 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6849 C...Number of multiple processes to be evaluated (= 0 : undefined).
6850 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6851 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6852 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6853 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6854 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6856 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6857 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6858 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6860 C...Beam and target hadron class:
6861 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6862 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6863 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6864 C...Characteristic class masses, slope parameters, beta = sqrt(X).
6865 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6866 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6867 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6869 C...Fitting constants used in parametrizations of diffractive results.
6870 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6871 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6872 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6873 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6874 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6875 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6876 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6877 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6878 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6879 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6880 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6881 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6882 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6883 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6884 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6885 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6886 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6887 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6888 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6889 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6890 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6891 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6892 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6893 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6894 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6895 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6896 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6897 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6898 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6900 C...Parameters. Combinations of the energy.
6909 C...Ratio of gamma/pi (for rescaling in parton distributions).
6910 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
6911 &(XPAR(5)*SEPS+YPAR(5)*SETA)
6913 IF(MINT(50).NE.1) RETURN
6915 C...Order flavours of incoming particles: KF1 < KF2.
6916 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
6925 ISGN12=ISIGN(1,MINT(11)*MINT(12))
6927 C...Find process number (for lookup tables).
6928 IF(KF1.GT.1000) THEN
6930 IF(ISGN12.LT.0) IPROC=2
6931 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
6933 IF(ISGN12.LT.0) IPROC=4
6934 IF(KF1.EQ.111) IPROC=5
6935 ELSEIF(KF1.GT.100) THEN
6937 ELSEIF(KF2.GT.1000) THEN
6939 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
6940 ELSEIF(KF2.GT.100) THEN
6942 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
6945 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
6948 C... Number of multiple processes to be stored; beam/target side.
6954 ELSEIF(NPR.EQ.6) THEN
6959 IF(MINT(101).EQ.4) N1=4
6961 IF(MINT(102).EQ.4) N2=4
6963 C...Do not do any more for user-set or undefined cross-sections.
6964 IF(MSTP(31).LE.0) RETURN
6965 IF(NPR.EQ.0) CALL PYERRM(26,
6966 &'(PYXTOT:) cross section for this process not yet implemented')
6968 C...Parameters. Combinations of the energy.
6977 C...Loop over multiple processes (for VDM).
6981 ELSEIF(NPR.EQ.3) THEN
6983 IF(KF2.LT.1000) IPR=I+10
6984 ELSEIF(NPR.EQ.6) THEN
6988 C...Evaluate hadron species, mass, slope contribution and fit number.
6998 C...Skip if energy too low relative to masses.
7002 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
7004 C...Total cross-section. Elastic slope parameter and cross-section.
7005 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
7006 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
7007 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
7009 C...Diffractive scattering A + B -> X + B.
7012 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
7013 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7014 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7015 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
7016 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
7017 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
7018 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
7020 C...Diffractive scattering A + B -> A + X.
7023 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
7024 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7025 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7026 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
7027 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
7028 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
7029 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
7031 C...Order single diffractive correctly.
7034 SIGTMP(I,2)=SIGTMP(I,3)
7038 C...Double diffractive scattering A + B -> X1 + X2.
7039 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
7040 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
7041 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
7042 IF(YEFF.LE.0) SUM1=0D0
7043 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
7044 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
7045 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
7046 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
7048 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
7049 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
7050 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
7052 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
7053 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
7054 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
7055 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
7056 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
7058 C...Non-diffractive by unitarity.
7059 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
7063 C...Put temporary results in output array: only one process.
7064 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
7066 SIGT(0,0,J)=SIGTMP(1,J)
7069 C...Beam multiple processes.
7070 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
7071 IF(MINT(107).EQ.2) THEN
7072 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7074 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7075 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7077 IF(MSTP(20).GT.0) THEN
7078 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
7081 IF(MINT(107).EQ.2) THEN
7082 CONV=(AEM/PARP(160+I))*VINT(317)
7083 ELSEIF(VINT(154).GT.PARP(15)) THEN
7084 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7085 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7091 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
7095 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7098 C...Target multiple processes.
7099 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
7100 IF(MINT(108).EQ.2) THEN
7101 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7103 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7104 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7106 IF(MSTP(20).GT.0) THEN
7107 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
7110 IF(MINT(108).EQ.2) THEN
7111 CONV=(AEM/PARP(160+I))*VINT(317)
7112 ELSEIF(VINT(154).GT.PARP(15)) THEN
7113 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7114 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7120 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
7124 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
7127 C...Both beam and target multiple processes.
7129 IF(MINT(107).EQ.2) THEN
7130 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7132 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7133 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7135 IF(MINT(108).EQ.2) THEN
7136 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7138 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
7139 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7141 IF(MSTP(20).GT.0) THEN
7142 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
7143 & VINT(308)))**MSTP(20)
7147 IF(MINT(107).EQ.2) THEN
7148 CONV=(AEM/PARP(160+I1))*VINT(317)
7149 ELSEIF(VINT(154).GT.PARP(15)) THEN
7150 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
7151 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7155 IF(MINT(108).EQ.2) THEN
7156 CONV=CONV*(AEM/PARP(160+I2))
7157 ELSEIF(VINT(154).GT.PARP(15)) THEN
7158 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
7159 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
7165 ELSEIF(I2.LE.2) THEN
7167 ELSEIF(I1.EQ.I2) THEN
7174 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
7175 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
7181 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
7182 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
7184 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7188 C...Scale up uniformly for Donnachie-Landshoff parametrization.
7189 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
7190 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
7194 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
7203 C*********************************************************************
7206 C...Finds optimal set of coefficients for kinematical variable selection
7207 C...and the maximum of the part of the differential cross-section used
7208 C...in the event weighting.
7212 C...Double precision and integer declarations.
7213 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7214 IMPLICIT INTEGER(I-N)
7215 INTEGER PYK,PYCHGE,PYCOMP
7216 C...Parameter statement to help give large particle numbers.
7217 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7218 &KEXCIT=4000000,KDIMEN=5000000)
7220 C...User process initialization commonblock.
7222 PARAMETER (MAXPUP=100)
7223 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7224 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7225 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7226 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7231 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7232 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7233 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7234 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7235 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7236 COMMON/PYINT1/MINT(400),VINT(400)
7237 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7238 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7239 COMMON/PYINT4/MWID(500),WIDS(500,5)
7240 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7241 COMMON/PYINT6/PROC(0:500)
7243 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7244 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
7245 COMMON/PYTCCO/COEFX(194:380,2)
7246 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
7247 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7248 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
7250 C...Local arrays, character variables and data.
7253 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7254 &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
7255 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2),WTRSAV(9),TEMPC(9),
7257 DATA CVAR/'tau ','tau''','y* ','cth '/
7260 C...Initial values and loop over subprocesses.
7270 C...Find maximum weight factors for photon flux.
7271 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7272 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7275 C...Select subprocess to study: skip cases not applicable.
7276 IF(ISET(ISUB).EQ.11) THEN
7277 IF(MSUB(ISUB).NE.1) GOTO 460
7278 C...User process intialization: cross section model dependent.
7279 IF(IABS(IDWTUP).EQ.1) THEN
7280 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7281 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7282 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7284 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7285 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7286 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7287 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7288 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7289 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7291 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7292 & WTGAGA*XSEC(ISUB,1)
7295 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7296 CALL PYSIGH(NCHN,SIGS)
7298 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7299 & WTGAGA*XSEC(ISUB,1)
7300 IF(MSUB(ISUB).NE.1) GOTO 460
7303 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7304 CALL PYSIGH(NCHN,SIGS)
7306 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7307 & WTGAGA*XSEC(ISUB,1)
7308 IF(XSEC(ISUB,1).EQ.0D0) THEN
7314 ELSEIF(ISUB.EQ.96) THEN
7315 IF(MINT(50).EQ.0) GOTO 460
7316 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7318 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7319 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7320 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7321 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7322 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7323 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7325 IF(MSUB(ISUB).NE.1) GOTO 460
7328 IF(ISUB.EQ.96) ISTSB=2
7329 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7331 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7332 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7334 C...Find resonances (explicit or implicit in cross-section).
7337 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7339 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7340 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7342 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7343 & .OR.ISUB.EQ.177) THEN
7345 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7347 IF(MSTP(46).EQ.5) THEN
7350 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7354 IF(CKMX.LE.0D0) CKMX=VINT(1)
7357 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7358 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7361 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7362 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7370 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
7371 $ (ISUB.GE.361.AND.ISUB.LE.380))
7374 IF(ISUB.EQ.141) THEN
7376 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7377 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
7380 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7381 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7387 ELSEIF(ITECH.EQ.0) THEN
7388 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
7397 C...Order the resonances
7398 IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
7403 IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
7408 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7415 SHN0=PMAS(KCR1,1)**2
7417 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
7418 SHN0=PMAS(KCR2,1)**2
7420 IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
7421 SHN0=PMAS(KCR3,1)**2
7424 FAR=SQRT(AEM/ALPRHT)
7426 CALL PYTECM(SHN,S1,WIDO,1)
7431 CALL PYTECM(SHN,S1,WIDO,1)
7432 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7435 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7436 ELSEIF(IRES.EQ.0) THEN
7446 IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
7453 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7460 SHN0=PMAS(KCR1,1)**2
7462 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
7463 SHN0=PMAS(KCR2,1)**2
7466 FAR=SQRT(AEM/ALPRHT)
7468 CALL PYTECM(SHN,S1,WIDO,2)
7473 CALL PYTECM(SHN,S1,WIDO,2)
7474 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7477 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7478 ELSEIF(JRES.EQ.0) THEN
7488 IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
7491 IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
7492 & ISUB.EQ.379.OR.ISUB.EQ.380) THEN
7495 VINT(73)=XMAS(1)**2/VINT(2)
7496 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
7504 VINT(75)=XMAS(2)**2/VINT(2)
7505 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
7513 VINT(77)=XMAS(3)**2/VINT(2)
7514 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
7521 C...Charged current: rho+- and a+-
7522 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
7525 VINT(73)=YMAS(1)**2/VINT(2)
7526 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
7534 VINT(75)=YMAS(2)**2/VINT(2)
7535 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
7544 IF(ISUB.NE.141) THEN
7545 IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
7546 & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
7547 IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
7548 & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
7549 IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
7550 & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
7551 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
7553 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
7555 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
7560 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
7568 ELSEIF(KFR1.NE.0) THEN
7570 ELSEIF(KFR2.NE.0) THEN
7575 ELSEIF(KFR3.NE.0) THEN
7584 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7586 ELSEIF(KFR2.NE.0) THEN
7601 C...Find product masses and minimum pT of process.
7607 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7611 IF(KFPR(ISUB,I).EQ.0) THEN
7612 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7614 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7615 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7618 C...This prevents SUSY/t particles from becoming too light.
7620 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7623 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7624 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7625 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7626 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7627 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7628 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7629 PMMN(I)=MIN(PMMN(I),PMSUM)
7632 ELSEIF(KFLW.EQ.6) THEN
7633 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7640 CKIN(41)=MAX(PMMN(1),CKIN(41))
7641 CKIN(43)=MAX(PMMN(2),CKIN(43))
7642 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7645 IF(MINT(51).EQ.1) THEN
7646 WRITE(MSTU(11),5100) ISUB
7653 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7654 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7655 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7656 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7657 ELSEIF(ISUB.EQ.96) THEN
7658 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7664 C...Prepare for additional variable choices in 2 -> 3.
7667 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7669 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7670 VINT(204)=PMAS(23,1)
7671 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7672 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7673 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7674 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7675 & VINT(204)=VINT(201)
7677 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7680 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7682 NPTS(1)=2+2*MINT(72)
7683 IF(MINT(47).EQ.1) THEN
7684 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7685 ELSEIF(MINT(47).GE.5) THEN
7686 IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
7692 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7693 IF(MINT(47).GE.2) NPTS(2)=2
7694 IF(MINT(47).GE.5) NPTS(2)=3
7697 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7699 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7700 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7703 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7704 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7706 C...Reset coefficients of cross-section weighting.
7710 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
7711 & .AND.ISUB.LE.380)) THEN
7728 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7729 C...in grid of phase space points.
7735 IF(METAU.EQ.1) GOTO 150
7736 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7737 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7738 IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
7740 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
7744 C...Special case when both resonances have same mass,
7745 C...as is often the case in process 194.
7746 c IF(MINT(72).GE.2) THEN
7747 c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7748 c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7749 c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7751 c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7756 CALL PYKMAP(1,MTAU,RTAU)
7757 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7760 IF(METAUP.EQ.1) GOTO 150
7761 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7763 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7764 CALL PYKMAP(4,MTAUP,0.5D0)
7766 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7770 IF(MEYST.EQ.1) GOTO 150
7771 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7772 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7773 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7774 CALL PYKMAP(2,MYST,0.5D0)
7778 IF(MECTH.EQ.1) GOTO 150
7779 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7780 MCTH=1+MOD(ITRY-1,NPTS(4))
7781 CALL PYKMAP(3,MCTH,0.5D0)
7783 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7785 C...Store position and limits.
7788 IF(MINT(51).EQ.1) GOTO 150
7791 MVARPT(NACC,2)=MTAUP
7795 VINTPT(NACC,J)=VINT(10+J)
7798 C...Normal case: calculate cross-section.
7800 CALL PYSIGH(NCHN,SIGS)
7806 C..2 -> 3: find highest value out of a number of tries.
7809 DO 140 IKIN3=1,MSTP(129)
7810 CALL PYKMAP(5,0,0D0)
7811 IF(MINT(51).EQ.1) GOTO 140
7812 CALL PYSIGH(NCHN,SIGTMP)
7817 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7821 C...Store cross-section.
7823 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7824 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7825 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7828 WRITE(MSTU(11),5100) ISUB
7831 ELSEIF(SIGSAM.EQ.0D0) THEN
7832 WRITE(MSTU(11),5300) ISUB
7836 IF(ISUB.NE.96) NPOSI=NPOSI+1
7838 C...Calculate integrals in tau over maximal phase space limits.
7841 ATAU1=LOG(TAUMAX/TAUMIN)
7842 IF(NPTS(1).GE.2) THEN
7843 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7845 IF(NPTS(1).GE.4) THEN
7846 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7847 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7850 IF(NPTS(1).GE.6) THEN
7851 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7852 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7855 IF(NPTS(1).GE.8) THEN
7856 ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
7857 ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
7860 IF(IPEAK7.EQ.1) THEN
7861 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7864 C...Reset. Sum up cross-sections in points calculated.
7866 IF(NPTS(IVAR).EQ.1) GOTO 320
7867 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7878 IBIN=MVARPT(IACC,IVAR)
7880 IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
7882 ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
7886 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7887 NAREL(IBIN)=NAREL(IBIN)+1
7888 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7890 C...Sum up tau cross-section pieces in points used.
7893 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7894 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7896 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7897 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7898 & ((TAU-TAUR1)**2+GAMR1**2)
7901 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7902 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7903 & ((TAU-TAUR2)**2+GAMR2**2)
7905 IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
7906 WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
7907 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7908 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
7909 WTMAT(IBIN,7)=WTMAT(IBIN,7)
7910 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7912 IF(MINT(72).EQ.3) THEN
7913 WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
7914 & +(ATAU1/ATAU8)/(TAU+TAUR3)
7915 WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
7916 & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
7918 C...Sum up tau' cross-section pieces in points used.
7919 ELSEIF(IVAR.EQ.2) THEN
7921 TAUP=VINTPT(IACC,16)
7922 TAUPMN=VINTPT(IACC,6)
7923 TAUPMX=VINTPT(IACC,26)
7924 ATAUP1=LOG(TAUPMX/TAUPMN)
7925 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
7926 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7927 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
7928 & (1D0-TAU/TAUP)**3/TAUP
7930 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
7931 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
7932 & TAUP/MAX(2D-10,1D0-TAUP)
7935 C...Sum up y* cross-section pieces in points used.
7936 ELSEIF(IVAR.EQ.3) THEN
7938 YSTMIN=VINTPT(IACC,2)
7939 YSTMAX=VINTPT(IACC,22)
7941 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
7943 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
7944 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
7945 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
7946 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
7947 IF(MINT(45).EQ.3) THEN
7948 TAUE=VINTPT(IACC,11)
7949 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7950 YST0=-0.5D0*LOG(TAUE)
7951 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
7952 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
7953 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
7954 & MAX(1D-10,1D0-EXP(YST-YST0))
7956 IF(MINT(46).EQ.3) THEN
7957 TAUE=VINTPT(IACC,11)
7958 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7959 YST0=-0.5D0*LOG(TAUE)
7960 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
7961 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
7962 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
7963 & MAX(1D-10,1D0-EXP(-YST-YST0))
7966 C...Sum up cos(theta-hat) cross-section pieces in points used.
7968 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
7970 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
7972 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
7975 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
7976 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
7977 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
7978 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
7980 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7981 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
7982 & MAX(RM34,RSQM-CTH)
7983 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
7984 & MAX(RM34,RSQM+CTH)
7985 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
7986 & MAX(RM34,RSQM-CTH)**2
7987 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
7988 & MAX(RM34,RSQM+CTH)**2
7992 C...Check that equation system solvable.
7993 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
7997 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
7998 & IRED=1,NBIN),WTREL(IBIN)
7999 IF(NAREL(IBIN).EQ.0) MSOLV=0
8000 WTRELS=WTRELS+WTREL(IBIN)
8002 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
8004 C...Solve to find relative importance of cross-section pieces.
8007 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
8008 WTRSAV(IBIN)=WTREL(IBIN)
8010 C...Auxiliary vectors to record order of permutations
8015 DO 230 IRED=1,NBIN-1
8017 RESMAX=ABS(WTREL(MROW))
8018 C...Find row with largest residual
8020 IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN
8022 RESMAX=ABS(WTREL(MROW))
8025 IF(RESMAX.LT.1D-20) THEN
8030 AMAX = ABS(WTMAT(MROW,MCOL))
8031 C...Find column with largest entry
8033 IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN
8035 AMAX = ABS(WTMAT(MROW,MCOL))
8038 C...Swap rows if necessary
8039 IF(MROW.NE.IRED) THEN
8041 TMPE=WTMAT(IRED,JBIN)
8042 WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN)
8043 WTMAT(MROW,JBIN)=TMPE
8046 WTREL(IRED)=WTREL(MROW)
8052 C...Swap columns if necessary
8053 IF(MCOL.NE.IRED) THEN
8055 TMPE=WTMAT(JBIN,IRED)
8056 WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL)
8057 WTMAT(JBIN,MCOL)=TMPE
8063 C...Begin eliminating equations
8064 DO 220 IBIN=IRED+1,NBIN
8065 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8069 C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
8070 RQTU=WTMAT(IBIN,IRED)
8071 RQTL=WTMAT(IRED,IRED)
8072 C...Switch order of operations
8073 WTREL(IBIN)=WTREL(IBIN)-RQTU*
8074 $ (WTREL(IRED)/RQTL)
8075 DO 210 ICOE=IRED,NBIN
8076 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-
8077 $ RQTU*(WTMAT(IRED,ICOE)/RQTL)
8081 DO 250 IRED=NBIN,1,-1
8082 DO 240 ICOE=IRED+1,NBIN
8083 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
8085 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8089 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
8090 TEMPC(IRED)=COEFU(IRED)
8092 C...Return to original order
8095 COEFU(MTMP)=TEMPC(IBIN)
8099 C...Share evenly if failure.
8100 260 IF(MSOLV.EQ.0) THEN
8104 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
8105 & WTRSAV(IBIN)/WTRELS)
8109 C...Normalize coefficients, with piece shared democratically.
8113 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
8114 COEFSU=COEFSU+COEFU(IBIN)
8115 WTRELS=WTRELS+WTRELN(IBIN)
8117 IF(COEFSU.GT.0D0) THEN
8119 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
8120 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
8124 COEFO(IBIN)=1D0/NBIN
8127 IF(IVAR.EQ.1) IOFF=0
8128 IF(IVAR.EQ.2) IOFF=17
8129 IF(IVAR.EQ.3) IOFF=7
8130 IF(IVAR.EQ.4) IOFF=12
8134 IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
8138 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
8139 IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
8140 COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
8142 COEF(ISUB,ICOF)=COEFO(IBIN)
8146 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
8147 & (COEFO(IBIN),IBIN=1,NBIN)
8151 C...Find two most promising maxima among points previously determined.
8159 VINT(10+J)=VINTPT(IACC,J)
8162 CALL PYSIGH(NCHN,SIGS)
8169 DO 350 IKIN3=1,MSTP(129)
8170 CALL PYKMAP(5,0,0D0)
8171 IF(MINT(51).EQ.1) GOTO 350
8172 CALL PYSIGH(NCHN,SIGTMP)
8177 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8182 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
8185 DO 370 IMV=NMAX,1,-1
8187 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
8188 IACCMX(IMV+1)=IACCMX(IMV)
8189 SIGSMX(IMV+1)=SIGSMX(IMV)
8192 380 IACCMX(IIN)=IACC
8194 IF(NMAX.LE.1) NMAX=NMAX+1
8198 C...Read out starting position for search.
8199 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
8204 MTAUP=MVARPT(IACC,2)
8212 C...Starting point and step size in parameter space.
8215 IF(NPTS(IVAR).EQ.1) GOTO 420
8216 IF(IVAR.EQ.1) VVAR=VTAU
8217 IF(IVAR.EQ.2) VVAR=VTAUP
8218 IF(IVAR.EQ.3) VVAR=VYST
8219 IF(IVAR.EQ.4) VVAR=VCTH
8220 IF(IVAR.EQ.1) MVAR=MTAU
8221 IF(IVAR.EQ.2) MVAR=MTAUP
8222 IF(IVAR.EQ.3) MVAR=MYST
8223 IF(IVAR.EQ.4) MVAR=MCTH
8224 IF(IRPT.EQ.1) VDEL=0.1D0
8225 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
8227 IF(IRPT.EQ.1) VMAR=0.02D0
8228 IF(IRPT.EQ.2) VMAR=0.002D0
8230 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
8233 C...Define new point in parameter space.
8237 ELSEIF(IMOV.EQ.1) THEN
8240 ELSEIF(IMOV.EQ.2) THEN
8243 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
8244 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
8250 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
8251 & VVAR-2D0*VDEL.GT.VMAR) THEN
8257 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
8271 C...Convert to relevant variables and find derived new limits.
8275 CALL PYKMAP(1,MTAU,VTAU)
8276 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8278 IF(MINT(51).EQ.1) ILERR=1
8281 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
8283 IF(IVAR.EQ.2) VTAUP=VNEW
8284 CALL PYKMAP(4,MTAUP,VTAUP)
8286 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
8288 IF(MINT(51).EQ.1) ILERR=1
8290 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
8291 IF(IVAR.EQ.3) VYST=VNEW
8292 CALL PYKMAP(2,MYST,VYST)
8294 IF(MINT(51).EQ.1) ILERR=1
8296 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
8298 IF(IVAR.EQ.4) VCTH=VNEW
8299 CALL PYKMAP(3,MCTH,VCTH)
8301 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
8303 C...Evaluate cross-section. Save new maximum. Final maximum.
8306 ELSEIF(ISTSB.NE.5) THEN
8307 CALL PYSIGH(NCHN,SIGS)
8314 DO 400 IKIN3=1,MSTP(129)
8315 CALL PYKMAP(5,0,0D0)
8316 IF(MINT(51).EQ.1) GOTO 400
8317 CALL PYSIGH(NCHN,SIGTMP)
8322 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8326 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
8327 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
8328 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
8333 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
8334 XSEC(ISUB,1)=1.05D0*SIGSAM
8335 C...Add extra headroom for UED
8336 IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0
8337 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
8338 & WTGAGA*XSEC(ISUB,1)
8340 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
8341 & PARP(174)*XSEC(ISUB,1)
8342 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
8346 C...Print summary table.
8347 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
8348 IF(MSTP(127).NE.1) THEN
8349 WRITE(MSTU(11),5900)
8352 WRITE(MSTU(11),6400)
8356 IF(MSTP(122).GE.1) THEN
8357 WRITE(MSTU(11),6000)
8358 WRITE(MSTU(11),6100)
8360 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
8361 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
8362 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
8364 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
8365 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
8366 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
8367 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
8368 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
8370 WRITE(MSTU(11),6300)
8373 C...Format statements for maximization results.
8374 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
8375 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
8376 &'cth',9X,'tau''',7X,'sigma')
8377 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
8378 &'phase space.'/1X,'Process switched off!')
8379 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
8380 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
8381 &'cross-section.'/1X,'Process switched off!')
8382 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
8383 5500 FORMAT(1X,1P,10D11.3)
8384 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
8385 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
8386 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
8387 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
8388 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
8389 &'cross-section.'/1X,'Execution stopped!')
8390 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
8391 &'cross-section maximum search',1X,8('*'))
8392 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
8393 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
8394 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
8395 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
8396 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
8397 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
8399 &1X,'Execution will stop if you try to generate events.')
8404 C*********************************************************************
8407 C...Initializes multiplicity distribution and selects mutliplicity
8408 C...of pileup events, i.e. several events occuring at the same
8411 SUBROUTINE PYPILE(MPILE)
8413 C...Double precision and integer declarations.
8414 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8415 IMPLICIT INTEGER(I-N)
8416 INTEGER PYK,PYCHGE,PYCOMP
8418 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8419 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8420 COMMON/PYINT1/MINT(400),VINT(400)
8421 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8422 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
8423 C...Local arrays and saved variables.
8424 DIMENSION WTI(0:200)
8425 SAVE IMIN,IMAX,WTI,WTS
8427 C...Sum of allowed cross-sections for pileup events.
8429 VINT(131)=SIGT(0,0,5)
8430 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
8431 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
8432 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
8433 IF(MSTP(133).LE.0) RETURN
8435 C...Initialize multiplicity distribution at maximum.
8436 XNAVE=VINT(131)*PARP(131)
8437 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
8438 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
8441 WTN=WTI(INAVE)*INAVE
8443 C...Find shape of multiplicity distribution below maximum.
8445 DO 100 I=INAVE-1,1,-1
8446 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
8447 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
8448 IF(WTI(I).LT.1D-6) GOTO 110
8454 C...Find shape of multiplicity distribution above maximum.
8456 DO 120 I=INAVE+1,200
8457 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
8458 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
8459 IF(WTI(I).LT.1D-6) GOTO 130
8466 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
8467 & WTS/(WTS+WTI(1)/XNAVE)
8468 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
8469 IF(MSTP(133).GE.2) VINT(134)=XNAVE
8471 C...Pick multiplicity of pileup events.
8473 IF(MSTP(133).LE.0) THEN
8474 MINT(81)=MAX(1,MSTP(134))
8480 IF(WTR.LE.0D0) GOTO 150
8486 C...Format statement for error message.
8487 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
8488 &'crossing too large, ',1P,D12.4)
8493 C*********************************************************************
8496 C...Saves and restores parameter and cross section values for the
8497 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8498 C...Also makes random choice between alternatives.
8500 SUBROUTINE PYSAVE(ISAVE,IGA)
8502 C...Double precision and integer declarations.
8503 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8504 IMPLICIT INTEGER(I-N)
8505 INTEGER PYK,PYCHGE,PYCOMP
8507 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8508 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8509 COMMON/PYINT1/MINT(400),VINT(400)
8510 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8511 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8512 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8513 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
8514 C...Local arrays and saved variables.
8515 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
8516 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
8517 &INTCP(15,20),RECP(15,20)
8518 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
8520 C...Save list of subprocesses and cross-section information.
8524 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
8527 MSUBCP(IGA,ICP)=MSUB(I)
8529 COEFCP(IGA,ICP,J)=COEF(I,J)
8532 NGENCP(IGA,ICP,J)=NGEN(I,J)
8533 XSECCP(IGA,ICP,J)=XSEC(I,J)
8538 NGENCP(IGA,0,J)=NGEN(0,J)
8539 XSECCP(IGA,0,J)=XSEC(0,J)
8544 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
8549 C...Save various common process variables.
8551 INTCP(IGA,J)=MINT(40+J)
8553 INTCP(IGA,11)=MINT(101)
8554 INTCP(IGA,12)=MINT(102)
8555 INTCP(IGA,13)=MINT(107)
8556 INTCP(IGA,14)=MINT(108)
8557 INTCP(IGA,15)=MINT(123)
8559 RECP(IGA,2)=VINT(318)
8561 C...Save cross-section information only.
8562 ELSEIF(ISAVE.EQ.2) THEN
8563 DO 190 ICP=1,NCP(IGA)
8566 NGENCP(IGA,ICP,J)=NGEN(I,J)
8567 XSECCP(IGA,ICP,J)=XSEC(I,J)
8571 NGENCP(IGA,0,J)=NGEN(0,J)
8572 XSECCP(IGA,0,J)=XSEC(0,J)
8575 C...Choose between allowed alternatives.
8576 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8579 DO 210 IG=1,MINT(121)
8580 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8582 XSUMCP=XSUMCP*PYR(0)
8583 DO 220 IG=1,MINT(121)
8585 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8586 IF(XSUMCP.LE.0D0) GOTO 230
8591 C...Restore cross-section information.
8595 DO 270 ICP=1,NCP(IGA)
8597 MSUB(I)=MSUBCP(IGA,ICP)
8599 COEF(I,J)=COEFCP(IGA,ICP,J)
8602 NGEN(I,J)=NGENCP(IGA,ICP,J)
8603 XSEC(I,J)=XSECCP(IGA,ICP,J)
8607 NGEN(0,J)=NGENCP(IGA,0,J)
8608 XSEC(0,J)=XSECCP(IGA,0,J)
8613 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8618 C...Restore various common process variables.
8620 MINT(40+J)=INTCP(IGA,J)
8622 MINT(101)=INTCP(IGA,11)
8623 MINT(102)=INTCP(IGA,12)
8624 MINT(107)=INTCP(IGA,13)
8625 MINT(108)=INTCP(IGA,14)
8626 MINT(123)=INTCP(IGA,15)
8629 VINT(318)=RECP(IGA,2)
8631 C...Sum up cross-section info (for PYSTAT).
8632 ELSEIF(ISAVE.EQ.5) THEN
8643 DO 350 IG=1,MINT(121)
8644 DO 340 ICP=1,NCP(IG)
8646 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8647 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8648 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8649 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8651 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8652 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8653 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8654 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8661 C*********************************************************************
8664 C...For lepton beams it gives photon-hadron or photon-photon systems
8665 C...to be treated with the ordinary machinery and combines this with a
8666 C...description of the lepton -> lepton + photon branching.
8668 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8670 C...Double precision and integer declarations.
8671 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8672 IMPLICIT INTEGER(I-N)
8673 INTEGER PYK,PYCHGE,PYCOMP
8675 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8676 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8677 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8678 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8679 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8680 COMMON/PYINT1/MINT(400),VINT(400)
8681 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8682 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8684 C...Local variables and data statement.
8685 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8686 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8687 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8690 C...Initialize generation of photons inside leptons.
8693 C...Save quantities on incoming lepton system.
8697 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8699 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8700 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8701 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8703 C...Calculate range of x and Q2 values allowed in generation.
8705 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8706 IF(MINT(140+I).NE.0) THEN
8707 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8708 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8710 YMIN=MAX(CKIN(71+2*I),EPS)
8711 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8712 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8713 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8714 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8715 THEMIN=MAX(CKIN(67+2*I),0D0)
8716 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8717 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8718 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8719 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8720 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8721 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8722 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8723 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8724 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8725 C...W limits when lepton on one side only.
8726 IF(MINT(143-I).EQ.0) THEN
8727 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8728 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8729 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8734 C...W limits when lepton on both sides.
8735 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8736 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8737 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8738 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8739 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8740 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8741 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8742 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8743 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8744 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8746 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8747 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8751 C...Q2 and W values and photon flux weight factors for initialization.
8752 ELSEIF(IGAGA.EQ.2) THEN
8757 C...W value for photon on one or both sides, and for processes
8758 C...with gamma-gamma cross section peaked at small shat.
8759 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8760 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8761 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8762 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8763 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8764 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8765 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8767 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8768 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8770 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8772 C...Upper estimate of photon flux weight factor.
8773 C...Initialization Q2 scale. Flag incoming unresolved photon.
8776 IF(MINT(140+I).NE.0) THEN
8777 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8778 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8779 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8781 Q2INIT=5D0+Q2MIN(3-I)
8782 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8783 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8784 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8785 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8786 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8787 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8789 ELSEIF(ISUB.EQ.140) THEN
8794 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8795 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8797 VINT(306+I)=VINT(2+I)**2
8802 C...Update pTmin and cross section information.
8803 IF(MSTP(82).LE.1) THEN
8804 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8806 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8808 VINT(149)=4D0*PTMN**2/VINT(2)
8813 C...Generate photons inside leptons and
8814 C...calculate photon flux weight factors.
8815 ELSEIF(IGAGA.EQ.3) THEN
8820 C...Generate phase space point and check against cuts.
8824 IF(MINT(140+I).NE.0) THEN
8826 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8827 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8828 C...Cuts on internal consistency in x and Q2.
8829 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8830 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8831 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8832 C...Cuts on y and theta.
8833 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8834 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8835 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8836 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8837 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8838 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8839 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8842 C...Phi angle isotropic. Reconstruct pT.
8843 PHI(I)=PARU(2)*PYR(0)
8844 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8845 & PMS(I))*SIN(THETA(I))
8847 C...Store info on variables selected, for documentation purposes.
8848 VINT(2+I)=-SQRT(Q2(I))
8852 VINT(310+I)=THETA(I)
8863 C...Cut on W combines info from two sides.
8864 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8865 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8866 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8867 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8868 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8869 IF(W2.LT.W2MIN) GOTO 120
8870 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8873 ELSEIF(MINT(141).NE.0) THEN
8874 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8877 ELSEIF(MINT(142).NE.0) THEN
8878 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8883 C...Store kinematics info for photon(s) in subsystem cm frame.
8888 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8889 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8890 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8893 VINT(298)=-VINT(293)
8894 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8895 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8897 C...Assign weight for photon flux; different for transverse and
8898 C...longitudinal photons. Flag incoming unresolved photon.
8901 IF(MINT(140+I).NE.0) THEN
8902 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8903 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8904 IF(MSTP(16).EQ.0) THEN
8907 WTGAGA=WTGAGA*X(I)/Y(I)
8910 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8911 WTGAGA=WTGAGA*(1D0-XY)
8912 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
8913 WTGAGA=WTGAGA*(1D0-XY)
8914 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
8915 WTGAGA=WTGAGA*(1D0-XY)
8917 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
8918 & PMS(I)*XY**2/Q2(I))
8920 IF(MINT(106+I).EQ.0) MINT(14+I)=22
8926 C...Update pTmin and cross section information.
8927 IF(MSTP(82).LE.1) THEN
8928 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8930 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8932 VINT(149)=4D0*PTMN**2/VINT(2)
8936 C...Reconstruct kinematics of photons inside leptons.
8937 ELSEIF(IGAGA.EQ.4) THEN
8939 C...Make place for incoming particles and scattered leptons.
8941 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
8942 MINT(4)=MINT(4)+MOVE
8943 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
8944 IF(K(I,1).EQ.21) THEN
8950 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8951 & K(I+MOVE,3)=K(I,3)+MOVE
8952 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
8953 & K(I+MOVE,4)=K(I,4)+MOVE
8954 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
8955 & K(I+MOVE,5)=K(I,5)+MOVE
8958 DO 170 I=MINT(84)+1,N
8959 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8960 & K(I,3)=K(I,3)+MOVE
8963 C...Fill in incoming particles.
8964 DO 190 I=MINT(83)+1,MINT(83)+MOVE
8973 IF(MINT(140+I).NE.0) THEN
8974 K(MINT(83)+I,2)=MINT(140+I)
8975 P(MINT(83)+I,5)=VINT(302+I)
8977 K(MINT(83)+I,2)=MINT(10+I)
8978 P(MINT(83)+I,5)=VINT(2+I)
8980 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
8981 & VINT(302))*(-1D0)**(I+1)
8982 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
8985 C...New mother-daughter relations in documentation section.
8986 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8987 K(MINT(83)+1,4)=MINT(83)+3
8988 K(MINT(83)+1,5)=MINT(83)+5
8989 K(MINT(83)+2,4)=MINT(83)+4
8990 K(MINT(83)+2,5)=MINT(83)+6
8991 K(MINT(83)+3,3)=MINT(83)+1
8992 K(MINT(83)+5,3)=MINT(83)+1
8993 K(MINT(83)+4,3)=MINT(83)+2
8994 K(MINT(83)+6,3)=MINT(83)+2
8995 ELSEIF(MINT(141).NE.0) THEN
8996 K(MINT(83)+1,4)=MINT(83)+3
8997 K(MINT(83)+1,5)=MINT(83)+4
8998 K(MINT(83)+2,4)=MINT(83)+5
8999 K(MINT(83)+3,3)=MINT(83)+1
9000 K(MINT(83)+4,3)=MINT(83)+1
9001 K(MINT(83)+5,3)=MINT(83)+2
9002 ELSEIF(MINT(142).NE.0) THEN
9003 K(MINT(83)+1,4)=MINT(83)+4
9004 K(MINT(83)+2,4)=MINT(83)+3
9005 K(MINT(83)+2,5)=MINT(83)+5
9006 K(MINT(83)+3,3)=MINT(83)+2
9007 K(MINT(83)+4,3)=MINT(83)+1
9008 K(MINT(83)+5,3)=MINT(83)+2
9011 C...Fill scattered lepton(s).
9013 IF(MINT(140+I).NE.0) THEN
9014 LSC=MINT(83)+MIN(I+2,MOVE)
9016 K(LSC,2)=MINT(140+I)
9017 P(LSC,1)=PT(I)*COS(PHI(I))
9018 P(LSC,2)=PT(I)*SIN(PHI(I))
9019 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
9020 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
9022 P(LSC,5)=VINT(302+I)
9026 C...Find incoming four-vectors to subprocess.
9028 IF(MINT(141).NE.0) THEN
9030 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
9034 P(N+1,J)=P(MINT(83)+1,J)
9038 IF(MINT(142).NE.0) THEN
9040 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
9044 P(N+2,J)=P(MINT(83)+2,J)
9048 C...Define boost and rotation between hadronic subsystem and
9049 C...collision rest frame; boost hadronic subsystem to this frame.
9051 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
9053 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
9054 BPHI=PYANGL(P(N+1,1),P(N+1,2))
9055 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
9056 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
9057 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
9060 C...Add on scattered leptons to final state.
9062 IF(MINT(140+I).NE.0) THEN
9063 LSC=MINT(83)+MIN(I+2,MOVE)
9079 C*********************************************************************
9082 C...Generates quantities characterizing the high-pT scattering at the
9083 C...parton level according to the matrix elements. Chooses incoming,
9084 C...reacting partons, their momentum fractions and one of the possible
9089 C...Double precision and integer declarations.
9090 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9091 IMPLICIT INTEGER(I-N)
9092 INTEGER PYK,PYCHGE,PYCOMP
9093 C...Parameter statement to help give large particle numbers.
9094 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
9095 &KEXCIT=4000000,KDIMEN=5000000)
9097 C...User process initialization and event commonblocks.
9099 PARAMETER (MAXPUP=100)
9100 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
9101 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
9102 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
9103 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
9106 PARAMETER (MAXNUP=500)
9107 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
9108 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
9109 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
9110 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
9111 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
9112 SAVE /HEPRUP/,/HEPEUP/
9115 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9116 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9117 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9118 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9119 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9120 COMMON/PYINT1/MINT(400),VINT(400)
9121 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9122 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9123 COMMON/PYINT4/MWID(500),WIDS(500,5)
9124 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
9125 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
9126 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
9127 COMMON/PYTCCO/COEFX(194:380,2)
9128 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
9129 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
9130 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
9133 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
9135 C...Parameters and data used in elastic/diffractive treatment.
9136 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
9137 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
9139 C...Initial values, specifically for (first) semihard interaction.
9148 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
9157 C...Start by assuming incoming photon is entering subprocess.
9158 IF(MINT(11).EQ.22) THEN
9160 VINT(307)=VINT(3)**2
9162 IF(MINT(12).EQ.22) THEN
9164 VINT(308)=VINT(4)**2
9169 C...Choice of process type - first event of pileup.
9171 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
9172 ELSEIF(MINT(82).EQ.1) THEN
9174 C...For gamma-p or gamma-gamma first pick between alternatives.
9176 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
9179 C...For real gamma + gamma with different nature, flip at random.
9180 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
9181 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
9191 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
9194 C...Pick process type, possibly by user process machinery.
9195 C...(If the latter, also event will be picked here.)
9196 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
9199 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
9204 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
9205 & ISUB.LT.500) GOTO 110
9207 RSUB=XSEC(0,1)*PYR(0)
9209 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
9212 IF(RSUB.LE.0D0) GOTO 130
9214 130 IF(ISUB.EQ.95) ISUB=96
9215 IF(ISUB.EQ.96) INMULT=1
9216 IF(ISET(ISUB).EQ.11) THEN
9223 C...Choice of inclusive process type - pileup events.
9224 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
9225 RSUB=VINT(131)*PYR(0)
9227 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
9228 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
9229 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
9230 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
9232 IF(ISUB.EQ.96) INMULT=1
9235 C...Choice of photon energy and flux factor inside lepton.
9236 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9237 CALL PYGAGA(3,WTGAGA)
9238 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
9239 CKIN(3)=MAX(VINT(285),VINT(154))
9242 C...When necessary set direct/resolved photon by hand.
9243 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
9244 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
9245 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
9248 C...Restrict direct*resolved processes to pTmin >= Q,
9249 C...to avoid doublecounting with DIS.
9250 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
9251 IF(MINT(15).EQ.22) THEN
9252 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
9254 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
9259 C...Set up for multiple interactions (may include impact parameter).
9260 IF(INMULT.EQ.1) THEN
9261 IF(MINT(35).LE.1) CALL PYMULT(2)
9262 IF(MINT(35).GE.2) CALL PYMIGN(2)
9265 C...Loopback point for minimum bias in photon physics.
9268 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
9269 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
9270 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
9271 &NGEN(97,1)=NGEN(97,1)+MINT(143)
9275 C...Random choice of flavour for some SUSY processes.
9276 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
9277 C...~e_L ~nu_e or ~mu_L ~nu_mu.
9278 IF(ISUB.EQ.210) THEN
9279 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
9280 KFPR(ISUB,2)=KFPR(ISUB,1)+1
9281 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9282 ELSEIF(ISUB.EQ.213) THEN
9283 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
9284 KFPR(ISUB,2)=KFPR(ISUB,1)
9285 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9286 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
9288 IF(ISUB.GE.258) THEN
9293 IF(MOD(ISUB,2).EQ.0) THEN
9294 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
9296 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
9298 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9299 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
9300 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
9303 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
9306 ELSEIF(PYR(0).LT.0.5D0) THEN
9313 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
9314 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
9315 C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9316 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
9317 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
9318 KFPR(ISUB,2)=KFPR(ISUB,1)
9319 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
9320 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
9321 KFPR(ISUB,2)=KFPR(ISUB,1)
9322 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9323 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
9324 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
9327 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
9330 ELSEIF(PYR(0).LT.0.5D0) THEN
9337 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
9342 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
9346 C...Random choice of flavours for some UED processes
9347 c...The production processes can generate a doublet pair,
9348 c...a singlet pair, or a doublet + singlet.
9350 C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
9351 IF(PYR(0).LE.0.1)THEN
9352 KFPR(ISUB,1)=5100001
9354 KFPR(ISUB,1)=5100002
9356 KFPR(ISUB,2)=KFPR(ISUB,1)
9357 ELSEIF(ISUB.EQ.314.OR.ISUB.EQ.315)THEN
9358 C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
9359 C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
9360 IF(PYR(0).LE.0.1)THEN
9361 KFPR(ISUB,1)=5100001
9363 KFPR(ISUB,1)=5100002
9365 KFPR(ISUB,2)=-KFPR(ISUB,1)
9366 ELSEIF(ISUB.EQ.316)THEN
9367 C...qi + qbarj -> q*_Di + q*_Sbarj
9368 IF(PYR(0).LE.0.5)THEN
9369 KFPR(ISUB,1)=5100001
9370 c Changed from private pythia6410_ued code
9371 c KFPR(ISUB,2)=-5010001
9372 KFPR(ISUB,2)=-6100002
9374 KFPR(ISUB,1)=5100002
9375 c Changed from private pythia6410_ued code
9376 c KFPR(ISUB,2)=-5010002
9377 KFPR(ISUB,2)=-6100001
9379 ELSEIF(ISUB.EQ.317)THEN
9380 C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
9381 IF(PYR(0).LE.0.5)THEN
9382 KFPR(ISUB,1)=5100001
9383 KFPR(ISUB,2)=-5100002
9385 KFPR(ISUB,1)=5100002
9386 KFPR(ISUB,2)=-5100001
9388 ELSEIF(ISUB.EQ.318)THEN
9389 C...qi + qj -> q*_Di + q*_Sj
9390 IF(PYR(0).LE.0.5)THEN
9391 KFPR(ISUB,1)=5100001
9392 KFPR(ISUB,2)=6100002
9394 KFPR(ISUB,1)=5100002
9395 KFPR(ISUB,2)=6100001
9399 C...Find resonances (explicit or implicit in cross-section).
9402 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
9404 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
9405 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
9407 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
9410 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
9412 IF(MSTP(46).EQ.5) THEN
9415 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
9419 IF(CKMX.LE.0D0) CKMX=VINT(1)
9422 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
9423 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
9426 TAUR1=PMAS(KCR1,1)**2/VINT(2)
9427 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
9435 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
9436 $(ISUB.GE.361.AND.ISUB.LE.380))
9439 IF(ISUB.EQ.141) THEN
9441 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
9442 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
9445 TAUR2=PMAS(KCR2,1)**2/VINT(2)
9446 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
9452 C...3 resonances at work: rho, omega, a
9453 ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
9454 & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
9457 VINT(73)=XMAS(1)**2/VINT(2)
9458 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
9464 VINT(75)=XMAS(2)**2/VINT(2)
9465 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
9471 VINT(77)=XMAS(3)**2/VINT(2)
9472 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
9477 C...Charged current: rho+- and a+-
9478 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
9481 VINT(73)=YMAS(1)**2/VINT(2)
9482 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
9488 VINT(75)=YMAS(2)**2/VINT(2)
9489 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
9496 IF(ISUB.NE.141) THEN
9497 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
9499 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
9501 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
9506 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
9514 ELSEIF(KFR1.NE.0) THEN
9516 ELSEIF(KFR2.NE.0) THEN
9521 ELSEIF(KFR3.NE.0) THEN
9530 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
9532 ELSEIF(KFR2.NE.0) THEN
9547 C...Find product masses and minimum pT of process,
9548 C...optionally with broadening according to a truncated Breit-Wigner.
9553 IF(MINT(82).GE.2) VINT(71)=0D0
9555 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9559 IF(KFPR(ISUB,I).EQ.0) THEN
9560 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
9562 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
9565 C...This prevents SUSY/t particles from becoming too light.
9567 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9570 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9571 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9572 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9573 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9574 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9575 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9576 PMMN(I)=MIN(PMMN(I),PMSUM)
9579 ELSEIF(KFLW.EQ.6) THEN
9580 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9587 CKIN(41)=MAX(PMMN(1),CKIN(41))
9588 CKIN(43)=MAX(PMMN(2),CKIN(43))
9589 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
9592 IF(MINT(51).EQ.1) THEN
9593 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9603 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
9604 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
9607 C...Prepare for additional variable choices in 2 -> 3.
9610 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
9612 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
9613 VINT(204)=PMAS(23,1)
9614 IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
9615 & VINT(204)=PMAS(24,1)
9616 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
9617 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
9618 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
9619 & VINT(204)=VINT(201)
9621 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
9624 C...Select incoming VDM particle (rho/omega/phi/J/psi).
9625 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
9626 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
9627 VRN=PYR(0)*SIGT(0,0,5)
9628 IF(MINT(101).LE.1) THEN
9635 IF(MINT(102).LE.1) THEN
9646 VRN=VRN-SIGT(I1,I2,5)
9647 IF(VRN.LE.0D0) GOTO 190
9650 190 IF(MINT(101).GE.2) MINT(103)=KFV1
9651 IF(MINT(102).GE.2) MINT(104)=KFV2
9655 C...Elastic scattering or single or double diffractive scattering.
9657 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9662 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
9664 VRN=PYR(0)*SIGT(0,0,JJ)
9665 IF(MINT(101).LE.1) THEN
9672 IF(MINT(102).LE.1) THEN
9683 VRN=VRN-SIGT(I1,I2,JJ)
9684 IF(VRN.LE.0D0) GOTO 220
9687 220 IF(MINT(101).GE.2) THEN
9691 IF(MINT(102).GE.2) THEN
9699 C...Select mass for GVMD states (rejecting previous assignment).
9701 Q1S=4D0*VINT(154)**2
9705 IF(MINT(106+JT).EQ.3) THEN
9707 PMM(JT)=SQRT((Q0S+PS)*(Q1S+PS)/
9708 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS)
9709 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9710 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9713 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9714 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9719 C...Side/sides of diffractive system.
9722 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9723 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9725 C...Find masses of particles and minimal masses of diffractive states.
9728 VINT(68+JT)=PDIF(JT)
9729 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9736 SMRES1=(PMM(1)+PMRC)**2
9737 SMRES2=(PMM(2)+PMRC)**2
9739 C...Find elastic slope and lower limit diffractive slope.
9740 IHA=MAX(2,IABS(MINT(103))/110)
9742 IHB=MAX(2,IABS(MINT(104))/110)
9745 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9746 ELSEIF(ISUB.EQ.92) THEN
9747 BMN=MAX(2D0,2D0*BHAD(IHB))
9748 ELSEIF(ISUB.EQ.93) THEN
9749 BMN=MAX(2D0,2D0*BHAD(IHA))
9750 ELSEIF(ISUB.EQ.94) THEN
9754 C...Determine maximum possible t range and coefficient of generation.
9755 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9756 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9757 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9758 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9759 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9760 & (SQM1*SQM4-SQM2*SQM3)/SH
9761 THL=-0.5D0*(THA+THB)
9763 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9765 C...Select diffractive mass/masses according to dm^2/m^2.
9769 IF(MINT(16+JT).EQ.0) THEN
9773 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9774 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9780 C..Additional mass factors, including resonance enhancement.
9781 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9782 IF(LOOP3.LT.100) GOTO 260
9786 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9787 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9788 ELSEIF(ISUB.EQ.93) THEN
9789 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9790 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9791 ELSEIF(ISUB.EQ.94) THEN
9792 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9793 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9794 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9795 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9798 C...Select t according to exp(Bmn*t) and correct to right slope.
9799 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9802 BADD=2D0*ALP*LOG(SH/SQM3)
9803 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9804 ELSEIF(ISUB.EQ.93) THEN
9805 BADD=2D0*ALP*LOG(SH/SQM4)
9806 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9807 ELSEIF(ISUB.EQ.94) THEN
9808 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9810 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9813 C...Check whether m^2 and t choices are consistent.
9814 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9815 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9816 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9817 IF(THB.LE.1D-8) GOTO 260
9818 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9819 & (SQM1*SQM4-SQM2*SQM3)/SH
9820 THLM=-0.5D0*(THA+THB)
9822 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9824 C...Information to output.
9827 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9829 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9832 VINT(283)=PMM(1)**2/4D0
9833 VINT(284)=PMM(2)**2/4D0
9835 C...Note: in the following, by In is meant the integral over the
9836 C...quantity multiplying coefficient cn.
9837 C...Choose tau according to h1(tau)/tau, where
9838 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9839 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9840 C...I1/I5*c5*1/(tau+tau_R') +
9841 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9842 C...I1/I7*c7*tau/(1.-tau), and
9843 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9844 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9846 IF(MINT(51).NE.0) THEN
9847 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9856 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9857 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9858 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9859 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9861 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9862 & COEF(ISUB,5)) MTAU=6
9863 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9864 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9865 C...Additional check to handle techni-processes with extra resonance
9866 C....Only modify tau treatment
9867 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
9869 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9870 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
9871 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9872 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
9873 & +COEFX(ISUB,1)) MTAU=9
9875 CALL PYKMAP(1,MTAU,PYR(0))
9877 C...2 -> 3, 4 processes:
9878 C...Choose tau' according to h4(tau,tau')/tau', where
9879 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9880 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9881 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9883 IF(MINT(51).NE.0) THEN
9884 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9893 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9894 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9895 CALL PYKMAP(4,MTAUP,PYR(0))
9898 C...Choose y* according to h2(y*), where
9899 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9900 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9901 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9902 C...and c1 + c2 + c3 + c4 + c5 = 1.
9904 IF(MINT(51).NE.0) THEN
9905 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9914 IF(RYST.GT.COEF(ISUB,8)) MYST=2
9915 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
9916 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
9917 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
9918 & COEF(ISUB,11)) MYST=5
9919 CALL PYKMAP(2,MYST,PYR(0))
9921 C...2 -> 2 processes:
9922 C...Choose cos(theta-hat) (cth) according to h3(cth), where
9923 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
9924 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
9925 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
9926 C...and c0 + c1 + c2 + c3 + c4 = 1.
9928 IF(MINT(51).NE.0) THEN
9929 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9936 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9939 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
9940 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
9941 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
9942 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
9943 & COEF(ISUB,16)) MCTH=5
9944 CALL PYKMAP(3,MCTH,PYR(0))
9947 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
9949 CALL PYKMAP(5,0,0D0)
9950 IF(MINT(51).NE.0) THEN
9951 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9960 C...DIS as f + gamma* -> f process: set dummy values.
9961 ELSEIF(ISTSB.EQ.8) THEN
9968 C...Low-pT or multiple interactions (first semihard interaction).
9969 ELSEIF(ISTSB.EQ.9) THEN
9970 IF(MINT(35).LE.1) CALL PYMULT(3)
9971 IF(MINT(35).GE.2) CALL PYMIGN(3)
9974 C...Study user-defined process: kinematics plus weight.
9975 ELSEIF(ISTSB.EQ.11) THEN
9976 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
9977 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
9982 IF(MINT(82).EQ.1) THEN
9983 NGEN(0,1)=NGEN(0,1)-1
9984 NGEN(ISUB,1)=NGEN(ISUB,1)-1
9986 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9990 C...Extract cross section event weight.
9991 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
9994 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
9996 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
9997 VINT(97)=SIGN(1D0,XWGTUP)
9999 VINT(97)=1D-9*XWGTUP
10002 C...Construct 'trivial' kinematical variables needed.
10005 VINT(41)=PUP(4,1)/EBMUP(1)
10006 VINT(42)=PUP(4,2)/EBMUP(2)
10007 IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
10008 CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
10009 & '(listing follows):')
10012 VINT(21)=VINT(41)*VINT(42)
10013 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
10014 VINT(44)=VINT(21)*VINT(2)
10015 VINT(43)=SQRT(MAX(0D0,VINT(44)))
10017 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
10018 VINT(56)=VINT(55)**2
10022 C...Construct other kinematical variables needed (approximately).
10025 VINT(45)=-0.5D0*VINT(44)
10026 VINT(46)=-0.5D0*VINT(44)
10035 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
10036 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
10038 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
10039 & '(PYRAND:) unacceptable ISTUP code for particles')
10040 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
10041 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
10042 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
10045 VINT(47)=SQRT(VINT(48))
10048 C...Choose azimuthal angle.
10050 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
10052 C...Check against user cuts on kinematics at parton level.
10054 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
10055 IF(MINT(51).NE.0) THEN
10056 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10057 IF(MFAIL.EQ.1) THEN
10063 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
10065 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
10066 & CALL PYKCUT(MCUT)
10068 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10069 IF(MFAIL.EQ.1) THEN
10077 IF(ISTSB.LE.10) THEN
10078 C... If internal process, call PYSIGH
10079 CALL PYSIGH(NCHN,SIGS)
10081 C... If external process, still have to set MI starting scale
10082 IF (MSTP(86).EQ.1) THEN
10083 C... Limit phase space by xT2 of hard interaction
10084 C... (gives undercounting of MI when ext proc != dijets)
10087 C... All accessible phase space allowed
10088 C... (gives double counting of MI when ext proc = dijets)
10089 XT2GMX = (1D0-VINT(41))*(1D0-VINT(42))
10091 VINT(62)=0.25D0*XT2GMX*VINT(2)
10092 VINT(61)=SQRT(MAX(0D0,VINT(62)))
10096 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
10098 C...Multiply cross section by lepton -> photon flux factor.
10099 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
10102 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
10104 SIGLPT=WTGAGA*SIGLPT
10107 C...Multiply cross-section by user-defined weights.
10108 IF(MSTP(173).EQ.1) THEN
10109 SIGS=PARP(173)*SIGS
10111 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
10113 SIGLPT=PARP(173)*SIGLPT
10119 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
10120 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
10121 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
10124 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
10127 C...Calculations for Monte Carlo estimate of all cross-sections.
10128 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
10129 IF(MSTP(142).LE.1) THEN
10130 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10132 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
10134 ELSEIF(MINT(82).EQ.1) THEN
10135 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10137 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
10138 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
10140 C...Multiple interactions: store results of cross-section calculation.
10141 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
10143 IF(MINT(35).LE.1) CALL PYMULT(4)
10144 IF(MINT(35).GE.2) CALL PYMIGN(4)
10147 C...Ratio of actual to maximum cross section.
10148 IF(ISTSB.NE.11) THEN
10149 VIOL=SIGSWT/XSEC(ISUB,1)
10150 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
10151 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
10152 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
10153 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
10154 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
10159 C...Check that weight not negative.
10160 IF(MSTP(123).LE.0) THEN
10161 IF(VIOL.LT.-1D-3) THEN
10162 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
10163 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10164 & VINT(22),VINT(23),VINT(26)
10168 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
10170 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
10171 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10172 & VINT(22),VINT(23),VINT(26)
10176 C...Weighting using estimate of maximum of differential cross-section.
10178 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
10179 IF(VIOL.LT.PYR(0)) THEN
10180 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10181 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
10184 ELSEIF(MFAIL.EQ.0) THEN
10185 RATND=SIGLPT/XSEC(95,1)
10187 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
10188 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
10189 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
10190 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10194 IF(VIOL.LT.PYR(0)) THEN
10197 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
10198 IF(VIOL.LT.PYR(0)) THEN
10200 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10204 RATND=SIGLPT/XSEC(95,1)
10205 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
10207 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10211 IF(VIOL.LT.PYR(0)) THEN
10212 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10217 C...Check for possible violation of estimated maximum of differential
10218 C...cross-section used in weighting.
10219 IF(MSTP(123).LE.0) THEN
10220 IF(VIOL.GT.1D0) THEN
10221 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
10222 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10223 & VINT(22),VINT(23),VINT(26)
10226 ELSEIF(MSTP(123).EQ.1) THEN
10227 IF(VIOL.GT.VINT(108)) THEN
10229 IF(VIOL.GT.1.0001D0) THEN
10231 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10232 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10233 & VINT(22),VINT(23),VINT(26)
10236 ELSEIF(VIOL.GT.VINT(108)) THEN
10238 IF(VIOL.GT.1D0) THEN
10240 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10241 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
10243 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
10244 IF(KFPR(ISUB,1).LE.9) THEN
10245 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
10246 & XMAXUP(KFPR(ISUB,1))
10247 ELSEIF(KFPR(ISUB,1).LE.99) THEN
10248 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
10249 & XMAXUP(KFPR(ISUB,1))
10251 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
10252 & XMAXUP(KFPR(ISUB,1))
10255 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
10256 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
10257 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
10258 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
10259 & XSEC(0,1)=XSEC(0,1)+XDIF
10260 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10261 & VINT(22),VINT(23),VINT(26)
10263 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
10264 ELSEIF(ISUB.LE.99) THEN
10265 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
10267 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
10274 C...Multiple interactions: choose impact parameter (if not already done).
10275 IF(MINT(39).EQ.0) VINT(148)=1D0
10276 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
10277 &MSTP(82).GE.3) THEN
10278 IF(MINT(35).LE.1) CALL PYMULT(5)
10279 IF(MINT(35).GE.2) CALL PYMIGN(5)
10280 IF(VINT(150).LT.PYR(0)) THEN
10281 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10282 IF(MFAIL.EQ.1) THEN
10289 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
10290 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
10291 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
10292 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
10294 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
10296 C...Choose flavour of reacting partons (and subprocess).
10297 IF(ISTSB.GE.11) GOTO 320
10300 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
10301 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
10302 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
10303 &PYR(0).GT.RQQBAR)) THEN
10307 MINT(2)=ISIG(ICHN,3)
10308 RSIGS=RSIGS-SIGH(ICHN)
10309 IF(RSIGS.LE.0D0) GOTO 320
10312 C...Multiple interactions: choose qqbar preferentially at small pT.
10313 ELSEIF(ISUB.EQ.96) THEN
10314 MINT(105)=MINT(103)
10315 MINT(109)=MINT(107)
10316 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
10317 MINT(105)=MINT(104)
10318 MINT(109)=MINT(108)
10319 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
10322 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
10324 C...Low-pT: choose string drawing configuration.
10330 IF(RSIGS.GT.1D0) MINT(2)=2
10331 IF(RSIGS.GT.2D0) MINT(2)=3
10334 C...Reassign QCD process. Partons before initial state radiation.
10335 320 IF(MINT(2).GT.10) THEN
10337 MINT(2)=MOD(MINT(2),10)
10339 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
10350 C...Calculate x value of photon for parton inside photon inside e.
10355 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
10356 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
10357 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
10358 IF(MSPLI.EQ.2) THEN
10362 MINT(105)=MINT(102+JT)
10363 MINT(109)=MINT(106+JT)
10364 VINT(120)=VINT(2+JT)
10366 C.... Store side in MINT(124)
10369 IF(MSTP(57).LE.1) THEN
10370 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
10372 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
10375 IF(MSTP(13).EQ.2) THEN
10376 Q2PMS=Q2HRD/PMAS(11,1)**2
10377 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
10379 330 XE=XHRD**PYR(0)
10380 XG=MIN(1D0-1D-10,XHRD/XE)
10381 IF(MSTP(57).LE.1) THEN
10382 CALL PYPDFU(22,XG,Q2HRD,XPQ)
10384 CALL PYPDFL(22,XG,Q2HRD,XPQ)
10386 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
10387 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
10388 IF(WT.LT.PYR(0)*WTMX) GOTO 330
10392 XSFX(JT,KFLS)=XPQ(KFLS)
10397 C...Pick scale where photon is resolved.
10401 IF(MINT(107).EQ.3) THEN
10402 IF(MSTP(66).EQ.1) THEN
10403 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
10404 ELSEIF(MSTP(66).EQ.2) THEN
10406 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10407 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10408 Q2INT=SQRT(Q0S*Q2EFF)
10409 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10410 ELSEIF(MSTP(66).EQ.3) THEN
10411 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
10412 ELSEIF(MSTP(66).GE.4) THEN
10413 PS=0.25D0*VINT(3)**2
10414 VINT(283)=(Q0S+PS)*(Q1S+PS)/
10415 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10419 IF(MINT(108).EQ.3) THEN
10420 IF(MSTP(66).EQ.1) THEN
10421 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
10422 ELSEIF(MSTP(66).EQ.2) THEN
10424 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10425 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10426 Q2INT=SQRT(Q0S*Q2EFF)
10427 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10428 ELSEIF(MSTP(66).EQ.3) THEN
10429 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
10430 ELSEIF(MSTP(66).GE.4) THEN
10431 PS=0.25D0*VINT(4)**2
10432 VINT(284)=(Q0S+PS)*(Q1S+PS)/
10433 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10436 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10438 C...Format statements for differential cross-section maximum violations.
10439 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
10440 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10441 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
10442 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
10443 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
10445 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
10446 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10447 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
10449 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
10450 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
10451 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
10452 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
10453 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
10454 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
10459 C*********************************************************************
10462 C...Finds outgoing flavours and event type; sets up the kinematics
10463 C...and colour flow of the hard scattering
10467 C...Double precision and integer declarations
10468 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10469 IMPLICIT INTEGER(I-N)
10470 INTEGER PYK,PYCHGE,PYCOMP
10471 C...Parameter statement to help give large particle numbers.
10472 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
10473 &KEXCIT=4000000,KDIMEN=5000000)
10474 C...Parameter statement for maximum size of showers.
10475 PARAMETER (MAXNUR=1000)
10477 C...User process event common block.
10479 PARAMETER (MAXNUP=500)
10480 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10481 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10482 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
10483 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
10484 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
10488 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
10489 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10490 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10491 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10492 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
10493 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10494 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10495 COMMON/PYINT1/MINT(400),VINT(400)
10496 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10497 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10498 COMMON/PYINT4/MWID(500),WIDS(500,5)
10499 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10500 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
10501 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
10502 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
10503 COMMON/PYPUED/IUED(0:99),RUED(0:99)
10504 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
10505 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
10507 C...Local arrays and saved variables
10508 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
10509 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
10510 INTEGER IOKFLA(6),IIFLAV
10511 C...UED related declarations:
10512 C...equivalences between ordered particles (451->475)
10513 C...and UED particle code (5 000 000 + id)
10514 DIMENSION IUEDEQ(475),MUED(2)
10515 DATA (IUEDEQ(I),I=451,475)/
10516 & 6100001,6100002,6100003,6100004,6100005,6100006,
10517 & 5100001,5100002,5100003,5100004,5100005,5100006,
10518 & 6100011,6100013,6100015,
10519 & 5100012,5100011,5100014,5100013,5100016,5100015,
10520 & 5100021,5100022,5100023,5100024/
10523 C...Read out process
10527 C...Restore information for low-pT processes
10528 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
10530 100 VINT(J)=VINTSV(J)
10533 C...Convert H' or A process into equivalent H one
10536 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
10537 &ISUB.LE.190)) THEN
10539 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
10541 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
10542 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
10543 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
10544 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
10545 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
10546 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
10547 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
10548 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
10549 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
10550 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
10551 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
10552 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
10555 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
10557 C...Convert bottomonium process into equivalent charmonium ones.
10558 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
10560 C...Choice of subprocess, number of documentation lines
10562 IF(ISUB.EQ.95) IDOC=8
10563 IF(ISET(ISUB).EQ.5) IDOC=9
10564 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
10566 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
10575 C...Reset K, P and V vectors. Store incoming particles
10576 DO 120 JT=1,MSTP(126)+100
10578 IF(I.GT.MSTU(4)) GOTO 120
10590 P(I,J)=VINT(285+5*JT+J)
10596 C...Store incoming partons in their CM-frame. Save pdf value.
10599 SHP=VINT(26)*VINT(2)
10602 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
10607 K(I,3)=MINT(83)+2+JT
10608 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
10609 P(I,4)=0.5D0*SHUSER
10610 IF(MINT(14+JT).GE.-40.AND.MINT(14+JT).LE.40) THEN
10611 VINT(38+JT)=XSFX(JT,MINT(14+JT))
10617 C...Copy incoming partons to documentation lines
10629 C...Choose new quark/lepton flavour for relevant annihilation graphs
10630 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
10631 &ISUB.EQ.314.OR.ISUB.EQ.319.OR.ISUB.EQ.316.OR.
10632 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
10634 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
10635 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
10636 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
10637 DO 190 I=1,MDCY(IGLGA,3)
10638 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
10639 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
10640 IF(RKFL.LE.0D0) GOTO 200
10643 IF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319
10644 & .OR.ISUB.EQ.316).AND.MINT(2).LE.2) THEN
10645 IF(KFLF.GE.4) GOTO 180
10646 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10647 & OR.ISUB.EQ.316).AND.MINT(2).LE.4) THEN
10650 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10651 & OR.ISUB.EQ.316) THEN
10654 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
10655 & .AND.IABS(KFLF).GE.3) THEN
10656 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
10658 FACCIB=VINT(46)**2/RTCM(41)**4
10659 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
10660 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
10663 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
10664 IF(KFLF.EQ.5) GOTO 180
10665 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10666 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
10667 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
10668 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
10672 C...Final state flavours and colour flow: default values
10679 KCS=ISIGN(1,MINT(15))
10681 IF(ISET(ISUB).EQ.11) THEN
10682 C...User-defined processes: find products
10685 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
10686 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
10687 MINT(21+IUP)=IDUP(IUP)
10688 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
10689 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
10690 ELSEIF(IDUP(IUP).EQ.0) THEN
10693 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
10697 ELSEIF(ISUB.LE.10) THEN
10699 C...f + fbar -> gamma*/Z0
10702 ELSEIF(ISUB.EQ.2) THEN
10703 C...f + fbar' -> W+/-
10704 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10705 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10706 KFRES=ISIGN(24,KCH1+KCH2)
10708 ELSEIF(ISUB.EQ.3) THEN
10709 C...f + fbar -> h0 (or H0, or A0)
10712 ELSEIF(ISUB.EQ.4) THEN
10713 C...gamma + W+/- -> W+/-
10715 ELSEIF(ISUB.EQ.5) THEN
10720 PMQ(1)=PYMASS(MINT(21))
10721 PMQ(2)=PYMASS(MINT(22))
10722 220 JT=INT(1.5D0+PYR(0))
10723 ZMIN=2D0*PMQ(JT)/SHPR
10724 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10725 & (SHPR*(SHPR-PMQ(3-JT)))
10726 ZMAX=MIN(1D0-XH,ZMAX)
10727 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10728 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10729 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
10730 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10731 IF(SQC1.LT.1D-8) GOTO 220
10733 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10734 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10735 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10736 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10737 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10738 IF(SQC1.LT.1D-8) GOTO 220
10740 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10741 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10742 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10743 PHIR=PARU(2)*PYR(0)
10745 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10746 & SQRT(1D0-CTHE(2)**2)*CPHI
10748 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10749 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10750 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10751 & PMQ(3-JT)**2/SHP))
10752 ZMIN=2D0*PMQ(3-JT)/SHPR
10753 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10754 ZMAX=MIN(1D0-XH,ZMAX)
10755 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10759 ELSEIF(ISUB.EQ.6) THEN
10760 C...Z0 + W+/- -> W+/-
10762 ELSEIF(ISUB.EQ.7) THEN
10765 ELSEIF(ISUB.EQ.8) THEN
10772 RVCKM=VINT(180+I)*PYR(0)
10775 IPM=(5-ISIGN(1,I))/2
10777 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10778 MINT(20+JT)=ISIGN(IB,I)
10779 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10780 IF(RVCKM.LE.0D0) GOTO 250
10783 IB=2*((IA+1)/2)-1+MOD(IA,2)
10784 MINT(20+JT)=ISIGN(IB,I)
10786 250 PMQ(JT)=PYMASS(MINT(20+JT))
10788 JT=INT(1.5D0+PYR(0))
10789 ZMIN=2D0*PMQ(JT)/SHPR
10790 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10791 & (SHPR*(SHPR-PMQ(3-JT)))
10792 ZMAX=MIN(1D0-XH,ZMAX)
10793 IF(ZMIN.GE.ZMAX) GOTO 230
10794 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10795 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10796 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10797 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10798 IF(SQC1.LT.1D-8) GOTO 230
10800 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10801 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10802 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10803 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10804 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10805 IF(SQC1.LT.1D-8) GOTO 230
10807 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10808 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10809 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10810 PHIR=PARU(2)*PYR(0)
10812 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10813 & SQRT(1D0-CTHE(2)**2)*CPHI
10815 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10816 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10817 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10818 & PMQ(3-JT)**2/SHP))
10819 ZMIN=2D0*PMQ(3-JT)/SHPR
10820 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10821 ZMAX=MIN(1D0-XH,ZMAX)
10822 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10826 ELSEIF(ISUB.EQ.10) THEN
10827 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10828 IF(MINT(2).EQ.1) THEN
10831 C...W exchange: need to mix flavours according to CKM matrix
10836 RVCKM=VINT(180+I)*PYR(0)
10839 IPM=(5-ISIGN(1,I))/2
10841 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10842 MINT(20+JT)=ISIGN(IB,I)
10843 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10844 IF(RVCKM.LE.0D0) GOTO 280
10847 IB=2*((IA+1)/2)-1+MOD(IA,2)
10848 MINT(20+JT)=ISIGN(IB,I)
10855 ELSEIF(ISUB.LE.20) THEN
10856 IF(ISUB.EQ.11) THEN
10857 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10859 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10861 ELSEIF(ISUB.EQ.12) THEN
10862 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10863 MINT(21)=ISIGN(KFLF,MINT(15))
10867 ELSEIF(ISUB.EQ.13) THEN
10868 C...f + fbar -> g + g; th arbitrary
10873 ELSEIF(ISUB.EQ.14) THEN
10874 C...f + fbar -> g + gamma; th arbitrary
10875 IF(PYR(0).GT.0.5D0) JS=2
10880 ELSEIF(ISUB.EQ.15) THEN
10881 C...f + fbar -> g + Z0; th arbitrary
10882 IF(PYR(0).GT.0.5D0) JS=2
10887 ELSEIF(ISUB.EQ.16) THEN
10888 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10889 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10890 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10891 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10893 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10896 ELSEIF(ISUB.EQ.17) THEN
10897 C...f + fbar -> g + h0; th arbitrary
10898 IF(PYR(0).GT.0.5D0) JS=2
10903 ELSEIF(ISUB.EQ.18) THEN
10904 C...f + fbar -> gamma + gamma; th arbitrary
10908 ELSEIF(ISUB.EQ.19) THEN
10909 C...f + fbar -> gamma + Z0; th arbitrary
10910 IF(PYR(0).GT.0.5D0) JS=2
10914 ELSEIF(ISUB.EQ.20) THEN
10915 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
10916 C...(p(fbar')-p(W+))**2
10917 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10918 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10919 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10921 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10924 ELSEIF(ISUB.LE.30) THEN
10925 IF(ISUB.EQ.21) THEN
10926 C...f + fbar -> gamma + h0; th arbitrary
10927 IF(PYR(0).GT.0.5D0) JS=2
10931 ELSEIF(ISUB.EQ.22) THEN
10932 C...f + fbar -> Z0 + Z0; th arbitrary
10936 ELSEIF(ISUB.EQ.23) THEN
10937 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10938 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10939 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10940 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10942 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10944 ELSEIF(ISUB.EQ.24) THEN
10945 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
10946 IF(PYR(0).GT.0.5D0) JS=2
10950 ELSEIF(ISUB.EQ.25) THEN
10951 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
10952 MINT(21)=-ISIGN(24,MINT(15))
10955 ELSEIF(ISUB.EQ.26) THEN
10956 C...f + fbar' -> W+/- + h0 (or H0, or A0);
10957 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10958 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10959 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10960 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10961 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
10964 ELSEIF(ISUB.EQ.27) THEN
10965 C...f + fbar -> h0 + h0
10967 ELSEIF(ISUB.EQ.28) THEN
10968 C...f + g -> f + g; th = (p(f)-p(f))**2
10969 IF(MINT(15).EQ.21) JS=2
10971 IF(MINT(15).EQ.21) KCC=KCC+2
10972 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10973 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10975 ELSEIF(ISUB.EQ.29) THEN
10976 C...f + g -> f + gamma; th = (p(f)-p(f))**2
10977 IF(MINT(15).EQ.21) JS=2
10980 KCS=ISIGN(1,MINT(14+JS))
10982 ELSEIF(ISUB.EQ.30) THEN
10983 C...f + g -> f + Z0; th = (p(f)-p(f))**2
10984 IF(MINT(15).EQ.21) JS=2
10987 KCS=ISIGN(1,MINT(14+JS))
10990 ELSEIF(ISUB.LE.40) THEN
10991 IF(ISUB.EQ.31) THEN
10992 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
10993 IF(MINT(15).EQ.21) JS=2
10996 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10997 RVCKM=VINT(180+I)*PYR(0)
11000 IPM=(5-ISIGN(1,I))/2
11002 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
11003 MINT(20+JS)=ISIGN(IB,I)
11004 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11005 IF(RVCKM.LE.0D0) GOTO 300
11008 KCS=ISIGN(1,MINT(14+JS))
11010 ELSEIF(ISUB.EQ.32) THEN
11011 C...f + g -> f + h0; th = (p(f)-p(f))**2
11012 IF(MINT(15).EQ.21) JS=2
11015 KCS=ISIGN(1,MINT(14+JS))
11017 ELSEIF(ISUB.EQ.33) THEN
11018 C...f + gamma -> f + g; th=(p(f)-p(f))**2
11019 IF(MINT(15).EQ.22) JS=2
11022 KCS=ISIGN(1,MINT(14+JS))
11024 ELSEIF(ISUB.EQ.34) THEN
11025 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
11026 IF(MINT(15).EQ.22) JS=2
11028 KCS=ISIGN(1,MINT(14+JS))
11030 ELSEIF(ISUB.EQ.35) THEN
11031 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
11032 IF(MINT(15).EQ.22) JS=2
11036 ELSEIF(ISUB.EQ.36) THEN
11037 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
11038 IF(MINT(15).EQ.22) JS=2
11041 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11043 RVCKM=VINT(180+I)*PYR(0)
11046 IPM=(5-ISIGN(1,I))/2
11048 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
11049 MINT(20+JS)=ISIGN(IB,I)
11050 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11051 IF(RVCKM.LE.0D0) GOTO 320
11054 IB=2*((IA+1)/2)-1+MOD(IA,2)
11055 MINT(20+JS)=ISIGN(IB,I)
11059 ELSEIF(ISUB.EQ.37) THEN
11060 C...f + gamma -> f + h0
11062 ELSEIF(ISUB.EQ.38) THEN
11063 C...f + Z0 -> f + g
11065 ELSEIF(ISUB.EQ.39) THEN
11066 C...f + Z0 -> f + gamma
11068 ELSEIF(ISUB.EQ.40) THEN
11069 C...f + Z0 -> f + Z0
11072 ELSEIF(ISUB.LE.50) THEN
11073 IF(ISUB.EQ.41) THEN
11074 C...f + Z0 -> f' + W+/-
11076 ELSEIF(ISUB.EQ.42) THEN
11077 C...f + Z0 -> f + h0
11079 ELSEIF(ISUB.EQ.43) THEN
11080 C...f + W+/- -> f' + g
11082 ELSEIF(ISUB.EQ.44) THEN
11083 C...f + W+/- -> f' + gamma
11085 ELSEIF(ISUB.EQ.45) THEN
11086 C...f + W+/- -> f' + Z0
11088 ELSEIF(ISUB.EQ.46) THEN
11089 C...f + W+/- -> f' + W+/-
11091 ELSEIF(ISUB.EQ.47) THEN
11092 C...f + W+/- -> f' + h0
11094 ELSEIF(ISUB.EQ.48) THEN
11095 C...f + h0 -> f + g
11097 ELSEIF(ISUB.EQ.49) THEN
11098 C...f + h0 -> f + gamma
11100 ELSEIF(ISUB.EQ.50) THEN
11101 C...f + h0 -> f + Z0
11104 ELSEIF(ISUB.LE.60) THEN
11105 IF(ISUB.EQ.51) THEN
11106 C...f + h0 -> f' + W+/-
11108 ELSEIF(ISUB.EQ.52) THEN
11109 C...f + h0 -> f + h0
11111 ELSEIF(ISUB.EQ.53) THEN
11112 C...g + g -> f + fbar; th arbitrary
11113 KCS=(-1)**INT(1.5D0+PYR(0))
11114 MINT(21)=ISIGN(KFLF,KCS)
11118 ELSEIF(ISUB.EQ.54) THEN
11119 C...g + gamma -> f + fbar; th arbitrary
11120 KCS=(-1)**INT(1.5D0+PYR(0))
11121 MINT(21)=ISIGN(KFLF,KCS)
11124 IF(MINT(16).EQ.21) KCC=28
11126 ELSEIF(ISUB.EQ.55) THEN
11127 C...g + Z0 -> f + fbar
11129 ELSEIF(ISUB.EQ.56) THEN
11130 C...g + W+/- -> f + fbar'
11132 ELSEIF(ISUB.EQ.57) THEN
11133 C...g + h0 -> f + fbar
11135 ELSEIF(ISUB.EQ.58) THEN
11136 C...gamma + gamma -> f + fbar; th arbitrary
11137 KCS=(-1)**INT(1.5D0+PYR(0))
11138 MINT(21)=ISIGN(KFLF,KCS)
11142 ELSEIF(ISUB.EQ.59) THEN
11143 C...gamma + Z0 -> f + fbar
11145 ELSEIF(ISUB.EQ.60) THEN
11146 C...gamma + W+/- -> f + fbar'
11149 ELSEIF(ISUB.LE.70) THEN
11150 IF(ISUB.EQ.61) THEN
11151 C...gamma + h0 -> f + fbar
11153 ELSEIF(ISUB.EQ.62) THEN
11154 C...Z0 + Z0 -> f + fbar
11156 ELSEIF(ISUB.EQ.63) THEN
11157 C...Z0 + W+/- -> f + fbar'
11159 ELSEIF(ISUB.EQ.64) THEN
11160 C...Z0 + h0 -> f + fbar
11162 ELSEIF(ISUB.EQ.65) THEN
11163 C...W+ + W- -> f + fbar
11165 ELSEIF(ISUB.EQ.66) THEN
11166 C...W+/- + h0 -> f + fbar'
11168 ELSEIF(ISUB.EQ.67) THEN
11169 C...h0 + h0 -> f + fbar
11171 ELSEIF(ISUB.EQ.68) THEN
11172 C...g + g -> g + g; th arbitrary
11174 KCS=(-1)**INT(1.5D0+PYR(0))
11176 ELSEIF(ISUB.EQ.69) THEN
11177 C...gamma + gamma -> W+ + W-; th arbitrary
11182 ELSEIF(ISUB.EQ.70) THEN
11183 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
11184 IF(MINT(15).EQ.22) MINT(21)=23
11185 IF(MINT(16).EQ.22) MINT(22)=23
11189 ELSEIF(ISUB.LE.80) THEN
11190 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
11191 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
11195 PMQ(1)=PYMASS(MINT(21))
11196 PMQ(2)=PYMASS(MINT(22))
11197 330 JT=INT(1.5D0+PYR(0))
11198 ZMIN=2D0*PMQ(JT)/SHPR
11199 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11200 & (SHPR*(SHPR-PMQ(3-JT)))
11201 ZMAX=MIN(1D0-XH,ZMAX)
11202 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11203 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11204 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
11205 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11206 IF(SQC1.LT.1D-8) GOTO 330
11208 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11209 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11210 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11211 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11212 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11213 IF(SQC1.LT.1D-8) GOTO 330
11215 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11216 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11217 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11218 PHIR=PARU(2)*PYR(0)
11220 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11221 & SQRT(1D0-CTHE(2)**2)*CPHI
11223 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11224 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11225 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11226 & PMQ(3-JT)**2/SHP))
11227 ZMIN=2D0*PMQ(3-JT)/SHPR
11228 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11229 ZMAX=MIN(1D0-XH,ZMAX)
11230 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
11233 ELSEIF(ISUB.EQ.73) THEN
11234 C...Z0 + W+/- -> Z0 + W+/-
11241 RVCKM=VINT(180+I)*PYR(0)
11244 IPM=(5-ISIGN(1,I))/2
11246 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
11247 MINT(20+JT)=ISIGN(IB,I)
11248 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11249 IF(RVCKM.LE.0D0) GOTO 360
11252 IB=2*((IA+1)/2)-1+MOD(IA,2)
11253 MINT(20+JT)=ISIGN(IB,I)
11255 360 PMQ(JT)=PYMASS(MINT(20+JT))
11256 MINT(23-JT)=MINT(17-JT)
11257 PMQ(3-JT)=PYMASS(MINT(23-JT))
11258 JT=INT(1.5D0+PYR(0))
11259 ZMIN=2D0*PMQ(JT)/SHPR
11260 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11261 & (SHPR*(SHPR-PMQ(3-JT)))
11262 ZMAX=MIN(1D0-XH,ZMAX)
11263 IF(ZMIN.GE.ZMAX) GOTO 340
11264 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11265 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11266 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
11267 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11268 IF(SQC1.LT.1D-8) GOTO 340
11270 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11271 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11272 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11273 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11274 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11275 IF(SQC1.LT.1D-8) GOTO 340
11277 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11278 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11279 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11280 PHIR=PARU(2)*PYR(0)
11282 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11283 & SQRT(1D0-CTHE(2)**2)*CPHI
11285 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11286 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11287 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11288 & PMQ(3-JT)**2/SHP))
11289 ZMIN=2D0*PMQ(3-JT)/SHPR
11290 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11291 ZMAX=MIN(1D0-XH,ZMAX)
11292 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
11295 ELSEIF(ISUB.EQ.74) THEN
11296 C...Z0 + h0 -> Z0 + h0
11298 ELSEIF(ISUB.EQ.75) THEN
11299 C...W+ + W- -> gamma + gamma
11301 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
11302 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
11308 RVCKM=VINT(180+I)*PYR(0)
11311 IPM=(5-ISIGN(1,I))/2
11313 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
11314 MINT(20+JT)=ISIGN(IB,I)
11315 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11316 IF(RVCKM.LE.0D0) GOTO 390
11319 IB=2*((IA+1)/2)-1+MOD(IA,2)
11320 MINT(20+JT)=ISIGN(IB,I)
11322 390 PMQ(JT)=PYMASS(MINT(20+JT))
11324 JT=INT(1.5D0+PYR(0))
11325 ZMIN=2D0*PMQ(JT)/SHPR
11326 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11327 & (SHPR*(SHPR-PMQ(3-JT)))
11328 ZMAX=MIN(1D0-XH,ZMAX)
11329 IF(ZMIN.GE.ZMAX) GOTO 370
11330 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11331 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11332 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
11333 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11334 IF(SQC1.LT.1D-8) GOTO 370
11336 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11337 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11338 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11339 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11340 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11341 IF(SQC1.LT.1D-8) GOTO 370
11343 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11344 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11345 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11346 PHIR=PARU(2)*PYR(0)
11348 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11349 & SQRT(1D0-CTHE(2)**2)*CPHI
11351 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11352 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11353 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11354 & PMQ(3-JT)**2/SHP))
11355 ZMIN=2D0*PMQ(3-JT)/SHPR
11356 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11357 ZMAX=MIN(1D0-XH,ZMAX)
11358 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
11361 ELSEIF(ISUB.EQ.78) THEN
11362 C...W+/- + h0 -> W+/- + h0
11364 ELSEIF(ISUB.EQ.79) THEN
11365 C...h0 + h0 -> h0 + h0
11367 ELSEIF(ISUB.EQ.80) THEN
11368 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11369 IF(MINT(15).EQ.22) JS=2
11372 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
11374 MINT(20+JS)=ISIGN(IB,I)
11378 ELSEIF(ISUB.LE.90) THEN
11379 IF(ISUB.EQ.81) THEN
11380 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11381 MINT(21)=ISIGN(MINT(55),MINT(15))
11385 ELSEIF(ISUB.EQ.82) THEN
11386 C...g + g -> Q + Qbar; th arbitrary
11387 KCS=(-1)**INT(1.5D0+PYR(0))
11388 MINT(21)=ISIGN(MINT(55),KCS)
11392 ELSEIF(ISUB.EQ.83) THEN
11393 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11395 IF(MINT(2).EQ.2) KFOLD=MINT(15)
11397 IF(KFAOLD.GT.10) THEN
11398 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
11400 RCKM=VINT(180+KFOLD)*PYR(0)
11401 IPM=(5-ISIGN(1,KFOLD))/2
11402 KFANEW=-MOD(KFAOLD+1,2)
11403 410 KFANEW=KFANEW+2
11404 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
11405 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
11406 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
11407 & VCKM(KFAOLD/2,(KFANEW+1)/2)
11408 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
11409 & VCKM(KFANEW/2,(KFAOLD+1)/2)
11411 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
11413 IF(MINT(2).EQ.1) THEN
11414 MINT(21)=ISIGN(MINT(55),MINT(15))
11415 MINT(22)=ISIGN(KFANEW,MINT(16))
11417 MINT(21)=ISIGN(KFANEW,MINT(15))
11418 MINT(22)=ISIGN(MINT(55),MINT(16))
11423 ELSEIF(ISUB.EQ.84) THEN
11424 C...g + gamma -> Q + Qbar; th arbitary
11425 KCS=(-1)**INT(1.5D0+PYR(0))
11426 MINT(21)=ISIGN(MINT(55),KCS)
11429 IF(MINT(16).EQ.21) KCC=28
11431 ELSEIF(ISUB.EQ.85) THEN
11432 C...gamma + gamma -> F + Fbar; th arbitary
11433 KCS=(-1)**INT(1.5D0+PYR(0))
11434 MINT(21)=ISIGN(MINT(56),KCS)
11438 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
11439 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11440 MINT(21)=KFPR(ISUB,1)
11441 MINT(22)=KFPR(ISUB,2)
11443 KCS=(-1)**INT(1.5D0+PYR(0))
11446 ELSEIF(ISUB.LE.100) THEN
11447 IF(ISUB.EQ.95) THEN
11448 C...Low-pT ( = energyless g + g -> g + g)
11450 KCS=(-1)**INT(1.5D0+PYR(0))
11452 ELSEIF(ISUB.EQ.96) THEN
11453 C...Multiple interactions (should be reassigned to QCD process)
11456 ELSEIF(ISUB.LE.110) THEN
11457 IF(ISUB.EQ.101) THEN
11458 C...g + g -> gamma*/Z0
11462 ELSEIF(ISUB.EQ.102) THEN
11463 C...g + g -> h0 (or H0, or A0)
11467 ELSEIF(ISUB.EQ.103) THEN
11468 C...gamma + gamma -> h0 (or H0, or A0)
11472 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
11473 C...g + g -> chi_0c or chi_2c.
11477 ELSEIF(ISUB.EQ.106) THEN
11478 C...g + g -> J/Psi + gamma
11479 MINT(21)=KFPR(ISUB,1)
11480 MINT(22)=KFPR(ISUB,2)
11483 ELSEIF(ISUB.EQ.107) THEN
11484 C...g + gamma -> J/Psi + g
11485 MINT(21)=KFPR(ISUB,1)
11486 MINT(22)=KFPR(ISUB,2)
11488 IF(MINT(16).EQ.22) KCC=33
11490 ELSEIF(ISUB.EQ.108) THEN
11491 C...gamma + gamma -> J/Psi + gamma
11492 MINT(21)=KFPR(ISUB,1)
11493 MINT(22)=KFPR(ISUB,2)
11495 ELSEIF(ISUB.EQ.110) THEN
11496 C...f + fbar -> gamma + h0; th arbitrary
11497 IF(PYR(0).GT.0.5D0) JS=2
11502 ELSEIF(ISUB.LE.120) THEN
11503 IF(ISUB.EQ.111) THEN
11504 C...f + fbar -> g + h0; th arbitrary
11505 IF(PYR(0).GT.0.5D0) JS=2
11510 ELSEIF(ISUB.EQ.112) THEN
11511 C...f + g -> f + h0; th = (p(f) - p(f))**2
11512 IF(MINT(15).EQ.21) JS=2
11515 KCS=ISIGN(1,MINT(14+JS))
11517 ELSEIF(ISUB.EQ.113) THEN
11518 C...g + g -> g + h0; th arbitrary
11519 IF(PYR(0).GT.0.5D0) JS=2
11522 KCS=(-1)**INT(1.5D0+PYR(0))
11524 ELSEIF(ISUB.EQ.114) THEN
11525 C...g + g -> gamma + gamma; th arbitrary
11526 IF(PYR(0).GT.0.5D0) JS=2
11531 ELSEIF(ISUB.EQ.115) THEN
11532 C...g + g -> g + gamma; th arbitrary
11533 IF(PYR(0).GT.0.5D0) JS=2
11536 KCS=(-1)**INT(1.5D0+PYR(0))
11538 ELSEIF(ISUB.EQ.116) THEN
11539 C...g + g -> gamma + Z0
11541 ELSEIF(ISUB.EQ.117) THEN
11542 C...g + g -> Z0 + Z0
11544 ELSEIF(ISUB.EQ.118) THEN
11545 C...g + g -> W+ + W-
11548 ELSEIF(ISUB.LE.140) THEN
11549 IF(ISUB.EQ.121) THEN
11550 C...g + g -> Q + Qbar + h0
11551 KCS=(-1)**INT(1.5D0+PYR(0))
11552 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11554 KCC=11+INT(0.5D0+PYR(0))
11557 ELSEIF(ISUB.EQ.122) THEN
11558 C...q + qbar -> Q + Qbar + h0
11559 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
11564 ELSEIF(ISUB.EQ.123) THEN
11565 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11570 ELSEIF(ISUB.EQ.124) THEN
11571 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11577 RVCKM=VINT(180+I)*PYR(0)
11580 IPM=(5-ISIGN(1,I))/2
11582 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
11583 MINT(20+JT)=ISIGN(IB,I)
11584 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11585 IF(RVCKM.LE.0D0) GOTO 430
11588 IB=2*((IA+1)/2)-1+MOD(IA,2)
11589 MINT(20+JT)=ISIGN(IB,I)
11595 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
11596 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11597 IF(MINT(15).EQ.22) JS=2
11600 KCS=ISIGN(1,MINT(14+JS))
11602 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
11603 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11604 IF(MINT(15).EQ.22) JS=2
11606 KCS=ISIGN(1,MINT(14+JS))
11608 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
11609 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11610 KCS=(-1)**INT(1.5D0+PYR(0))
11611 MINT(21)=ISIGN(KFLF,KCS)
11614 IF(MINT(16).EQ.21) KCC=28
11616 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
11617 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11618 KCS=(-1)**INT(1.5D0+PYR(0))
11619 MINT(21)=ISIGN(KFLF,KCS)
11625 ELSEIF(ISUB.LE.160) THEN
11626 IF(ISUB.EQ.141) THEN
11627 C...f + fbar -> gamma*/Z0/Z'0
11630 ELSEIF(ISUB.EQ.142) THEN
11631 C...f + fbar' -> W'+/-
11632 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11633 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11634 KFRES=ISIGN(34,KCH1+KCH2)
11636 ELSEIF(ISUB.EQ.143) THEN
11637 C...f + fbar' -> H+/-
11638 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11639 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11640 KFRES=ISIGN(37,KCH1+KCH2)
11642 ELSEIF(ISUB.EQ.144) THEN
11644 KFRES=ISIGN(41,MINT(15)+MINT(16))
11646 ELSEIF(ISUB.EQ.145) THEN
11647 C...q + l -> LQ (leptoquark)
11648 IF(IABS(MINT(16)).LE.8) JS=2
11649 KFRES=ISIGN(42,MINT(14+JS))
11651 KCS=ISIGN(1,MINT(14+JS))
11653 ELSEIF(ISUB.EQ.146) THEN
11654 C...e + gamma -> e* (excited lepton)
11655 IF(MINT(15).EQ.22) JS=2
11656 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11659 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
11660 C...q + g -> q* (excited quark)
11661 IF(MINT(15).EQ.21) JS=2
11662 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11664 KCS=ISIGN(1,MINT(14+JS))
11666 ELSEIF(ISUB.EQ.149) THEN
11667 C...g + g -> eta_tc
11670 KCS=(-1)**INT(1.5D0+PYR(0))
11673 ELSEIF(ISUB.LE.200) THEN
11674 IF(ISUB.EQ.161) THEN
11675 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11676 IF(MINT(15).EQ.21) JS=2
11679 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
11680 IB=IA+MOD(IA,2)-MOD(IA+1,2)
11681 MINT(20+JS)=ISIGN(IB,I)
11683 KCS=ISIGN(1,MINT(14+JS))
11685 ELSEIF(ISUB.EQ.162) THEN
11686 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11687 IF(MINT(15).EQ.21) JS=2
11688 MINT(20+JS)=ISIGN(42,MINT(14+JS))
11689 KFLQL=KFDP(MDCY(42,2),2)
11690 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
11692 KCS=ISIGN(1,MINT(14+JS))
11694 ELSEIF(ISUB.EQ.163) THEN
11695 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11696 KCS=(-1)**INT(1.5D0+PYR(0))
11697 MINT(21)=ISIGN(42,KCS)
11701 ELSEIF(ISUB.EQ.164) THEN
11702 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11703 MINT(21)=ISIGN(42,MINT(15))
11707 ELSEIF(ISUB.EQ.165) THEN
11708 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11709 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11712 ELSEIF(ISUB.EQ.166) THEN
11713 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11714 IF(MOD(MINT(15),2).EQ.0) THEN
11715 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11716 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11718 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11719 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11722 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
11723 C...q + q' -> q" + q* (excited quark)
11724 KFQSTR=KFPR(ISUB,2)
11725 KFQEXC=MOD(KFQSTR,KEXCIT)
11727 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11728 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
11729 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11733 ELSEIF(ISUB.EQ.169) THEN
11734 C...q + qbar -> e + e* (excited lepton)
11735 KFQSTR=KFPR(ISUB,2)
11736 KFQEXC=MOD(KFQSTR,KEXCIT)
11738 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11739 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11742 ELSEIF(ISUB.EQ.191) THEN
11743 C...f + fbar -> rho_tc0.
11746 ELSEIF(ISUB.EQ.192) THEN
11747 C...f + fbar' -> rho_tc+/-
11748 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11749 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11750 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11752 ELSEIF(ISUB.EQ.193) THEN
11753 C...f + fbar -> omega_tc0.
11756 ELSEIF(ISUB.EQ.194) THEN
11757 C...f + fbar -> f' + fbar' via mixture of s-channel
11758 C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11759 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11762 ELSEIF(ISUB.EQ.195) THEN
11763 C...f + fbar' -> f'' + fbar''' via s-channel
11764 C...rho_tc+ th=(p(f)-p(f'))**2
11765 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11766 IF(MOD(MINT(15),2).EQ.0) THEN
11767 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11768 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11770 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11771 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11776 ELSEIF(ISUB.LE.215) THEN
11777 IF(ISUB.EQ.201) THEN
11778 C...f + fbar -> ~e_L + ~e_Lbar
11779 MINT(21)=ISIGN(KSUSY1+11,KCS)
11782 ELSEIF(ISUB.EQ.202) THEN
11783 C...f + fbar -> ~e_R + ~e_Rbar
11784 MINT(21)=ISIGN(KSUSY2+11,KCS)
11787 ELSEIF(ISUB.EQ.203) THEN
11788 C...f + fbar -> ~e_L + ~e_Rbar
11789 IF(MINT(15).LT.0) JS=2
11790 IF(MINT(2).EQ.1) THEN
11791 MINT(20+JS)=KFPR(ISUB,1)
11792 MINT(23-JS)=-KFPR(ISUB,2)
11794 MINT(20+JS)=-KFPR(ISUB,1)
11795 MINT(23-JS)=KFPR(ISUB,2)
11798 ELSEIF(ISUB.EQ.204) THEN
11799 C...f + fbar -> ~mu_L + ~mu_Lbar
11800 MINT(21)=ISIGN(KSUSY1+13,KCS)
11803 ELSEIF(ISUB.EQ.205) THEN
11804 C...f + fbar -> ~mu_R + ~mu_Rbar
11805 MINT(21)=ISIGN(KSUSY2+13,KCS)
11808 ELSEIF(ISUB.EQ.206) THEN
11809 C...f + fbar -> ~mu_L + ~mu_Rbar
11810 IF(MINT(15).LT.0) JS=2
11811 IF(MINT(2).EQ.1) THEN
11812 MINT(20+JS)=KFPR(ISUB,1)
11813 MINT(23-JS)=-KFPR(ISUB,2)
11815 MINT(20+JS)=-KFPR(ISUB,1)
11816 MINT(23-JS)=KFPR(ISUB,2)
11819 ELSEIF(ISUB.EQ.207) THEN
11820 C...f + fbar -> ~tau_1 + ~tau_1bar
11821 MINT(21)=ISIGN(KSUSY1+15,KCS)
11824 ELSEIF(ISUB.EQ.208) THEN
11825 C...f + fbar -> ~tau_2 + ~tau_2bar
11826 MINT(21)=ISIGN(KSUSY2+15,KCS)
11829 ELSEIF(ISUB.EQ.209) THEN
11830 C...f + fbar -> ~tau_1 + ~tau_2bar
11831 IF(MINT(15).LT.0) JS=2
11832 IF(MINT(2).EQ.1) THEN
11833 MINT(20+JS)=KFPR(ISUB,1)
11834 MINT(23-JS)=-KFPR(ISUB,2)
11836 MINT(20+JS)=-KFPR(ISUB,1)
11837 MINT(23-JS)=KFPR(ISUB,2)
11840 ELSEIF(ISUB.EQ.210) THEN
11841 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11842 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11843 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11844 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11845 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11847 ELSEIF(ISUB.EQ.211) THEN
11848 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11849 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11850 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11851 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11852 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11854 ELSEIF(ISUB.EQ.212) THEN
11855 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11856 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11857 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11858 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11859 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11861 ELSEIF(ISUB.EQ.213) THEN
11862 C...f + fbar -> ~nul + ~nulbar
11863 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11866 ELSEIF(ISUB.EQ.214) THEN
11867 C...f + fbar -> ~nutau + ~nutaubar
11868 MINT(21)=ISIGN(KSUSY1+16,KCS)
11872 ELSEIF(ISUB.LE.225) THEN
11873 IF(ISUB.EQ.216) THEN
11874 C...f + fbar -> ~chi01 + ~chi01
11878 ELSEIF(ISUB.EQ.217) THEN
11879 C...f + fbar -> ~chi02 + ~chi02
11883 ELSEIF(ISUB.EQ.218 ) THEN
11884 C...f + fbar -> ~chi03 + ~chi03
11888 ELSEIF(ISUB.EQ.219 ) THEN
11889 C...f + fbar -> ~chi04 + ~chi04
11893 ELSEIF(ISUB.EQ.220 ) THEN
11894 C...f + fbar -> ~chi01 + ~chi02
11895 IF(MINT(15).LT.0) JS=2
11896 C IF(PYR(0).GT.0.5D0) JS=2
11897 MINT(20+JS)=KSUSY1+22
11898 MINT(23-JS)=KSUSY1+23
11900 ELSEIF(ISUB.EQ.221 ) THEN
11901 C...f + fbar -> ~chi01 + ~chi03
11902 IF(MINT(15).LT.0) JS=2
11903 C IF(PYR(0).GT.0.5D0) JS=2
11904 MINT(20+JS)=KSUSY1+22
11905 MINT(23-JS)=KSUSY1+25
11907 ELSEIF(ISUB.EQ.222) THEN
11908 C...f + fbar -> ~chi01 + ~chi04
11909 IF(MINT(15).LT.0) JS=2
11910 C IF(PYR(0).GT.0.5D0) JS=2
11911 MINT(20+JS)=KSUSY1+22
11912 MINT(23-JS)=KSUSY1+35
11914 ELSEIF(ISUB.EQ.223) THEN
11915 C...f + fbar -> ~chi02 + ~chi03
11916 IF(MINT(15).LT.0) JS=2
11917 C IF(PYR(0).GT.0.5D0) JS=2
11918 MINT(20+JS)=KSUSY1+23
11919 MINT(23-JS)=KSUSY1+25
11921 ELSEIF(ISUB.EQ.224) THEN
11922 C...f + fbar -> ~chi02 + ~chi04
11923 IF(MINT(15).LT.0) JS=2
11924 C IF(PYR(0).GT.0.5D0) JS=2
11925 MINT(20+JS)=KSUSY1+23
11926 MINT(23-JS)=KSUSY1+35
11928 ELSEIF(ISUB.EQ.225) THEN
11929 C...f + fbar -> ~chi03 + ~chi04
11930 IF(MINT(15).LT.0) JS=2
11931 C IF(PYR(0).GT.0.5D0) JS=2
11932 MINT(20+JS)=KSUSY1+25
11933 MINT(23-JS)=KSUSY1+35
11936 ELSEIF(ISUB.LE.236) THEN
11937 IF(ISUB.EQ.226) THEN
11938 C...f + fbar -> ~chi+-1 + ~chi-+1
11939 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
11940 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11941 MINT(21)=ISIGN(KSUSY1+24,KCH1)
11944 ELSEIF(ISUB.EQ.227) THEN
11945 C...f + fbar -> ~chi+-2 + ~chi-+2
11946 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11947 MINT(21)=ISIGN(KSUSY1+37,KCH1)
11950 ELSEIF(ISUB.EQ.228) THEN
11951 C...f + fbar -> ~chi+-1 + ~chi-+2
11952 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
11953 C...js=1 if pyr<.5, js=2 if pyr>.5
11954 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
11955 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
11956 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
11957 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
11958 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11960 IF(MINT(2).EQ.1) THEN
11961 MINT(21)= ISIGN(KSUSY1+24,KCH1)
11962 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
11963 c IF(KCH2.EQ.0) JS=2
11965 MINT(21)= ISIGN(KSUSY1+37,KCH1)
11966 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
11968 c IF(KCH2.EQ.1) JS=2
11971 ELSEIF(ISUB.EQ.229) THEN
11972 C...q + qbar' -> ~chi01 + ~chi+-1
11973 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
11974 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11975 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11977 IF(MOD(MINT(15),2).EQ.0) JS=2
11978 MINT(20+JS)=KSUSY1+22
11979 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11981 ELSEIF(ISUB.EQ.230) THEN
11982 C...q + qbar' -> ~chi02 + ~chi+-1
11983 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11984 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11985 IF(MOD(MINT(15),2).EQ.0) JS=2
11986 MINT(20+JS)=KSUSY1+23
11987 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11989 ELSEIF(ISUB.EQ.231) THEN
11990 C...q + qbar' -> ~chi03 + ~chi+-1
11991 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11992 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11993 IF(MOD(MINT(15),2).EQ.0) JS=2
11994 MINT(20+JS)=KSUSY1+25
11995 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11997 ELSEIF(ISUB.EQ.232) THEN
11998 C...q + qbar' -> ~chi04 + ~chi+-1
11999 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12000 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12001 IF(MOD(MINT(15),2).EQ.0) JS=2
12002 MINT(20+JS)=KSUSY1+35
12003 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12005 ELSEIF(ISUB.EQ.233) THEN
12006 C...q + qbar' -> ~chi01 + ~chi+-2
12007 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12008 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12009 IF(MOD(MINT(15),2).EQ.0) JS=2
12010 MINT(20+JS)=KSUSY1+22
12011 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12013 ELSEIF(ISUB.EQ.234) THEN
12014 C...q + qbar' -> ~chi02 + ~chi+-2
12015 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12016 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12017 IF(MOD(MINT(15),2).EQ.0) JS=2
12018 MINT(20+JS)=KSUSY1+23
12019 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12021 ELSEIF(ISUB.EQ.235) THEN
12022 C...q + qbar' -> ~chi03 + ~chi+-2
12023 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12024 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12025 IF(MOD(MINT(15),2).EQ.0) JS=2
12026 MINT(20+JS)=KSUSY1+25
12027 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12029 ELSEIF(ISUB.EQ.236) THEN
12030 C...q + qbar' -> ~chi04 + ~chi+-2
12031 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12032 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12033 IF(MOD(MINT(15),2).EQ.0) JS=2
12034 MINT(20+JS)=KSUSY1+35
12035 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12038 ELSEIF(ISUB.LE.245) THEN
12039 IF(ISUB.EQ.237) THEN
12040 C...q + qbar -> ~chi01 + ~g
12042 IF(PYR(0).GT.0.5D0) JS=2
12043 MINT(20+JS)=KSUSY1+21
12044 MINT(23-JS)=KSUSY1+22
12047 ELSEIF(ISUB.EQ.238) THEN
12048 C...q + qbar -> ~chi02 + ~g
12050 IF(PYR(0).GT.0.5D0) JS=2
12051 MINT(20+JS)=KSUSY1+21
12052 MINT(23-JS)=KSUSY1+23
12055 ELSEIF(ISUB.EQ.239) THEN
12056 C...q + qbar -> ~chi03 + ~g
12058 IF(PYR(0).GT.0.5D0) JS=2
12059 MINT(20+JS)=KSUSY1+21
12060 MINT(23-JS)=KSUSY1+25
12063 ELSEIF(ISUB.EQ.240) THEN
12064 C...q + qbar -> ~chi04 + ~g
12066 IF(PYR(0).GT.0.5D0) JS=2
12067 MINT(20+JS)=KSUSY1+21
12068 MINT(23-JS)=KSUSY1+35
12071 ELSEIF(ISUB.EQ.241) THEN
12072 C...q + qbar' -> ~chi+-1 + ~g
12073 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12074 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12075 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12076 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12077 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12078 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12079 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12081 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12082 MINT(20+JS)=KSUSY1+21
12083 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12086 ELSEIF(ISUB.EQ.242) THEN
12087 C...q + qbar' -> ~chi+-2 + ~g
12088 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12089 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12090 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12091 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12092 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12093 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12094 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12096 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12097 MINT(20+JS)=KSUSY1+21
12098 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12101 ELSEIF(ISUB.EQ.243) THEN
12102 C...q + qbar -> ~g + ~g ; th arbitrary
12107 ELSEIF(ISUB.EQ.244) THEN
12108 C...g + g -> ~g + ~g ; th arbitrary
12110 KCS=(-1)**INT(1.5D0+PYR(0))
12115 ELSEIF(ISUB.LE.260) THEN
12116 IF(ISUB.EQ.246) THEN
12117 C...qj + g -> ~qj_L + ~chi01
12118 IF(MINT(15).EQ.21) JS=2
12121 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12122 MINT(23-JS)=KSUSY1+22
12124 KCS=ISIGN(1,MINT(14+JS))
12126 ELSEIF(ISUB.EQ.247) THEN
12127 C...qj + g -> ~qj_R + ~chi01
12128 IF(MINT(15).EQ.21) JS=2
12131 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12132 MINT(23-JS)=KSUSY1+22
12134 KCS=ISIGN(1,MINT(14+JS))
12136 ELSEIF(ISUB.EQ.248) THEN
12137 C...qj + g -> ~qj_L + ~chi02
12138 IF(MINT(15).EQ.21) JS=2
12141 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12142 MINT(23-JS)=KSUSY1+23
12144 KCS=ISIGN(1,MINT(14+JS))
12146 ELSEIF(ISUB.EQ.249) THEN
12147 C...qj + g -> ~qj_R + ~chi02
12148 IF(MINT(15).EQ.21) JS=2
12151 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12152 MINT(23-JS)=KSUSY1+23
12154 KCS=ISIGN(1,MINT(14+JS))
12156 ELSEIF(ISUB.EQ.250) THEN
12157 C...qj + g -> ~qj_L + ~chi03
12158 IF(MINT(15).EQ.21) JS=2
12161 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12162 MINT(23-JS)=KSUSY1+25
12164 KCS=ISIGN(1,MINT(14+JS))
12166 ELSEIF(ISUB.EQ.251) THEN
12167 C...qj + g -> ~qj_R + ~chi03
12168 IF(MINT(15).EQ.21) JS=2
12171 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12172 MINT(23-JS)=KSUSY1+25
12174 KCS=ISIGN(1,MINT(14+JS))
12176 ELSEIF(ISUB.EQ.252) THEN
12177 C...qj + g -> ~qj_L + ~chi04
12178 IF(MINT(15).EQ.21) JS=2
12181 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12182 MINT(23-JS)=KSUSY1+35
12184 KCS=ISIGN(1,MINT(14+JS))
12186 ELSEIF(ISUB.EQ.253) THEN
12187 C...qj + g -> ~qj_R + ~chi04
12188 IF(MINT(15).EQ.21) JS=2
12191 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12192 MINT(23-JS)=KSUSY1+35
12194 KCS=ISIGN(1,MINT(14+JS))
12196 ELSEIF(ISUB.EQ.254) THEN
12197 C...qj + g -> ~qk_L + ~chi+-1
12198 IF(MINT(15).EQ.21) JS=2
12201 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12202 IB=-IA+INT((IA+1)/2)*4-1
12203 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12205 KCS=ISIGN(1,MINT(14+JS))
12207 ELSEIF(ISUB.EQ.255) THEN
12208 C...qj + g -> ~qk_L + ~chi+-1
12209 IF(MINT(15).EQ.21) JS=2
12212 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12213 IB=-IA+INT((IA+1)/2)*4-1
12214 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12216 KCS=ISIGN(1,MINT(14+JS))
12218 ELSEIF(ISUB.EQ.256) THEN
12219 C...qj + g -> ~qk_L + ~chi+-2
12220 IF(MINT(15).EQ.21) JS=2
12223 IB=-IA+INT((IA+1)/2)*4-1
12224 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12225 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12227 KCS=ISIGN(1,MINT(14+JS))
12229 ELSEIF(ISUB.EQ.257) THEN
12230 C...qj + g -> ~qk_R + ~chi+-2
12231 IF(MINT(15).EQ.21) JS=2
12234 IB=-IA+INT((IA+1)/2)*4-1
12235 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12236 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12238 KCS=ISIGN(1,MINT(14+JS))
12240 ELSEIF(ISUB.EQ.258) THEN
12241 C...qj + g -> ~qj_L + ~g
12242 IF(MINT(15).EQ.21) JS=2
12245 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12246 MINT(23-JS)=KSUSY1+21
12248 IF(JS.EQ.2) KCC=KCC+2
12251 ELSEIF(ISUB.EQ.259) THEN
12252 C...qj + g -> ~qj_R + ~g
12253 IF(MINT(15).EQ.21) JS=2
12256 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12257 MINT(23-JS)=KSUSY1+21
12259 IF(JS.EQ.2) KCC=KCC+2
12263 ELSEIF(ISUB.LE.270) THEN
12264 IF(ISUB.EQ.261) THEN
12265 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
12267 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12268 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12270 C...Correct color combination
12271 IF(MINT(43).EQ.4) KCC=4
12273 ELSEIF(ISUB.EQ.262) THEN
12274 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
12276 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12277 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12279 C...Correct color combination
12280 IF(MINT(43).EQ.4) KCC=4
12282 ELSEIF(ISUB.EQ.263) THEN
12283 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
12284 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
12285 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
12286 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12287 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
12290 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
12291 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
12293 C...Correct color combination
12294 IF(MINT(43).EQ.4) KCC=4
12296 ELSEIF(ISUB.EQ.264) THEN
12297 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
12298 KCS=(-1)**INT(1.5D0+PYR(0))
12299 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12303 ELSEIF(ISUB.EQ.265) THEN
12304 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
12305 KCS=(-1)**INT(1.5D0+PYR(0))
12306 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12311 ELSEIF(ISUB.LE.296) THEN
12312 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
12313 C...qi + qj -> ~qi_L + ~qj_L
12315 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12316 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12317 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12319 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
12320 C...qi + qj -> ~qi_R + ~qj_R
12322 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12323 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12324 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12326 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
12327 C...qi + qj -> ~qi_L + ~qj_R
12328 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12329 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12331 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12333 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
12334 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
12335 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12336 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12338 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12340 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
12341 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12342 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12343 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12345 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12347 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
12348 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12349 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12350 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12352 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12354 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
12355 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12357 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12358 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12360 IF(MINT(43).EQ.4) KCC=4
12362 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
12363 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12365 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12366 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12368 IF(MINT(43).EQ.4) KCC=4
12370 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
12371 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12373 KCS=(-1)**INT(1.5D0+PYR(0))
12374 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12378 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
12379 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12380 KCS=(-1)**INT(1.5D0+PYR(0))
12381 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12385 ELSEIF(ISUB.EQ.294) THEN
12386 C...qj + g -> ~qj_L + ~g
12387 IF(MINT(15).EQ.21) JS=2
12390 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12391 MINT(23-JS)=KSUSY1+21
12393 IF(JS.EQ.2) KCC=KCC+2
12396 ELSEIF(ISUB.EQ.295) THEN
12397 C...qj + g -> ~qj_R + ~g
12398 IF(MINT(15).EQ.21) JS=2
12401 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12402 MINT(23-JS)=KSUSY1+21
12404 IF(JS.EQ.2) KCC=KCC+2
12408 ELSEIF(ISUB.LE.330) THEN
12409 IF(ISUB.EQ.311)THEN
12410 C...g + g -> g* + g* (UED)
12412 KCS=(-1)**INT(1.5D0+PYR(0))
12415 MINT(21)=IUEDEQ(472)
12416 MINT(22)=IUEDEQ(472)
12417 ELSEIF(ISUB.EQ.312)THEN
12418 C...q + g -> q*_D + g*, q*_S + g*
12419 C...The two channels have the same cross section
12421 IF(PYR(0).GT.0.5)KKFLMI=456
12422 IF(MINT(15).EQ.21) JS=2
12424 IF(MINT(15).EQ.21)KCC=KCC+2
12425 IF(MINT(15).NE.21)THEN
12426 KCS=ISIGN(1,MINT(15))
12428 MUED(1)=KCS*(KKFLMI+IABS(MINT(15)))
12429 MINT(22)=IUEDEQ(472)
12430 MINT(21)=KCS*IUEDEQ(KKFLMI+IABS(MINT(15)))
12432 IF(MINT(16).NE.21)THEN
12433 KCS=ISIGN(1,MINT(16))
12434 MUED(2)=KCS*(KKFLMI+IABS(MINT(16)))
12436 MINT(22)=KCS*IUEDEQ(KKFLMI+IABS(MINT(16)))
12437 MINT(21)=IUEDEQ(472)
12439 ELSEIF(ISUB.EQ.313)THEN
12440 C...q + q' -> q*_D + q*_D',q*_S+q*_S'
12441 C...The two channels have the same cross section
12443 IF(PYR(0).GT.0.5)KKFLMI=456
12445 IF(MINT(15).EQ.MINT(16))THEN
12446 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12448 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12451 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12452 MUED(2)=SIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12453 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12454 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12456 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12457 ELSEIF(ISUB.EQ.314)THEN
12458 C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar
12459 C...The two channels have the same cross section
12461 IF(PYR(0).GT.0.5)KKFLMI=456
12462 KCS=(-1)**INT(1.5D0+PYR(0))
12464 IF(XFLAOUT.LE.0.2)THEN
12465 MUED(1)=ISIGN(1,KCS)*(KKFLMI+1)
12466 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+1)
12467 ELSEIF(XFLAOUT.LE.0.4)THEN
12468 MUED(1)=ISIGN(1,KCS)*(KKFLMI+2)
12469 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+2)
12470 ELSEIF(XFLAOUT.LE.0.6)THEN
12471 MUED(1)=ISIGN(1,KCS)*(KKFLMI+3)
12472 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+3)
12473 ELSEIF(XFLAOUT.LE.0.8)THEN
12474 MUED(1)=ISIGN(1,KCS)*(KKFLMI+4)
12475 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+4)
12477 MUED(1)=ISIGN(1,KCS)*(KKFLMI+5)
12478 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+5)
12483 ELSEIF(ISUB.EQ.315)THEN
12484 C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar
12485 C...The two channels have the same cross section
12487 IF(PYR(0).GT.0.5)KKFLMI=456
12488 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12490 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12493 ELSEIF(ISUB.EQ.316)THEN
12494 C...q + qbar' -> q*_D + q*_S_bar'
12495 MUED(1)=ISIGN(1,MINT(15))*(456+IABS(MINT(15)))
12496 MUED(2)=ISIGN(1,MINT(16))*(450+IABS(MINT(16)))
12497 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12498 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12500 ELSEIF(ISUB.EQ.317)THEN
12501 C...q + qbar' -> q*_D + q*_D_bar', q*_S + q*_S_bar
12502 C...The two channels have the same cross section
12504 IF(PYR(0).GT.0.5)KKFLMI=456
12505 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12506 MUED(2)=ISIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12507 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12508 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12510 ELSEIF(ISUB.EQ.318)THEN
12511 C...q + q' -> q*_D + q*_S'
12513 MUED(1)=SIGN(1,MINT(15))*(456+IABS(MINT(15)))
12514 MUED(2)=SIGN(1,MINT(16))*(450+IABS(MINT(16)))
12515 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12516 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12517 ELSEIF(ISUB.EQ.319)THEN
12518 C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar'
12519 C...The two channels have the same cross section
12521 IF(PYR(0).GT.0.5)KKFLMI=456
12524 C...N.B. NFLAVOURS=IUED(3)
12527 IF(I.NE.IABS(MINT(15)))THEN
12532 FLASTEP=1./(IUED(3)-1)
12535 IF(XFLAOUT.LE.FLAVV)THEN
12536 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IOKFLA(I))
12537 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IOKFLA(I))
12542 IF(IABS(MUED(1)).LT.451.AND.IABS(MUED(1)).GT.462)THEN
12543 WRITE(MSTU(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!'
12544 CALL PYSTOP(5000000)
12550 ELSEIF(ISUB.LE.340) THEN
12552 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
12553 C...q + qbar' -> H+ + H0
12554 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12555 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12556 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12557 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
12558 MINT(23-JS)=KFPR(ISUB,2)
12559 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
12560 C...f + fbar -> A0 + H0; th arbitrary
12561 IF(PYR(0).GT.0.5D0) JS=2
12562 MINT(20+JS)=KFPR(ISUB,1)
12563 MINT(23-JS)=KFPR(ISUB,2)
12564 ELSEIF(ISUB.EQ.301) THEN
12565 C...f + fbar -> H+ H-
12566 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12571 ELSEIF(ISUB.LE.360) THEN
12573 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
12574 C...l + l -> H_L++/--, H_R++/--
12575 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12576 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12577 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12579 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
12580 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12581 IF(MINT(15).EQ.22) JS=2
12582 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
12583 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
12586 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
12587 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12588 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
12591 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
12592 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12593 C...as inner process).
12598 RVCKM=VINT(180+I)*PYR(0)
12601 IPM=(5-ISIGN(1,I))/2
12603 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
12604 MINT(20+JT)=ISIGN(IB,I)
12605 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12606 IF(RVCKM.LE.0D0) GOTO 450
12609 IB=2*((IA+1)/2)-1+MOD(IA,2)
12610 MINT(20+JT)=ISIGN(IB,I)
12614 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
12615 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
12617 ELSEIF(ISUB.EQ.353) THEN
12618 C...f + fbar -> Z_R0
12621 ELSEIF(ISUB.EQ.354) THEN
12622 C...f + fbar' -> W+/-
12623 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12624 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12625 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12629 ELSEIF(ISUB.LE.380) THEN
12631 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
12632 C...f + fbar -> charged+ charged- technicolor
12633 KSW=(-1)**INT(1.5D0+PYR(0))
12634 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
12635 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
12637 ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
12638 C...f + fbar -> neutral neutral technicolor
12639 MINT(21)=KFPR(ISUB,1)
12640 MINT(22)=KFPR(ISUB,2)
12642 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
12643 C...f + fbar' -> neutral charged technicolor
12646 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12647 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12648 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12649 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12650 MINT(20+JS)=KFPR(ISUB,IN)
12652 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
12653 C...f + fbar' -> charged neutral technicolor
12656 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12657 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12658 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12659 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12660 MINT(23-JS)=KFPR(ISUB,IN)
12663 ELSEIF(ISUB.LE.400) THEN
12664 IF(ISUB.EQ.381) THEN
12665 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12667 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12669 ELSEIF(ISUB.EQ.382) THEN
12670 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12671 MINT(21)=ISIGN(KFLF,MINT(15))
12675 ELSEIF(ISUB.EQ.383) THEN
12676 C...f + fbar -> g + g; th arbitrary, TC extensions
12681 ELSEIF(ISUB.EQ.384) THEN
12682 C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12683 IF(MINT(15).EQ.21) JS=2
12685 IF(MINT(15).EQ.21) KCC=KCC+2
12686 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12687 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12689 ELSEIF(ISUB.EQ.385) THEN
12690 C...g + g -> f + fbar; th arbitrary, TC extensions
12691 KCS=(-1)**INT(1.5D0+PYR(0))
12692 MINT(21)=ISIGN(KFLF,KCS)
12696 ELSEIF(ISUB.EQ.386) THEN
12697 C...g + g -> g + g; th arbitrary, TC extensions
12699 KCS=(-1)**INT(1.5D0+PYR(0))
12701 ELSEIF(ISUB.EQ.387) THEN
12702 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12703 MINT(21)=ISIGN(MINT(55),MINT(15))
12707 ELSEIF(ISUB.EQ.388) THEN
12708 C...g + g -> Q + Qbar; th arbitrary, TC extensions
12709 KCS=(-1)**INT(1.5D0+PYR(0))
12710 MINT(21)=ISIGN(MINT(55),KCS)
12714 ELSEIF(ISUB.EQ.391) THEN
12715 C...f + fbar -> G*.
12718 ELSEIF(ISUB.EQ.392) THEN
12723 ELSEIF(ISUB.EQ.393) THEN
12724 C...q + qbar -> g + G*; th arbitrary.
12725 IF(PYR(0).GT.0.5D0) JS=2
12726 MINT(20+JS)=KFPR(ISUB,1)
12727 MINT(23-JS)=KFPR(ISUB,2)
12730 ELSEIF(ISUB.EQ.394) THEN
12731 C...q + g -> q + G*; th = (p(f) - p(f))**2
12732 IF(MINT(15).EQ.21) JS=2
12733 MINT(23-JS)=KFPR(ISUB,2)
12735 KCS=ISIGN(1,MINT(14+JS))
12737 ELSEIF(ISUB.EQ.395) THEN
12738 C...g + g -> G* + g; th arbitrary.
12739 IF(PYR(0).GT.0.5D0) JS=2
12740 MINT(23-JS)=KFPR(ISUB,2)
12744 ELSEIF(ISUB.LE.420) THEN
12745 IF(ISUB.EQ.401) THEN
12746 C...g + g -> t + b + H+/-
12747 KCS=(-1)**INT(1.5D0+PYR(0))
12748 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
12749 MINT(22)=ISIGN(5,-KCS)
12750 KCC=11+INT(0.5D0+PYR(0))
12751 KFRES=ISIGN(KFHIGG,-KCS)
12753 ELSEIF(ISUB.EQ.402) THEN
12754 C...q + qbar -> t + b + H+/-
12755 KFL=(-1)**INT(1.5D0+PYR(0))
12756 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
12757 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
12759 KFRES=ISIGN(KFHIGG,-KFL*KCS)
12763 C...Additional code by Stefan Wolf
12764 ELSEIF(ISUB.LE.430) THEN
12765 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
12766 C...g + g -> QQ~[n] + g
12767 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12768 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12769 C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12770 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12771 C...or from ISUB.EQ.68 (for ISUB.NE.421)
12772 C...[g + g -> g + g; th arbitrary]
12773 MINT(21)=KFPR(ISUBSV,1)
12774 MINT(22)=KFPR(ISUBSV,2)
12775 IF(ISUB.EQ.421) THEN
12777 KCS=(-1)**INT(1.5D0+PYR(0))
12780 KCS=(-1)**INT(1.5D0+PYR(0))
12783 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
12784 C...q + g -> q + QQ~[n]
12785 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12786 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12787 C...KCC copied from ISUB.EQ.28
12788 C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12789 IF(MINT(15).EQ.21) JS=2
12790 MINT(23-JS)=KFPR(ISUBSV,2)
12792 IF(MINT(15).EQ.21) KCC=KCC+2
12793 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12794 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12796 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
12797 C...q + q~ -> g + QQ~[n]
12798 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12799 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12800 C...KCC copied from ISUB.EQ.13
12801 C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12802 IF(PYR(0).GT.0.5) JS=2
12804 MINT(23-JS)=KFPR(ISUBSV,2)
12808 ELSEIF(ISUB.LE.440) THEN
12809 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
12810 C...g + g -> QQ~[n] + g
12811 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12812 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12813 C...KCC and KCS copied from ISUB.EQ.86-89
12814 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12815 MINT(21)=KFPR(ISUBSV,1)
12816 MINT(22)=KFPR(ISUBSV,2)
12818 KCS=(-1)**INT(1.5D0+PYR(0))
12820 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
12821 C...q + g -> q + QQ~[n]
12822 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12823 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12824 C...KCC and KCS copied from ISUB.EQ.112
12825 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12826 IF(MINT(15).EQ.21) JS=2
12827 MINT(23-JS)=KFPR(ISUBSV,2)
12829 KCS=ISIGN(1,MINT(14+JS))
12831 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
12832 C...q + q~ -> g + QQ~[n]
12833 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12834 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12835 C...KCC copied from ISUB.EQ.111
12836 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12837 IF(PYR(0).GT.0.5) JS=2
12839 MINT(23-JS)=KFPR(ISUBSV,2)
12846 IF(ISET(ISUB).EQ.11) THEN
12847 C...Store documentation for user-defined processes
12848 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
12849 KUPPO(1)=MINT(83)+5
12850 KUPPO(2)=MINT(83)+6
12854 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
12863 IF(IDUP(IUP).EQ.0) K(I,2)=90
12865 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
12873 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
12876 C...Store final state partons for user-defined processes
12881 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
12883 IF(IDUP(IUP).EQ.0) K(N,2)=90
12884 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
12887 K(N,3)=MINT(84)+MOTHUP(1,IUP)
12891 C...Search for daughters of intermediate colourless particles.
12892 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
12893 DO 475 IUPDAU=IUP+1,NUP
12894 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
12896 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
12904 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
12906 C...Arrange colour flow for user-defined processes
12910 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
12911 IF(K(I1,1).EQ.1) K(I1,1)=3
12912 IF(K(I1,1).EQ.11) K(I1,1)=14
12913 C...Find a not yet considered colour/anticolour line.
12915 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
12918 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
12922 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
12923 C...Find all others belonging to same line.
12926 DO 520 IUP2=IUP1+1,NUP
12929 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
12930 IF(ISDE2.EQ.ISDE1) THEN
12931 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
12932 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
12934 ELSEIF(I4.NE.0) THEN
12935 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
12936 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
12938 ELSEIF(IUP2.LE.2) THEN
12939 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
12940 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
12943 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
12944 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
12954 ELSEIF(IDOC.EQ.7) THEN
12955 C...Resonance not decaying; store kinematics
12970 C...Special cases: colour flow in coloured resonances
12971 KCRES=PYCOMP(KFRES)
12972 IF(KCHG(KCRES,2).NE.0) THEN
12976 IF(KCS.EQ.-1) JC=3-J
12977 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12978 & MINT(84)+ICOL(KCC,1,JC)
12979 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12980 & MINT(84)+ICOL(KCC,2,JC)
12981 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12982 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12991 ELSEIF(IDOC.EQ.8) THEN
12992 C...2 -> 2 processes: store outgoing partons in their CM-frame
12995 KCA=PYCOMP(MINT(20+JT))
12997 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12999 K(I,3)=MINT(83)+IDOC+JT-2
13001 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
13002 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13004 P(I,5)=PYMASS(K(I,2))
13006 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
13007 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
13009 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
13010 KFA1=IABS(MINT(21))
13011 KFA2=IABS(MINT(22))
13012 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
13020 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
13021 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
13022 P(IPU4,4)=SHR-P(IPU3,4)
13023 P(IPU4,3)=-P(IPU3,3)
13028 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
13029 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
13031 ELSEIF(IDOC.EQ.9) THEN
13032 C...2 -> 3 processes: store outgoing partons in their CM frame
13035 KCA=PYCOMP(MINT(20+JT))
13037 IF(KCHG(KCA,2).NE.0) K(I,1)=3
13039 K(I,3)=MINT(83)+IDOC+JT-3
13041 C...t and b in opposide order in event list as compared to
13042 C...matrix element?
13043 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
13044 IF(IABS(K(I,2)).LE.22) THEN
13045 P(I,5)=PYMASS(K(I,2))
13047 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
13049 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
13050 P(I,1)=PT*COS(VINT(198+5*JTA))
13051 P(I,2)=PT*SIN(VINT(198+5*JTA))
13055 K(IPU5,3)=MINT(83)+IDOC
13057 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13058 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13059 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
13060 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
13061 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
13063 P(IPU5,3)=PMT3*SINH(VINT(211))
13064 P(IPU5,4)=PMT3*COSH(VINT(211))
13065 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
13066 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
13067 IF(SQL12.LE.0D0) THEN
13071 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
13072 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13073 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
13074 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
13075 C...t and b in opposide order in event list as compared to
13077 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
13078 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13079 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
13081 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
13082 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
13088 ELSEIF(IDOC.EQ.11) THEN
13089 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
13090 PHI(1)=PARU(2)*PYR(0)
13095 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13097 K(I,3)=MINT(83)+IDOC+JT-2
13098 P(I,5)=PYMASS(K(I,2))
13099 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
13103 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13104 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13105 P(I,1)=PTABS*COS(PHI(JT))
13106 P(I,2)=PTABS*SIN(PHI(JT))
13107 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13108 P(I,4)=0.5D0*SHPR*Z(JT)
13112 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
13116 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13117 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13118 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13125 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13126 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13127 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
13128 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
13137 ELSEIF(IDOC.EQ.12) THEN
13138 C...Z0 and W+/- scattering: store bosons and outgoing partons
13139 PHI(1)=PARU(2)*PYR(0)
13141 JTRAN=INT(1.5D0+PYR(0))
13145 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13147 K(I,3)=MINT(83)+IDOC+JT-2
13148 P(I,5)=PYMASS(K(I,2))
13149 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
13150 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13151 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13152 P(I,1)=PTABS*COS(PHI(JT))
13153 P(I,2)=PTABS*SIN(PHI(JT))
13154 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13155 P(I,4)=0.5D0*SHPR*Z(JT)
13158 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
13161 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
13166 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13167 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13168 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13171 K(IPU,2)=KFPR(ISUB,JT)
13172 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
13173 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
13174 K(IPU,3)=MINT(83)+8+JT
13175 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
13176 P(IPU,5)=PYMASS(K(IPU,2))
13178 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13180 MINT(22+JT)=K(IPU,2)
13182 C...Find rotation and boost for hard scattering subsystem
13185 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
13186 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
13187 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
13188 GAMCM=(P(I1,4)+P(I2,4))/SHR
13189 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
13190 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
13191 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
13192 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
13193 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
13194 PHICM=PYANGL(PX,PY)
13195 C...Store hard scattering subsystem. Rotate and boost it
13196 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
13198 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
13200 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
13201 PHIWZ=VINT(24)-PHICM
13202 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
13203 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
13204 P(IPU5,3)=PABS*CTHWZ
13205 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
13206 P(IPU6,1)=-P(IPU5,1)
13207 P(IPU6,2)=-P(IPU5,2)
13208 P(IPU6,3)=-P(IPU5,3)
13209 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
13210 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
13222 MINT(8)=MINT(83)+10
13225 IF(ISET(ISUB).EQ.11) THEN
13226 ELSEIF(IDOC.GE.8) THEN
13227 C...Store colour connection indices
13230 IF(KCS.EQ.-1) JC=3-J
13231 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13232 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
13233 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13234 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
13235 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
13236 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13237 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13238 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13241 C...Copy outgoing partons to documentation lines
13243 IF(IDOC.EQ.9) IMAX=3
13245 I1=MINT(83)+IDOC-IMAX+I
13249 IF(IDOC.LE.9) K(I1,3)=0
13250 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
13256 ELSEIF(IDOC.EQ.9) THEN
13257 C...Store colour connection indices
13260 IF(KCS.EQ.-1) JC=3-J
13261 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13262 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
13263 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
13264 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13265 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
13266 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
13267 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13268 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13269 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
13270 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13273 C...Copy outgoing partons to documentation lines
13275 I1=MINT(83)+IDOC-3+I
13286 C...Copy outgoing partons to list of allowed radiators.
13288 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
13289 DO 690 I=MINT(84)+3,N
13292 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
13296 C...Low-pT events: remove gluons used for string drawing purposes
13297 IF(ISUB.EQ.95) THEN
13298 IF(MINT(35).LE.1) THEN
13299 K(IPU3,1)=K(IPU3,1)+10
13300 K(IPU4,1)=K(IPU4,1)+10
13306 DO 720 I=MINT(83)+5,MINT(83)+8
13316 C***********************************************************************
13319 C...Handles intertwined pT-ordered spacelike initial-state parton
13320 C...and multiple interactions.
13322 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
13323 C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
13324 C...MODE = 0 : (Re-)initialize ISR/MI evolution.
13325 C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
13327 C...Double precision and integer declarations.
13328 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13329 IMPLICIT INTEGER(I-N)
13330 INTEGER PYK,PYCHGE,PYCOMP
13333 DOUBLE PRECISION PYALPS
13334 C...Parameter statement for maximum size of showers.
13335 PARAMETER (MAXNUR=1000)
13337 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13338 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13339 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13340 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13341 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13342 COMMON/PYINT1/MINT(400),VINT(400)
13343 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13344 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13345 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
13346 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
13347 & XMI(2,240),PT2MI(240),IMISEP(0:240)
13348 COMMON/PYCTAG/NCT,MCT(4000,2)
13349 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
13350 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
13351 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
13352 C...Local arrays and saved variables.
13353 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
13354 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
13357 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
13358 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
13360 C----------------------------------------------------------------------
13361 C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
13362 C...done only once per event, while MODE=0 is repeated each time the
13363 C...evolution needs to be restarted.
13364 IF (MODE.EQ.-1) THEN
13368 C...Store hard scattering variables
13385 C...Set shat for hardest scattering
13387 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
13390 C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
13394 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
13395 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
13396 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
13398 C----------------------------------------------------------------------
13399 C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
13400 C...interaction initiators, with no previous evolution. Check the input
13401 C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
13402 C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
13403 C...smaller than the CM energy / 2.)
13404 ELSEIF (MODE.EQ.0) THEN
13405 C...Reset counters and switches
13411 C...Reset hard scattering variables
13422 P(MINT(83)+4+IS,J)=PSAV(IS,J)
13423 V(MINT(83)+4+IS,J)=VSAV(IS,J)
13426 C...Reset statistics on activity in event.
13431 C...Reset extra companion reweighting factor
13434 C...We do not generate MI for soft process (ISUB=95), but the
13435 C...initialization must be done regardless, for later purposes.
13438 C...Initialize multiple interactions.
13439 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
13440 IF(MINT(51).NE.0) RETURN
13442 C...Decide whether quarks in hard scattering were valence or sea
13446 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
13447 IF(MINT(51).NE.0) RETURN
13450 C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
13452 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
13453 IF (MSTP(70).EQ.2) THEN
13454 C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
13455 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
13456 ELSEIF (MSTP(70).EQ.3) THEN
13457 C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73)
13458 ALPHA0 = MAX(1D-6,PARP(73))
13459 Q20 = ALAM3**2/PARP(64)
13460 IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2
13461 VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0)
13463 C...Also store PT2MIN in VINT(17).
13464 180 VINT(17)=PT2MIN
13466 C...Set FS masses zero now.
13470 C...Initialize IS showers with VINT(56) as max scale.
13473 IF (MSTP(70).EQ.0) THEN
13474 PT20=MAX(PT2MIN,PARP(62)**2)
13475 ELSEIF (MSTP(70).EQ.1) THEN
13476 PT20=MAX(PT2MIN,(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13478 CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL)
13479 IF(MINT(51).NE.0) RETURN
13483 C----------------------------------------------------------------------
13484 C...MODE= 1: Evolve event from PTMAX to PTMIN.
13485 ELSEIF (MODE.EQ.1) THEN
13487 C...Skip if no phase space.
13488 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
13490 C...Starting pT2 max scale (to be udpated successively).
13493 C...Evolve two sides of the event to find which branches at highest pT.
13498 C...Loop over current shower initiators.
13499 IF (MSTP(61).GE.1) THEN
13500 DO 230 MI=1,MINT(31)
13501 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
13503 IF (MI.EQ.1) ISUB=ISUBHD
13506 C...Set up shat, initiator x values, and x remaining in BR.
13508 VINT(141)=XMI(1,MI)
13509 VINT(142)=XMI(2,MI)
13512 DO 210 JI=1,MINT(31)
13513 IF (JI.EQ.MINT(36)) GOTO 210
13514 VINT(143)=VINT(143)-XMI(1,JI)
13515 VINT(144)=VINT(144)-XMI(2,JI)
13517 C...Loop over sides.
13518 C...Generate trial branchings for this interaction. The hardest
13519 C...branching so far is automatically updated if necessary in /PYISMX/.
13523 IF (MSTP(70).EQ.0) THEN
13524 PT20=MAX(PT2MIN,PARP(62)**2)
13525 ELSEIF (MSTP(70).EQ.1) THEN
13527 & (PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13529 CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL)
13530 IF (MINT(51).NE.0) RETURN
13535 C...Generate trial additional interaction.
13536 MINT(36)=MINT(31)+1
13537 240 IF (MOD(MSTP(81),10).GE.1) THEN
13539 C...Set up X remaining in BR.
13542 DO 250 JI=1,MINT(31)
13543 VINT(143)=VINT(143)-XMI(1,JI)
13544 VINT(144)=VINT(144)-XMI(2,JI)
13546 C...Generate trial interaction
13547 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13548 IF (MINT(51).EQ.1) RETURN
13551 C...And the winner is:
13552 IF (PT2MX.LT.PT2MIN) THEN
13554 ELSEIF (JSMX.EQ.0) THEN
13555 C...Accept additional interaction (may still fail).
13556 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13557 IF(MINT(51).NE.0) RETURN
13558 IF (IFAIL.EQ.0) THEN
13559 SHAT(MINT(36))=VINT(44)
13560 C...Decide on flavours (valence/sea/companion).
13563 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13564 IF(MINT(51).NE.0) RETURN
13567 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
13568 C...Reconstruct kinematics of acceptable ISR branching.
13569 C...Set up shat, initiator x values, and x remaining in BR.
13572 VINT(44)=SHAT(MINT(36))
13573 VINT(141)=XMI(1,MINT(36))
13574 VINT(142)=XMI(2,MINT(36))
13577 DO 280 JI=1,MINT(31)
13578 IF (JI.EQ.MINT(36)) GOTO 280
13579 VINT(143)=VINT(143)-XMI(1,JI)
13580 VINT(144)=VINT(144)-XMI(2,JI)
13583 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
13584 IF (MINT(51).EQ.1) RETURN
13585 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
13586 C...Bookeep joining. Cannot (yet) be constructed kinematically.
13587 MINT(354)=MINT(354)+1
13588 VINT(354)=VINT(354)+SQRT(PT2MX)
13589 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
13590 MJOIND(JSMX-2,MJN1MX)=MJN2MX
13591 MJOIND(JSMX-2,MJN2MX)=MJN1MX
13594 C...Update PT2 iteration scale.
13597 C...Loop back to continue evolution.
13598 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13599 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
13601 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
13604 C----------------------------------------------------------------------
13605 C...MODE= 2: (Re-)store user information on hardest interaction etc.
13606 ELSEIF (MODE.EQ.2) THEN
13608 C...Revert to "ordinary" meanings of some parameters.
13610 MINT(12+JS)=K(IMI(JS,1,1),2)
13611 VINT(140+JS)=XMI(JS,1)
13612 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
13614 DO 300 MI=1,MINT(31)
13615 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
13619 C...Restore saved quantities for hardest interaction.
13634 C*********************************************************************
13637 C...Generates spacelike parton showers.
13639 SUBROUTINE PYSSPA(IPU1,IPU2)
13641 C...Double precision and integer declarations.
13642 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13643 IMPLICIT INTEGER(I-N)
13644 INTEGER PYK,PYCHGE,PYCOMP
13645 PARAMETER (MAXNUR=1000)
13647 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13648 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13649 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13650 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13651 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13652 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13653 COMMON/PYINT1/MINT(400),VINT(400)
13654 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13655 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13656 COMMON/PYCTAG/NCT,MCT(4000,2)
13657 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,
13658 &/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/
13659 C...Local arrays and data.
13660 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
13661 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
13662 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
13663 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
13664 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
13667 C...Read out basic information; set global Q^2 scale.
13672 VINT2R=VINT(2)*VINT(143)*VINT(144)
13673 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
13674 &MIN(VINT2R,PARP(67)*VINT(56))
13677 C...Define which processes ME corrections have been implemented for.
13679 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13680 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
13681 & ISUB.EQ.144) MECOR=1
13682 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13683 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
13686 C...Initialize QCD evolution and check phase space.
13690 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
13693 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13694 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13695 Q2INT=SQRT(Q0S*Q2EFF)
13696 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
13697 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
13698 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
13700 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
13703 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13704 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13705 Q2INT=SQRT(Q0S*Q2EFF)
13706 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
13707 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
13708 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
13715 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
13717 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
13718 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
13719 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
13720 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
13724 C...Initialize QED evolution and check phase space.
13728 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
13729 &SPME=PMAS(13,1)**2
13730 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
13731 &SPME=PMAS(15,1)**2
13732 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
13735 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
13737 TEMX=LOG(Q2MX/SPME)
13738 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
13740 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13745 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
13747 C...Loopback point in case of failure to reconstruct kinematics.
13756 IF(LOOP.GT.100) THEN
13767 C...Initial values: flavours, momenta, virtualities.
13770 KFBEAM(JT)=MINT(10+JT)
13771 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
13772 KFLS(JT)=MINT(14+JT)
13773 KFLS(JT+2)=KFLS(JT)
13775 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
13776 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
13778 Q2S(JT)=FCQ2MX*Q2MX
13785 C...Calculate initial parton distribution weights.
13786 MINT(105)=MINT(102+JT)
13787 MINT(109)=MINT(106+JT)
13788 VINT(120)=VINT(2+JT)
13790 C.... Store side in MINT(124)
13793 IF(XS(JT).LT.1D0-XEE) THEN
13794 IF(MINT(31).GE.2) MINT(30)=JT
13795 IF(MSTP(57).LE.1) THEN
13796 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13798 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13802 XFS(JT,KFL)=XFB(KFL)
13804 C...Special kinematics check for c/b quarks (that g -> c cbar or
13805 C...b bbar kinematically possible).
13806 KFLCB=IABS(KFLS(JT))
13807 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
13808 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
13815 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
13817 C...Find if interference with final state partons.
13819 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
13823 KCA=PYCOMP(IABS(KFLS(I)))
13824 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
13826 IF(KCFI(I).NE.0) THEN
13827 IF(I.EQ.1) IPFS=IPUS1
13828 IF(I.EQ.2) IPFS=IPUS2
13830 ICSI=MOD(K(IPFS,3+J),MSTU(5))
13831 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
13832 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
13834 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
13836 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
13841 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
13844 C...Pick up leg with highest virtuality.
13848 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
13849 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
13850 IF(MORE(JT).EQ.0) JT=3-JT
13855 XFB(KFL)=XFS(JT,KFL)
13860 C...Check if allowed to branch.
13862 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
13864 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
13865 IF(XB.GE.1D0-2D0*XEC) MCEV=0
13868 IF(MINT(44+JT).EQ.3) THEN
13870 IF(XB.GE.1D0-2D0*XEE) MEEV=0
13871 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
13873 C***Currently kill QED shower for resolved photoproduction.
13874 IF(MINT(18+JT).EQ.1) MEEV=0
13875 C***Currently kill shower for W inside electron.
13876 IF(IABS(KFLB).EQ.24) THEN
13881 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
13883 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13888 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
13892 IF(MSTP(62).LE.1) THEN
13893 IF(ZS(JT).GT.0.99999D0) THEN
13896 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
13897 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
13898 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
13900 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13901 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13904 ALSDUM=PYALPS(FQ2C*Q2B)
13905 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
13907 B0=(33D0-2D0*MSTU(118))/6D0
13909 IF(MEEV.EQ.2) TEVEB=TEVCB
13913 C...Select side for interference with final state partons.
13914 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
13917 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
13919 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
13920 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
13921 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
13923 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
13927 C...Calculate preweighting factor for ME-corrected processes.
13928 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
13930 C...Calculate Altarelli-Parisi weights.
13936 C...q -> q (g or gamma emission), g -> q.
13937 IF(IABS(KFLB).LE.10) THEN
13938 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
13939 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
13941 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
13942 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
13944 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13945 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
13946 WTAPC(21)=WTGF*WTAPC(21)
13947 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13949 C...f -> f, gamma -> f.
13950 ELSEIF(IABS(KFLB).LE.20) THEN
13951 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
13952 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
13953 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
13954 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
13955 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13956 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13957 WTAPE(22)=WTGF*WTAPE(22)
13959 C...f -> g, g -> g.
13960 ELSEIF(KFLB.EQ.21) THEN
13961 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
13962 DO 180 KFL=1,MSTP(58)
13966 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
13967 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13968 DO 190 KFL=1,MSTP(58)
13969 WTAPC(KFL)=WTFG*WTAPC(KFL)
13970 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
13972 WTAPC(21)=WTGG*WTAPC(21)
13974 C...f -> gamma, W+, W-.
13975 ELSEIF(KFLB.EQ.22) THEN
13976 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
13979 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13980 WTAPE(11)=WTFG*WTAPE(11)
13981 WTAPE(-11)=WTFG*WTAPE(-11)
13983 ELSEIF(KFLB.EQ.24) THEN
13984 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13985 & (XEE*(XB+XEE)))/XB
13986 ELSEIF(KFLB.EQ.-24) THEN
13987 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13988 & (XEE*(XB+XEE)))/XB
13991 C...Calculate parton distribution weights and sum.
13994 IF(NTRY.GT.500) THEN
14000 XFBO=MAX(1D-10,XFB(KFLB))
14002 WTSF(KFL)=XFB(KFL)/XFBO
14003 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
14004 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
14006 WTSUMC=MAX(0.0001D0,WTSUMC)
14007 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
14009 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
14012 IF(NTRY2.GT.500) THEN
14017 IF(MSTP(64).LE.0) THEN
14018 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
14019 ELSEIF(MSTP(64).EQ.1) THEN
14020 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
14022 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
14026 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
14027 & (PARU(101)*FWTE*WTSUME*TEMX)))
14028 ELSEIF(MEEV.EQ.2) THEN
14029 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
14032 C...Translate t into Q2 scale; choose between QCD and QED evolution.
14033 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
14034 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
14035 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
14036 C...Ensure that Q2 is above threshold for charm/bottom.
14038 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14040 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
14041 Q2CB=1.1D0*PMAS(KFLCB,1)**2
14042 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14043 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
14046 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14048 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
14051 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
14052 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
14053 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
14054 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
14055 IF(Q2EB.GT.Q2MNE) MCE=2
14056 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
14057 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
14058 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
14059 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
14060 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
14061 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
14063 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
14064 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
14067 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
14068 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
14071 C...Evolution possibly ended. Update t values.
14075 ELSEIF(MCE.EQ.1) THEN
14078 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
14079 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14083 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14086 C...Select flavour for branching parton.
14087 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
14088 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
14091 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
14092 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
14093 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
14094 IF(KFLA.EQ.25) THEN
14099 C...Choose z value and corrective weight.
14101 C...q -> q + g or q -> q + gamma.
14102 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
14103 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
14104 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
14105 WTZ=0.5D0*(1D0+Z**2)
14107 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
14108 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
14109 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14110 C...f -> f + gamma.
14111 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14112 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
14113 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
14114 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
14116 Z=XB+XB*(XEE/(1D0-XEE))*
14117 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14119 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
14120 C...f -> gamma + f.
14121 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
14122 Z=XB+XB*(XEE/(1D0-XEE))*
14123 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14124 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
14126 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
14127 Z=XB+XB*(XEE/(1D0-XEE))*
14128 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14129 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
14130 & (Q2B/(Q2B+PMAS(24,1)**2))
14132 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
14133 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
14134 WTZ=1D0-2D0*Z*(1D0-Z)
14136 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14137 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
14138 WTZ=(1D0-Z*(1D0-Z))**2
14139 C...gamma -> f + fbar.
14140 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
14141 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
14142 WTZ=1D0-2D0*Z*(1D0-Z)
14144 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
14146 C...Option with resummation of soft gluon emission as effective z shift.
14148 IF(MSTP(65).GE.1) THEN
14150 IF(KFLB.NE.21) RSOFT=8D0/3D0
14151 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
14152 IF(Z.LE.XB) GOTO 220
14155 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
14156 IF(MSTP(64).GE.2) THEN
14157 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
14158 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
14159 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
14160 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
14164 C...Remove kinematically impossible branchings.
14165 UHAT=Q2B-DSH*(1D0-Z)/Z
14166 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
14168 C...Select phi angle of branching at random.
14169 PHIBR=PARU(2)*PYR(0)
14171 C...Matrix-element corrections for some processes.
14172 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14173 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14174 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
14176 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
14177 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
14179 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14180 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
14182 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14183 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
14188 C...Impose angular constraint in first branching from interference
14189 C...with final state partons.
14191 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
14192 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
14193 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
14194 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
14195 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
14196 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
14200 C...Option with angular ordering requirement.
14201 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
14202 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
14203 IF(THE2T.GT.THE2(JT)) GOTO 220
14207 C...Weighting with new parton distributions.
14208 MINT(105)=MINT(102+JT)
14209 MINT(109)=MINT(106+JT)
14210 VINT(120)=VINT(2+JT)
14211 IF(MINT(31).GE.2) MINT(30)=JT
14213 C.... Store side in MINT(124)
14216 IF(MSTP(57).LE.1) THEN
14217 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
14219 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
14222 IF(XFBN.LT.1D-20) THEN
14223 IF(KFLA.EQ.KFLB) THEN
14229 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
14230 TEVCB=0.5D0*(TEVCBS+TEVCB)
14232 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
14233 TEVEB=0.5D0*(TEVEBS+TEVEB)
14245 C.... Store side in MINT(124)
14248 IF(MINT(31).GE.2) MINT(30)=JT
14249 IF(MSTP(57).LE.1) THEN
14250 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
14252 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
14255 IF(XFAN.LT.1D-20) GOTO 200
14257 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
14259 C...Define two hard scatterers in their CM-frame.
14260 260 IF(N.EQ.NS+2) THEN
14262 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
14265 IF(JR.EQ.1) IPO=IPUS1
14266 IF(JR.EQ.2) IPO=IPUS2
14276 P(I,3)=DPLCM*(-1)**(JR+1)
14277 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
14278 P(I,5)=-SQRT(DQ2(JR))
14281 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
14282 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
14283 MCT(I,1)=MCT(IPO,1)
14284 MCT(I,2)=MCT(IPO,2)
14287 C...Find maximum allowed mass of timelike parton.
14288 ELSEIF(N.GT.NS+2) THEN
14293 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
14294 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
14295 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
14296 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
14297 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
14299 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
14300 & 1D-10*DPD(1)) IKIN=1
14301 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
14302 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
14303 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
14304 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
14306 C...Generate timelike parton shower (if required).
14313 C...f -> f + g (gamma).
14314 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
14316 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
14317 C...f -> g (gamma, W+-) + f.
14318 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
14320 IF(KFLS(JT+2).EQ.24) THEN
14322 ELSEIF(KFLS(JT+2).EQ.-24) THEN
14325 C...g (gamma) -> f + fbar, g + g.
14327 K(IT,2)=-KFLS(JT+2)
14328 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
14331 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
14332 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
14333 P(IT,5)=PYMASS(K(IT,2))
14334 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
14335 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
14338 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
14339 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
14340 IF(MSTP(63).EQ.1) THEN
14342 ELSEIF(MSTP(63).EQ.2) THEN
14343 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
14347 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14348 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
14349 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
14350 PARJ(85)=SQRT(MAX(0D0,DPT2))*
14351 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
14353 C...Only do timelike shower here if using PYSHOW
14354 IF (MSTJ(41).NE.11.AND.MSTJ(41).NE.12) THEN
14355 CALL PYSHOW(IT,0,SQRT(Q2TIM))
14359 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
14362 C...Reconstruct kinematics of branching: timelike parton shower.
14364 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14365 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
14366 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
14367 & (4D0*DSH*DPC(3)**2)
14368 IF(DPT2.LT.0D0) GOTO 100
14369 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
14370 & DSHR)/DPC(3)-DPC(3)
14372 P(IT,3)=DPB(1)*(-1)**(JT+1)
14373 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
14375 DPB(1)=SQRT(DPB(1)**2+DPT2)
14376 DPB(2)=SQRT(DPB(1)**2+DMS)
14378 DPB(4)=SQRT(DPB(3)**2+DMS)
14379 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
14381 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
14382 THE=PYANGL(P(IT,3),P(IT,1))
14383 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
14386 C...Reconstruct kinematics of branching: spacelike parton.
14395 P(N+1,3)=P(IT,3)+P(IS(JT),3)
14396 P(N+1,4)=P(IT,4)+P(IS(JT),4)
14397 P(N+1,5)=-SQRT(DQ2(3))
14401 C...Define colour flow of branching.
14406 C...f -> f + gamma (Z, W).
14407 IF(IABS(K(IT,2)).GE.22) THEN
14411 C...f -> gamma (Z, W) + f.
14412 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
14415 C...gamma -> q + qbar, g + g.
14416 ELSEIF(K(N+1,2).EQ.22) THEN
14422 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
14426 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
14429 C...qbar -> qbar + g.
14430 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
14433 C...qbar -> g + qbar.
14434 ELSEIF(K(N+1,2).LT.0) THEN
14437 C...g -> g + g; g -> q + qbar.
14438 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14445 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
14446 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
14447 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14448 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14449 IF(ID1.NE.ID2) THEN
14450 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14451 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14454 IF(K(IT,1).EQ.1) THEN
14459 C...Boost to new CM-frame.
14460 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
14461 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
14462 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
14463 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
14464 IR=N+(JT-1)*(IS(1)-N)
14465 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
14468 C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
14469 IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN
14472 PTPART(NPART)=SQRT(PARP(71)*DPT2)
14475 C...Global statistics.
14476 MINT(352)=MINT(352)+1
14477 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14478 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14482 C...Update kinematics variables.
14485 IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
14488 C...Save quantities; loop back.
14492 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
14493 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
14494 KFLS(JT+2)=KFLS(JT)
14499 XFS(JT,KFL)=XFA(KFL)
14508 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14509 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
14510 IF(MSTU(21).GE.1) N=NS
14511 IF(MSTU(21).GE.1) RETURN
14513 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
14515 C...Boost hard scattering partons to frame of shower initiators.
14517 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
14523 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
14524 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
14525 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
14527 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
14528 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
14529 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
14531 C...Store user information. Reset Lambda value.
14532 IF(MINT(31).LE.1) THEN
14533 K(IPU1,3)=MINT(83)+3
14534 K(IPU2,3)=MINT(83)+4
14536 K(IPU1,3)=MINT(83)+1
14537 K(IPU2,3)=MINT(83)+2
14540 MINT(12+JT)=KFLS(JT)
14541 VINT(140+JT)=XS(JT)
14542 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
14543 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
14550 C*********************************************************************
14553 C...Generates pT-ordered spacelike initial-state parton showers and
14554 C...trial joinings.
14555 C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14556 C... interaction initiators at PT2NOW.
14557 C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14558 C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14559 C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14560 C... is below PT2CUT.
14561 C... (Also generate test joinings if MSTP(96)=1.)
14562 C...MODE= 1: Accept stored shower branching. Update event record etc.
14563 C...PT2NOW : Starting (max) PT2 scale for evolution.
14564 C...PT2CUT : Lower limit for evolution.
14565 C...PT2 : Result of evolution. Generated PT2 for trial emission.
14566 C...IFAIL : Status return code. IFAIL=0 when all is well.
14568 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14570 C...Double precision and integer declarations.
14571 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14572 IMPLICIT INTEGER(I-N)
14573 INTEGER PYK,PYCHGE,PYCOMP
14574 C...Parameter statement for maximum size of showers.
14575 PARAMETER (MAXNUR=1000)
14577 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14578 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14579 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14580 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14581 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14582 COMMON/PYINT1/MINT(400),VINT(400)
14583 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14584 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14585 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14586 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14587 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14588 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14589 COMMON/PYCTAG/NCT,MCT(4000,2)
14590 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
14591 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
14592 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
14593 C...Local variables
14594 DIMENSION ZSAV(2,240),PT2SAV(2,240),
14595 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
14596 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
14597 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
14598 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
14599 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
14600 C...For check on excessive weights.
14603 C...Only give errors for very large weights, otherwise just warnings
14604 DATA WTEMAX /1.5D0/
14605 C...Only give errors for large pT, otherwise just warnings
14610 C----------------------------------------------------------------------
14611 C...MODE=-1: Initialize initial state showers from scratch, i.e.
14612 C...starting from the hardest interaction initiators.
14613 IF (MODE.EQ.-1) THEN
14614 C...Set hard scattering SHAT.
14616 C...Mass thresholds and Lambda for QCD evolution.
14617 AEM2PI=PARU(101)/PARU(2)
14621 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
14622 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
14623 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
14624 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
14625 C...Optionally use Lambda_MC = Lambda_CMW
14626 IF (MSTP(64).EQ.3) THEN
14627 ALAM5 = ALAM5 * 1.569
14628 ALAM4 = ALAM4 * 1.618
14629 ALAM3 = ALAM3 * 1.661
14633 C...Massive quark forced creation threshold (in M**2).
14635 C...Set upper limit for X (ensures some X left for beam remnant).
14636 XMXC=1D0-2D0*PARP(111)/VINT(1)
14638 IF (MSTP(61).GE.1) THEN
14639 C...Initial values: flavours, momenta, virtualities.
14643 C...Special kinematics check for c/b quarks (that g -> c cbar or
14644 C...b bbar kinematically possible).
14645 KFLB=K(IMI(JS,1,1),2)
14647 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14648 C...Check PT2MAX > mQ^2
14649 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
14650 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14651 & 'No Q creation possible.')
14655 C...Check for physical z values (m == MQ / sqrt(s))
14656 C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14657 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
14658 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
14659 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
14660 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
14671 C...Zero joining array
14677 C----------------------------------------------------------------------
14678 C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14679 C...MINT(30). Store if emission PT2 scale is largest so far.
14680 C...Also generate test joinings if MSTP(96)=1.
14681 ELSEIF(MODE.EQ.0) THEN
14686 C...No shower for structureless beam
14687 IF (MINT(44+JS).EQ.1) RETURN
14690 C...Absolute shower max scale = VINT(56)
14691 PT2=MIN(PT2NOW,VINT(56))
14692 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
14693 C...Define for which processes ME corrections have been implemented.
14694 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
14695 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
14696 & .142.OR.ISUB.EQ.144) MECOR=1
14697 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
14698 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
14699 C...Calculate preweighting factor for ME-corrected processes.
14700 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14702 C...Basic info on daughter for which to find mother.
14703 KFLB=K(IMI(JS,MI,1),2)
14705 C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14706 C...second companion.
14707 KSVCB=MAX(-1,IMI(JS,MI,2))
14708 C...Treat "first" companion of a pair like an ordinary sea quark
14709 C...(except that creation diagram is not allowed)
14710 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
14711 C...X (rescaled to [0,1])
14712 XB=XMI(JS,MI)/VINT(142+JS)
14713 C...Massive quarks (use physical masses.)
14716 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14718 IF (KFLBA.EQ.5) RMQ2=RMB2
14719 C...Special threshold treatment for non-photon beams
14720 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
14723 C...Flags for parton distribution calls.
14724 MINT(105)=MINT(102+JS)
14725 MINT(109)=MINT(106+JS)
14726 VINT(120)=VINT(2+JS)
14729 C.... Store side in MINT(124)
14732 C...Calculate initial parton distribution weights.
14733 IF(XB.GE.XMXC) THEN
14735 ELSEIF(MQMASS.EQ.0) THEN
14736 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14738 C...Initialize massive quark PT2 dependent pdf underestimate.
14740 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
14741 C.!.Tentative treatment of massive valence quarks.
14742 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
14744 TPM0=LOG(PT20/RMQ2)
14747 IF (KFLBA.LE.6) THEN
14748 C...For quarks, only include respective sea, val, or cmp part.
14749 IF (KSVCB.LE.0) THEN
14750 XFB(KFLB)=XPSVC(KFLB,KSVCB)
14752 C...Find companion's companion
14755 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
14759 C...Momentum fraction of the companion quark.
14760 C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
14762 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14766 C...Determine overestimated z range: switch at c and b masses.
14767 130 IF (PT2.GT.TMIN*RMB2) THEN
14769 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
14772 ELSEIF(PT2.GT.TMIN*RMC2) THEN
14774 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
14783 C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
14784 ALAM2=ALAM2/PARP(64)
14785 C...Overestimated ZMAX:
14786 IF (MQMASS.EQ.0) THEN
14788 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
14791 C...Massive (limit for bremsstrahlung diagram > creation)
14792 FMQ=SQRT(RMQ2/SHTNOW(MI))
14797 C...If kinematically impossible then do not evolve.
14798 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
14800 C...Reset Altarelli-Parisi and PDF weights.
14807 C...Zero joining weights and compute X(partner) and X(mother) values.
14808 IF (MSTP(96).NE.0) THEN
14810 DO 150 MJ=1,MINT(31)
14813 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
14814 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
14819 C...Approximate Altarelli-Parisi weights (integrated AP dz).
14820 C...q -> q, g -> q or q -> q + gamma (already set which).
14821 IF(KFLBA.LE.5) THEN
14822 C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
14823 IF (KSVCB.LT.0) THEN
14824 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14826 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
14827 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
14828 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
14830 WTAP(21)=0.5D0*(ZMAX-ZMIN)
14831 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14832 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
14833 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14834 WTAP(KFLB)=WTFF*WTAP(KFLB)
14835 WTAP(21)=WTGF*WTAP(21)
14838 IF (KSVCB.GE.1) THEN
14839 C...Kill normal creation but add joining diagrams for cmp quark.
14841 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14842 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
14843 & " quark here. Not handled yet, giving up!")
14848 C...Check for possible joinings
14849 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
14850 C...Find companion's companion.
14853 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
14854 IF (MJOIND(JS,MJ).EQ.0) THEN
14857 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
14858 IF (WTAPJ(MJ).GT.1D-6) THEN
14864 C...Add trial gluon joinings.
14865 DO 170 MJ=1,MINT(31)
14866 KFLC=K(IMI(JS,MJ,1),2)
14867 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
14868 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14869 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14870 IF (WTAPJ(MJ).GT.1D-6) THEN
14877 ELSEIF (IMI(JS,MI,2).GE.0) THEN
14878 C...Kill creation diagram for val quarks and sea quarks with companions.
14880 ELSEIF (MQMASS.EQ.0) THEN
14881 C...Extra safety factor for massless sea quark creation.
14882 WTAP(21)=WTAP(21)*1.25D0
14885 C... q -> g, g -> g.
14886 ELSEIF(KFLB.EQ.21) THEN
14887 C...Here we decide later whether a quark picked up is valence or
14888 C...sea, so we maintain the extra factor sqrt(z) since we deal
14889 C...with the *sum* of sea and valence in this context.
14890 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
14891 C...new: do not allow backwards evol to pick up heavy flavour.
14892 DO 180 KFL=1,MIN(3,MSTP(58))
14896 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
14897 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14899 WTAP(21)=WTGG*WTAP(21)
14901 C...Check for possible joinings (companions handled separately above)
14902 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
14904 DO 190 MJ=1,MINT(31)
14905 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
14907 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14908 IF (KSVCC.GE.1) GOTO 190
14909 KFLC=K(IMI(JS,MJ,1),2)
14910 C...Only try g -> g + g once.
14911 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
14912 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14913 IF (KFLC.EQ.21) THEN
14914 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14916 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
14918 IF (WTAPJ(MJ).GT.1D-6) THEN
14927 C...Initialize massive quark evolution
14928 IF (MQMASS.NE.0) THEN
14929 RML=(RMQ2+VINT(18))/ALAM2
14931 TPL=LOG((PT2+VINT(18))/ALAM2)
14932 TPM=LOG((PT2+VINT(18))/RMQ2)
14933 WN=WTAP(21)*WPDF0/B0
14937 C...Loopback point for iteration
14941 IF(NTRY.GT.500) THEN
14942 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
14947 C... Calculate PDF weights and sum for evolution rate.
14949 XFBO=MAX(1D-10,XFB(KFLB))
14951 WTPDF(KFL)=XFB(KFL)/XFBO
14952 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
14954 C...Only add gluon mother diagram for massless KFLB.
14955 IF(MQMASS.EQ.0) THEN
14956 WTPDF(21)=XFB(21)/XFBO
14957 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
14959 WTSUM=MAX(0.0001D0,WTSUM)
14961 C...Add joining diagrams where applicable.
14963 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14964 DO 220 MJ=1,MINT(31)
14965 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
14966 WTPDFJ(MJ)=1D0/XFBO
14967 C...x and x*pdf (+ sea/val) for parton C.
14968 KFLC=K(IMI(JS,MJ,1),2)
14970 KSVCC=MAX(-1,IMI(JS,MJ,2))
14971 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14975 C.... Store side in MINT(124)
14978 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14980 IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
14981 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14982 ELSEIF (KSVCC.GE.1) THEN
14983 print*, 'error! parton C is companion!'
14985 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
14986 C...x and x*pdf (+ sea/val) for parton A.
14989 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14992 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14998 C.... Store side in MINT(124)
15001 IF (KSVCA.LE.0) THEN
15002 C...Consider C the "evolved" parton if B is gluon. Val/sea
15003 C...counting will then be done correctly in PYPDFU.
15004 IF (KFLBA.EQ.21) MINT(36)=MJ
15005 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15007 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15009 C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
15010 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
15012 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
15013 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
15017 C...Pick normal pT2 (in overestimated z range).
15020 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
15023 C...Evolve q -> q gamma separately, pick it if larger pT.
15024 IF(KFLBA.LE.5) THEN
15025 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
15026 IF(PT2QED.GT.PT2) THEN
15033 C... Evolve massive quark creation separately.
15035 IF (MQMASS.NE.0) THEN
15036 PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
15038 C... Ensure mininimum PT2CR and force creation near threshold.
15039 IF (PT2CR.LT.TMIN*RMQ2) THEN
15041 IF (NTHRES.GT.50) THEN
15042 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
15043 & 'massive quark creation. Gave up trying.')
15045 C...Special return code if failing before any evolution at all: bad event
15046 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
15053 C... Select largest PT2 (brems or creation):
15054 IF (PT2CR.GT.PT2) THEN
15063 C... Compute logarithms for this PT2
15064 TPL=LOG((PT2+VINT(18))/ALAM2)
15065 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
15066 WTCRQQ=TPM/LOG(PT2/RMQ2)
15069 C...Evolve joining separately
15071 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
15072 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
15074 IF (PT2JN.GE.PT2) THEN
15080 C...Loopback if crossed c/b mass thresholds.
15081 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
15084 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
15089 C...Speed up shower. Skip if higher-PT acceptable branching
15090 C...already found somewhere else.
15091 C...Also finish if below lower cutoff.
15093 IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
15095 C...Select parton A flavour (massive Q handled above.)
15096 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
15100 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
15101 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
15102 IF(KFLA.EQ.6) KFLA=21
15103 ELSEIF (MJOIN.EQ.1) THEN
15104 C...Tentative joining accept/reject.
15105 WTRAN=PYR(0)*WTJOIN
15108 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
15109 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
15110 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
15111 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
15115 C...x*pdf (+ sea/val) at new pT2 for parton B.
15116 IF (KSVCB.LE.0) THEN
15119 C.... Store side in MINT(124)
15122 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
15123 IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
15125 C...Companion distributions do not evolve.
15128 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
15129 KFLC=K(IMI(JS,MJ,1),2)
15131 KSVCC=MAX(-1,IMI(JS,MJ,2))
15132 IF (KSVCB.GE.1) KSVCC=-1
15133 C...x*pdf (+ sea/val) at new pT2 for parton C.
15137 C.... Store side in MINT(124)
15140 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
15142 IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
15143 WTVETO=WTVETO/XFJ(KFLC)
15144 C...x and x*pdf (+ sea/val) at new pT2 for parton A.
15147 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
15150 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15154 IF (KSVCA.LE.0) THEN
15157 C.... Store side in MINT(124)
15160 IF (KFLB.EQ.21) MINT(36)=MJ
15161 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15163 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15165 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
15167 WTVETO=WTVETO*XFJ(KFLA)
15168 C...Monte Carlo veto.
15169 IF (WTVETO.LT.PYR(0)) GOTO 200
15170 C...If accept, save PT2 of this joining.
15171 IF (PT2.GT.PT2MX) THEN
15179 C...Exit and continue evolution.
15184 C...Choose z value (still in overestimated range) and corrective weight.
15185 C...Unphysical z will be rejected below when Q2 has is computed.
15188 C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
15189 C...q -> q + g or q -> q + gamma (already set which).
15190 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
15191 IF (KSVCB.LT.0) THEN
15192 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
15194 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
15195 Z=((1-ZFAC)/(1+ZFAC))**2
15197 WTZ=0.5D0*(1D0+Z**2)
15198 C...Massive weight correction.
15199 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
15200 C...Valence quark weight correction (extra sqrt)
15201 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
15204 C...NB: MQ>0 not yet implemented. Forced absent above.
15205 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
15207 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
15208 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
15211 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
15213 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
15214 WTZ=Z**2+(1D0-Z)**2
15215 C...Massive correction
15216 IF (MQMASS.NE.0) THEN
15217 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
15218 C...Extra safety margin for light sea quark creation
15219 ELSEIF (KSVCB.LT.0) THEN
15224 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15226 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
15227 & (ZMAX*(1D0-ZMIN)))**PYR(0))
15228 WTZ=(1D0-Z*(1D0-Z))**2
15231 C...Derive Q2 from pT2.
15233 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
15235 C...Loopback if outside allowed z range for given pT2.
15236 RM2C=PYMASS(KFLC)**2
15237 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
15238 IF (PT2ADJ.LT.1D-6) GOTO 230
15240 C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
15241 C...No modification for very first emission if using ME correction
15243 IF (MECOR.GE.1.AND.NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) THEN
15247 C...For 1st branching, limit phase space by s-hat with color-partner
15248 IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15251 C...Use anticolor tag for antiquark, or for gluon half the time
15252 IF ((KFLB.LT.0.AND.KFLBA.LT.10).OR.(
15253 & KFLB.EQ.21.AND.PYR(0).GT.0.5)) MSIDE=2
15255 MCTAG=MCT(IDIP,MSIDE)
15256 C...Default is to set up phase space using the opposite incoming parton
15257 JDIP=IMI(3-JS,MI,1)
15259 C...Alternatively, look for final-state color partner (pick first if several)
15261 IF (MCT(IPART(IFS),MSIDE).EQ.MCTAG.AND.NDIP.EQ.0) THEN
15266 C...Compute mass of pair
15267 SDIP=(P(IDIP,4)+P(JDIP,4))**2-(P(IDIP,3)+P(JDIP,3))**2
15268 & -(P(IDIP,2)+P(JDIP,2))**2-(P(IDIP,1)+P(JDIP,1))**2
15269 IF (MSTP67.EQ.1) THEN
15270 C...1 Option to completely kill radiation above s_dip * PARP(67)
15271 IF (4*PT2.GT.PARP(67)*SDIP) GOTO 230
15272 ELSE IF (MSTP67.EQ.2) THEN
15273 C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
15274 C... (-> improved power showers?)
15275 IF (4*PT2*PYR(0).GT.PARP(67)*SDIP) GOTO 230
15278 C...For subsequent branchings, loopback if nonordered in angle/rapidity
15279 ELSE IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
15280 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
15284 C...Select phi angle of branching at random.
15287 C...Matrix-element corrections for some processes.
15288 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15289 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
15290 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15292 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
15293 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15295 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
15296 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15298 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15299 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15304 C...Parton distributions at new pT2 but old x.
15307 C.... Store side in MINT(124)
15310 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
15311 C...Treat val and cmp separately
15312 IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
15314 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
15316 IF(XFBN.LT.1D-20) THEN
15317 IF(KFLA.EQ.KFLB) THEN
15330 C...Parton distributions at new pT2 and new x.
15334 C.... Store side in MINT(124)
15337 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
15338 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
15339 C...q -> q + g: only consider respective sea, val, or cmp content.
15340 IF (KSVCB.LE.0) THEN
15341 XFA(KFLA)=XPSVC(KFLA,KSVCB)
15344 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
15348 IF(XFAN.LT.1D-20) THEN
15352 C...If weighting fails continue evolution.
15354 IF (MCRQQ.EQ.0) THEN
15355 WTPDFA=1D0/WTPDF(KFLA)
15356 WTTOT=WTZ*XFAN/XFBN*WTPDFA
15357 ELSEIF(MCRQQ.EQ.1) THEN
15359 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
15361 ELSEIF(MCRQQ.EQ.2) THEN
15362 C...Force massive quark creation.
15366 C...Loop back if trial emission fails.
15367 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
15368 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
15369 IF(WTTOT.LT.0D0) THEN
15370 WRITE(CHWT,'(1P,E12.4)') WTTOT
15371 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
15372 ELSEIF(WTTOT.GT.WTACC) THEN
15373 WRITE(CHWT,'(1P,E12.4)') WTTOT
15374 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
15375 C...Too high weight: write out as error, but do not update error counter
15376 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
15378 & '(PYPTIS:) Weight '//CHWT//' above unity')
15379 IF (PT2.GT.PTEMAX) PTEMAX=PT2
15380 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
15383 & '(PYPTIS:) Weight '//CHWT//' above unity')
15385 C...Useful for debugging but commented out for distribution:
15386 C print*, 'JS, MI',JS, MI
15387 C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
15388 C print*, 'A -> B C',KFLA, KFLB, KFLC
15390 C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
15393 C...Save acceptable branching.
15394 IF(PT2.GT.PT2MX) THEN
15407 C----------------------------------------------------------------------
15408 C...MODE= 1: Accept stored shower branching. Update event record etc.
15409 ELSEIF (MODE.EQ.1) THEN
15414 C...Shift down rest of event record to make room for insertion.
15419 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
15420 KT1=K(I,4)/MSTU(5)**2
15421 KT2=K(I,5)/MSTU(5)**2
15422 ID1=MOD(K(I,4),MSTU(5))
15423 ID2=MOD(K(I,5),MSTU(5))
15424 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
15425 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
15426 IF (ID1.GE.IT) ID1=ID1+2
15427 IF (ID2.GE.IT) ID2=ID2+2
15428 IF (IM1.GE.IT) IM1=IM1+2
15429 IF (IM2.GE.IT) IM2=IM2+2
15430 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
15431 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
15437 MCT(I+2,1)=MCT(I,1)
15438 MCT(I+2,2)=MCT(I,2)
15441 C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
15442 DO 300 JI=1,MINT(31)
15443 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
15444 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
15445 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
15446 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
15447 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
15448 C...Also update companion pointers to the present mother.
15449 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
15452 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
15454 C...Zero entries dedicated for new timelike and mother partons.
15465 C...Define timelike and new mother partons. History.
15472 C...Set mother origin = side.
15473 K(IM,3)=MINT(83)+JS+2
15474 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
15476 C...Define colour flow of branching.
15479 C...q -> q + gamma.
15480 IF(K(IT,2).EQ.22) THEN
15485 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
15489 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
15492 C...qbar -> qbar + g.
15493 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
15496 C...qbar -> g + qbar.
15497 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
15500 C...g -> g + g; g -> q + qbar..
15501 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
15508 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
15509 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
15510 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
15511 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
15512 IF(ID1.NE.ID2) THEN
15513 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
15514 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
15516 IF(K(IT,1).EQ.1) THEN
15520 C...Update IMI and colour tag arrays.
15528 C...If mother flag not yet set for spacelike parton, trace it.
15529 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
15530 IF(MINT(51).NE.0) RETURN
15534 C...If mother flag not yet set for timelike parton, trace it.
15535 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
15536 IF(MINT(51).NE.0) RETURN
15539 C...Boost recoiling parton to compensate for Q2 scale.
15540 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
15541 & (1D0+(1D0+Q2BMX/SHAT)**2)
15543 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
15545 C...Define system to be rotated and boosted
15546 C...(not including the 2 just added partons)
15547 C...(but including the docu lines for first interaction)
15548 IMIN=IMISEP(MI-1)+1
15549 IF (MI.EQ.1) IMIN=MINT(83)+5
15552 C...Rotate back system in phi to compensate for subsequent rotation.
15553 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
15555 C...Define kinematics of new partons in old frame.
15557 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
15558 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
15559 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
15560 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
15562 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
15563 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
15564 P(IT,5)=SQRT(RM2CMX)
15566 C...Update internal line, now spacelike
15567 P(IS,1)=P(IM,1)-P(IT,1)
15568 P(IS,2)=P(IM,2)-P(IT,2)
15569 P(IS,3)=P(IM,3)-P(IT,3)
15570 P(IS,4)=P(IM,4)-P(IT,4)
15571 P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
15572 C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
15573 IF (P(IS,5).LT.0D0) THEN
15574 P(IS,5)=-SQRT(ABS(P(IS,5)))
15576 P(IS,5)=SQRT(P(IS,5))
15579 C...Boost entire system and rotate to new frame.
15580 C...(including docu lines)
15581 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
15582 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
15583 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
15584 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
15589 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
15591 THETA=PYANGL(P(I1,3),P(I1,1))
15592 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
15594 C...Global statistics.
15595 MINT(352)=MINT(352)+1
15596 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
15597 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
15599 C...Add parton with relevant pT scale for timelike shower.
15600 IF (K(IT,2).NE.22) THEN
15603 PTPART(NPART)=SQRT(PT2AMX)
15606 C...Update saved variables.
15607 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15608 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15609 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15610 PT2SAV(JSMX,MIMX)=PT2MX
15615 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15616 C...Gluon reconstructs to quark.
15617 C...Decide whether newly created quark is valence or sea:
15619 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15620 IF(MINT(51).NE.0) RETURN
15622 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15623 C...Quark reconstructs to gluon.
15624 C...Now some guy may have lost his companion. Check.
15626 IF (ICMP.GT.0) THEN
15627 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15628 & //' away. Cannot handle that yet. Giving up.')
15631 ELSEIF(ICMP.LT.0) THEN
15632 C...A sea quark with companion still in BR was reconstructed to a gluon.
15633 C...Companion should now be removed from the beam remnant.
15634 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15637 DO 380 JCMP=ICMP,NVC(JS,IFL)-1
15638 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15639 DO 370 JI=1,MINT(31)
15641 JFL=-K(IMI(JS,JI,1),2)
15642 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15646 NVC(JS,IFL)=NVC(JS,IFL)-1
15648 C...Set gluon IMI(JS,MI,2) = 0.
15650 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15651 C...Quark reconstructing to quark. If sea with companion still in BR
15652 C...then update associated x value.
15653 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15654 IF (IMI(JS,MI,2).LT.0) THEN
15657 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15663 C...If reached this point, normal exit.
15669 C*********************************************************************
15672 C...Generates maximum ME weight in some initial-state showers.
15673 C...Inparameter MECOR: kind of hard scattering process
15674 C...Outparameter WTFF: maximum weight for fermion -> fermion
15675 C... WTGF: maximum weight for gluon/photon -> fermion
15676 C... WTFG: maximum weight for fermion -> gluon/photon
15677 C... WTGG: maximum weight for gluon -> gluon
15679 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15681 C...Double precision and integer declarations.
15682 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15683 IMPLICIT INTEGER(I-N)
15684 INTEGER PYK,PYCHGE,PYCOMP
15686 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15687 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15688 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15689 COMMON/PYINT1/MINT(400),VINT(400)
15690 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15691 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15693 C...Default maximum weight.
15699 C...Select maximum weight by process.
15700 IF(MECOR.EQ.1) THEN
15703 ELSEIF(MECOR.EQ.2) THEN
15711 C*********************************************************************
15714 C...Calculates actual ME weight in some initial-state showers.
15715 C...Inparameter MECOR: kind of hard scattering process
15716 C... IFLCB: flavour combination of branching,
15717 C... 1 for fermion -> fermion,
15718 C... 2 for gluon/photon -> fermion
15719 C... 3 for fermion -> gluon/photon,
15720 C... 4 for gluon -> gluon
15721 C... Q2: Q2 value of shower branching
15722 C... Z: Z value of branching
15723 C...In+outparameter PHIBR: azimuthal angle of branching
15724 C...Outparameter WTME: actual ME weight
15726 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
15728 C...Double precision and integer declarations.
15729 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15730 IMPLICIT INTEGER(I-N)
15731 INTEGER PYK,PYCHGE,PYCOMP
15733 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15734 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15735 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15736 COMMON/PYINT1/MINT(400),VINT(400)
15737 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15738 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15740 C...Default output.
15743 C...Define kinematics of shower branching in Mandelstam variables.
15747 UH=Q2-SQM*(1D0-Z)/Z
15749 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
15750 IF(MECOR.EQ.1) THEN
15751 IF(IFLCB.EQ.1) THEN
15752 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
15753 ELSEIF(IFLCB.EQ.2) THEN
15754 WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
15757 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
15758 ELSEIF(MECOR.EQ.2) THEN
15759 IF(IFLCB.EQ.3) THEN
15760 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
15761 ELSEIF(IFLCB.EQ.4) THEN
15762 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
15765 C...Matrix-element corrections for q + qbar -> Higgs (h0)
15766 ELSEIF(MECOR.EQ.3) THEN
15767 IF(IFLCB.EQ.2) THEN
15768 WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
15769 1 (SH**2+2D0*SQM*(SQM-SH))
15776 C*********************************************************************
15779 C...Handles the generation of additional interactions in the new
15780 C...multiple interactions framework.
15781 C...MODE=-1 : Initalize MI from scratch.
15782 C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
15783 C... Sudakov for PT2, abort if below PT2CUT.
15784 C...MODE= 1 : Accept interaction at PT2NOW and store variables.
15785 C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
15786 C...PT2NOW : Starting (max) PT2 scale for evolution.
15787 C...PT2CUT : Lower limit for evolution.
15788 C...PT2 : Result of evolution. Generated PT2 for trial interaction.
15789 C...IFAIL : Status return code.
15790 C... = 0: All is well.
15791 C... < 0: Phase space exhausted, generation to be terminated.
15792 C... > 0: Additional interaction vetoed, but continue evolution.
15794 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
15795 C...Double precision and integer declarations.
15796 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15797 IMPLICIT INTEGER(I-N)
15798 INTEGER PYK,PYCHGE,PYCOMP
15799 C...Parameter statement for maximum size of showers.
15800 PARAMETER (MAXNUR=1000)
15802 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15803 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15804 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15805 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15806 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15807 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15808 COMMON/PYINT1/MINT(400),VINT(400)
15809 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15810 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15811 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15812 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15813 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
15814 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
15815 & XMI(2,240),PT2MI(240),IMISEP(0:240)
15816 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
15817 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
15818 COMMON/PYCTAG/NCT,MCT(4000,2)
15819 C...Local arrays and saved variables.
15820 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
15822 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
15823 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
15824 & /PYISMX/,/PYCTAG/
15828 C...Set MI subprocess = QCD 2 -> 2.
15831 C----------------------------------------------------------------------
15832 C...MODE=-1: Initialize from scratch
15833 IF (MODE.EQ.-1) THEN
15834 C...Initialize PT2 array.
15836 C...Initialize list of incoming beams and partons from two sides.
15843 IMI(JS,1,1)=MINT(84)+JS
15845 XMI(JS,1)=VINT(40+JS)
15846 C...Rescale x values to fractions of photon energy.
15847 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
15848 C...Hard reset: hard interaction initiators motherless by definition.
15849 K(MINT(84)+JS,3)=2+JS
15850 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
15851 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
15855 IF (MOD(MSTP(81),10).GE.1) THEN
15856 IF(MSTP(82).LE.1) THEN
15857 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
15859 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
15860 & VINT(317)/(VINT(318)*VINT(320))
15861 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
15863 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
15864 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
15867 C...Zero entries relating to scatterings beyond the first.
15873 IMISEP(MI)=IMISEP(1)
15878 C...Initialize factors for PDF reshaping.
15880 KFBEAM(JS)=MINT(10+JS)
15881 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
15882 KFABM=IABS(KFBEAM(JS))
15883 KFSBM=ISIGN(1,KFBEAM(JS))
15885 C...Zero flavour content of incoming beam particle.
15889 C... Flavour content of baryon.
15890 IF(KFABM.GT.1000) THEN
15891 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
15892 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
15893 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
15894 C... Flavour content of pi+-, K+-.
15895 ELSEIF(KFABM.EQ.211) THEN
15896 KFIVAL(JS,1)=KFSBM*2
15897 KFIVAL(JS,2)=-KFSBM
15898 ELSEIF(KFABM.EQ.321) THEN
15899 KFIVAL(JS,1)=-KFSBM*3
15900 KFIVAL(JS,2)=KFSBM*2
15901 C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
15904 C...Zero initial valence and companion content.
15909 C...Set up colour line tags starting from hard interaction initiators.
15911 C...Reset colour tag array and colour processing flags.
15912 DO 150 I=IMISEP(0)+1,N
15915 K(I,4)=MOD(K(I,4),MSTU(5)**2)
15916 K(I,5)=MOD(K(I,5),MSTU(5)**2)
15918 C... Consider each side in turn.
15923 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15925 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
15927 CALL PYCTTR(I1,KCS,I2)
15928 IF(MINT(51).NE.0) RETURN
15932 C...Range checking for companion quark pdf large-x param.
15933 IF (MSTP(87).LT.0) THEN
15934 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15937 ELSEIF (MSTP(87).GT.4) THEN
15938 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15943 C----------------------------------------------------------------------
15944 C...MODE=0: Generate trial interaction. Return codes:
15945 C...IFAIL < 0: Phase space exhausted, generation to be terminated.
15946 C...IFAIL = 0: Additional interaction generated at PT2.
15947 C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
15948 ELSEIF (MODE.EQ.0) THEN
15949 C...Abolute MI max scale = VINT(62)
15950 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
15951 180 IF(MSTP(82).LE.1) THEN
15952 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
15953 IF(XT2.LT.VINT(149)) IFAIL=-2
15955 IF(XT2.LE.0.01001D0*VINT(149)) THEN
15958 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
15959 & LOG(PYR(0)))-VINT(149)
15962 C...Also exit if below lower limit or if higher trial branching
15964 PT2=0.25D0*VINT(2)*XT2
15965 IF (PT2.LE.PT2CUT) IFAIL=-4
15966 IF (PT2.LE.PT2MX) IFAIL=-5
15967 IF (IFAIL.NE.0) THEN
15971 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
15972 VINT(25)=4D0*PT2/VINT(2)
15975 C...Choose tau and y*. Calculate cos(theta-hat).
15976 IF(PYR(0).LE.COEF(ISUB,1)) THEN
15977 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
15978 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
15980 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
15983 C...New: require shat > 1.
15984 IF(TAU*VINT(2).LT.1D0) GOTO 180
15988 IF(RYST.GT.COEF(ISUB,8)) MYST=2
15989 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
15990 CALL PYKMAP(2,MYST,PYR(0))
15991 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
15993 C...Check that x not used up. Accept or reject kinematical variables.
15994 X1M=SQRT(TAU)*EXP(VINT(22))
15995 X2M=SQRT(TAU)*EXP(-VINT(22))
15996 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
15997 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
15998 CALL PYSIGH(NCHN,SIGS)
15999 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
16000 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
16001 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
16003 C...Save if highest PT so far.
16004 IF (PT2.GT.PT2MX) THEN
16010 C----------------------------------------------------------------------
16011 C...MODE=1: Generate and save accepted scattering.
16012 ELSEIF (MODE.EQ.1) THEN
16014 C...Reset K, P, V, and MCT vectors.
16026 C...Choose flavour of reacting partons (and subprocess).
16028 IF (NTRY.GT.50) THEN
16029 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
16030 & //'interaction. Giving up!')
16038 ICONMI=ISIG(ICHN,3)
16039 RSIGS=RSIGS-SIGH(ICHN)
16040 IF(RSIGS.LE.0D0) GOTO 230
16043 C...Reassign to appropriate process codes.
16044 230 ISUBMI=ICONMI/10
16045 ICONMI=MOD(ICONMI,10)
16047 C...Choose new quark flavour for annihilation graphs
16048 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
16049 SH=VINT(21)*VINT(2)
16050 CALL PYWIDT(21,SH,WDTP,WDTE)
16051 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
16052 DO 250 I=1,MDCY(21,3)
16053 KFLF=KFDP(I+MDCY(21,2)-1,1)
16054 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
16055 IF(RKFL.LE.0D0) GOTO 260
16057 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
16058 IF(KFLF.GE.4) GOTO 240
16059 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
16062 ELSEIF(ISUBMI.EQ.53) THEN
16068 C...Final state flavours and colour flow: default values
16075 IF(ISUBMI.EQ.11) THEN
16076 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
16078 IF(KFL1*KFL2.LT.0) KCC=KCC+2
16080 ELSEIF(ISUBMI.EQ.12) THEN
16081 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
16082 KFL3=ISIGN(KFLF,KFL1)
16086 ELSEIF(ISUBMI.EQ.13) THEN
16087 C...f + fbar -> g + g; th arbitrary
16092 ELSEIF(ISUBMI.EQ.28) THEN
16093 C...f + g -> f + g; th = (p(f)-p(f))**2
16094 IF(KFL1.EQ.21) JS=2
16096 IF(KFL1.EQ.21) KCC=KCC+2
16097 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
16098 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
16100 ELSEIF(ISUBMI.EQ.53) THEN
16101 C...g + g -> f + fbar; th arbitrary
16102 KCS=(-1)**INT(1.5D0+PYR(0))
16103 KFL3=ISIGN(KFLF,KCS)
16107 ELSEIF(ISUBMI.EQ.68) THEN
16108 C...g + g -> g + g; th arbitrary
16110 KCS=(-1)**INT(1.5D0+PYR(0))
16113 C...Check that massive sea quarks have non-zero phase space for g -> Q Q
16114 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
16115 & .OR.IABS(KFL4).EQ.5) THEN
16116 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
16117 IF (PT2.LE.1.05*RMMAX2) THEN
16118 IF (NTRY.EQ.2) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
16119 & //' too close to threshold (2nd try).')
16124 C...Store flavours of scattering.
16132 C...Set flavours and mothers of scattering partons.
16141 K(N+1,3)=MINT(83)+1
16142 K(N+2,3)=MINT(83)+2
16146 C...Store colour connection indices.
16149 IF(KCS.EQ.-1) JC=3-J
16150 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
16151 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
16152 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
16153 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
16156 C...Store incoming and outgoing partons in their CM-frame.
16157 SHR=SQRT(VINT(21))*VINT(1)
16160 P(N+2,3)=-0.5D0*SHR
16162 P(N+3,5)=PYMASS(K(N+3,2))
16163 P(N+4,5)=PYMASS(K(N+4,2))
16164 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
16168 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
16169 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
16170 P(N+4,4)=SHR-P(N+3,4)
16173 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
16175 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
16177 C...Global statistics.
16178 MINT(351)=MINT(351)+1
16179 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
16180 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
16182 C...Keep track of loose colour ends and information on scattering.
16183 MINT(31)=MINT(31)+1
16185 PT2MI(MINT(36))=PT2
16186 IMISEP(MINT(31))=N+4
16188 IMI(JS,MINT(31),1)=N+JS
16189 IMI(JS,MINT(31),2)=0
16190 XMI(JS,MINT(31))=VINT(40+JS)
16192 C...Update cumulative counters
16193 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
16194 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
16197 C...Add to list of final state partons
16200 PTPART(NPART+1)=SQRT(PT2)
16201 PTPART(NPART+2)=SQRT(PT2)
16205 NISGEN(1,MINT(31))=0
16206 NISGEN(2,MINT(31))=0
16210 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
16211 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
16216 C...Finally, assign colour tags to new partons
16218 I1=IMI(JS,MINT(31),1)
16219 I2=IMI(3-JS,MINT(31),1)
16221 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
16223 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
16225 CALL PYCTTR(I1,KCS,I2)
16226 IF(MINT(51).NE.0) RETURN
16230 C----------------------------------------------------------------------
16231 C...MODE=2: Decide whether quarks in last scattering were valence,
16232 C...companion, or sea.
16233 ELSEIF (MODE.EQ.2) THEN
16237 KFSBM=ISIGN(1,MINT(10+JS))
16238 IFL=K(IMI(JS,MI,1),2)
16240 IF (IABS(IFL).GE.6) THEN
16241 IF (IABS(IFL).EQ.6) THEN
16242 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
16246 C...Get PDFs at X(rescaled) and PT2 of the current initiator.
16247 C...(Do not include the parton itself in the X rescaling.)
16249 XRSC=X/(VINT(142+JS)+X)
16250 C...Note: XPSVC = x*pdf.
16253 C.... Store side in MINT(124)
16256 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
16259 C...Ensure that pdfs are positive definite
16260 IF (SEA.LT.0D0) THEN
16261 CALL PYERRM(9,'(PYPTMI:) Sea distribution negative.')
16263 ELSEIF (VAL.LT.0D0) THEN
16264 CALL PYERRM(9,'(PYPTMI:) Val distribution negative.')
16268 DO 310 IVC=1,NVC(JS,IFL)
16269 CMP=CMP+XPSVC(IFL,IVC)
16273 C...Decide (Extra factor x cancels in the dvision).
16274 320 RVCS=PYR(0)*(SEA+VAL+CMP)
16277 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
16278 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
16280 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
16281 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
16282 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
16283 IF(KFIVAL(JS,1).EQ.0) THEN
16284 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
16285 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
16286 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
16287 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
16289 C...Count down valence remaining. Do not count current scattering.
16290 DO 340 I1=1,NMI(JS)
16291 IF (I1.EQ.MINT(36)) GOTO 340
16292 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
16296 IF(IVNOW.EQ.0) GOTO 330
16299 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
16300 IF(KFIVAL(JS,1).EQ.0) THEN
16301 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
16304 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
16306 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
16307 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
16311 ELSEIF (RVCS.LE.VAL+SEA) THEN
16312 C...If sea, add opposite sign companion parton. Store X and I.
16313 NVC(JS,-IFL)=NVC(JS,-IFL)+1
16314 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
16315 C...Set pointer to companion
16316 IMI(JS,MI,2)=-NVC(JS,-IFL)
16319 C...If companion, check whether we've got any in the books
16320 IF (NVC(JS,IFL).EQ.0) THEN
16322 C...Only report error first time for this event
16324 & CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
16325 C...Try a few times
16326 IF (NTRY.LE.10) THEN
16328 C... But if it stil fails, abort this event
16334 C...If several possibilities, decide which one
16338 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
16339 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
16340 C...Find original sea (anti-)quark. Do not consider current scattering.
16342 DO 360 I1=1,NMI(JS)
16343 IF (I1.EQ.MINT(36)) GOTO 360
16344 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
16345 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
16346 IMI(JS,MI,2)=IMI(JS,I1,1)
16347 IMI(JS,I1,2)=IMI(JS,MI,1)
16350 C...Mark companion "out-kicked".
16351 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
16358 C*********************************************************************
16360 C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
16361 C...Giving the x*f pdf of a companion quark, with its partner at XS,
16362 C...using an approximate gluon density like (1-X)^NPOW/X. The value
16363 C...corresponds to an unrescaled range between 0 and 1-X.
16365 FUNCTION PYFCMP(XC,XS,NPOW)
16367 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
16371 C...Parent gluon momentum fraction
16373 IF (Y.GE.1D0) RETURN
16374 C...Common factor (includes factor XC, since PYFCMP=x*f)
16375 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
16376 C...Store normalized companion x*f distribution.
16377 IF (NPOW.LE.0) THEN
16378 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
16379 ELSEIF (NPOW.EQ.1) THEN
16380 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
16381 ELSEIF (NPOW.EQ.2) THEN
16382 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
16383 & +3D0*XS*(1D0+XS)*LOG(XS)))
16384 ELSEIF (NPOW.EQ.3) THEN
16385 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
16386 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16387 ELSEIF (NPOW.GE.4) THEN
16388 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
16389 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
16394 C*********************************************************************
16396 C...PYPCMP: Auxiliary to PYPDFU.
16397 C...Giving the momentum integral of a companion quark, with its
16398 C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
16399 C...The value corresponds to an unrescaled range between 0 and 1-XS.
16401 FUNCTION PYPCMP(XS,NPOW)
16403 DOUBLE PRECISION XS, PYPCMP
16405 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
16407 ELSEIF (NPOW.LE.0) THEN
16408 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
16409 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
16410 ELSEIF (NPOW.EQ.1) THEN
16411 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
16412 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
16413 ELSEIF (NPOW.EQ.2) THEN
16414 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
16415 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
16416 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
16417 & -3D0*XS*LOG(XS)*(1+XS)))
16418 ELSEIF (NPOW.EQ.3) THEN
16419 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
16420 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
16421 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
16422 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16424 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
16425 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
16426 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
16427 & -6D0*XS*LOG(XS)*(1D0+XS)))
16432 C*********************************************************************
16435 C...Rearranges contents of the HEPEUP commonblock so that
16436 C...mothers precede daughters and daughters of a decay are
16437 C...listed consecutively.
16441 C...Double precision and integer declarations.
16442 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16443 IMPLICIT INTEGER(I-N)
16445 C...User process event common block.
16447 PARAMETER (MAXNUP=500)
16448 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
16449 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
16450 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
16451 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
16452 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
16456 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
16457 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
16458 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
16460 C...Check whether a rearrangement is required.
16463 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
16466 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
16470 C...Find the new order that particles should have.
16476 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
16481 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
16482 IF(NNEW.NE.NUP) THEN
16484 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
16488 C...Copy old info into temporary storage.
16492 MOTUPT(1,I)=MOTHUP(1,I)
16493 MOTUPT(2,I)=MOTHUP(2,I)
16494 ICOUPT(1,I)=ICOLUP(1,I)
16495 ICOUPT(2,I)=ICOLUP(2,I)
16499 VTIUPT(I)=VTIMUP(I)
16500 SPIUPT(I)=SPINUP(I)
16503 C...Copy info back into HEPEUP in right order.
16506 IDUP(I)=IDUPT(IOLD)
16507 ISTUP(I)=ISTUPT(IOLD)
16511 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
16512 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
16514 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
16516 MOTHUP(1,I)=MOTHUP(2,I)
16519 ICOLUP(1,I)=ICOUPT(1,IOLD)
16520 ICOLUP(2,I)=ICOUPT(2,IOLD)
16522 PUP(J,I)=PUPT(J,IOLD)
16524 VTIMUP(I)=VTIUPT(IOLD)
16525 SPINUP(I)=SPIUPT(IOLD)
16529 c...If incoming particles are massive recalculate to put them massless.
16530 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
16531 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
16532 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
16533 PUP(4,1)=0.5D0*PPLUS
16536 PUP(4,2)=0.5D0*PMINUS
16544 C*********************************************************************
16547 C...Administers the generation of successive final-state showers
16548 C...in external processes.
16550 SUBROUTINE PYADSH(NFIN)
16552 C...Double precision and integer declarations.
16553 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16554 IMPLICIT INTEGER(I-N)
16555 INTEGER PYK,PYCHGE,PYCOMP
16556 C...Parameter statement for maximum size of showers.
16557 PARAMETER (MAXNUR=1000)
16559 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16560 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16561 COMMON/PYCTAG/NCT,MCT(4000,2)
16562 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16563 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16564 COMMON/PYINT1/MINT(400),VINT(400)
16565 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
16567 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
16569 C...Set primary vertex.
16571 V(MINT(83)+5,J)=0D0
16572 V(MINT(83)+6,J)=0D0
16573 V(MINT(84)+1,J)=0D0
16574 V(MINT(84)+2,J)=0D0
16577 C...Isolate systems of particles with the same mother.
16580 DO 140 I=MINT(84)+3,NFIN
16582 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
16589 C...Set production vertices.
16590 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
16597 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
16600 IF(MSTP(125).GE.1) THEN
16608 C...End loop over systems. Return if no showers to be performed.
16609 IBEG(NSYS+1)=NFIN+1
16610 IF(MSTP(71).LE.0) RETURN
16612 C...Loop through systems of particles; check that sensible size.
16614 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
16615 IF(MINT(35).LE.2) THEN
16616 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
16618 ELSEIF(NSIZ.LE.1) THEN
16619 CALL PYERRM(2,'(PYADSH:) only one particle in system')
16621 ELSEIF(NSIZ.GT.80) THEN
16622 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
16627 C...Save status codes and daughters of showering particles; reset them.
16634 IF(K(I,1).GT.10) THEN
16636 IF(KSAV(II,1).EQ.14) K(I,1)=3
16638 IF(KSAV(II,1).LE.10) THEN
16639 ELSEIF(K(I,1).EQ.1) THEN
16645 KSAV(II,4)=MOD(K(I,4),MSTU(5))
16646 KSAV(II,5)=MOD(K(I,5),MSTU(5))
16647 K(I,4)=K(I,4)-KSAV(II,4)
16648 K(I,5)=K(I,5)-KSAV(II,5)
16651 PSUM(J)=PSUM(J)+P(I,J)
16655 C...Perform shower.
16656 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16658 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16660 IF(MINT(35).LE.2) THEN
16662 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16664 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16667 C...For external processes, first call, also ISR partons radiate.
16668 C...Can use existing PYPART list, removing partons that radiate later.
16669 ELSEIF(ISYS.EQ.1) THEN
16672 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16674 IPART(NPARTN)=IPART(II)
16675 PTPART(NPARTN)=PTPART(II)
16679 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16681 C...For subsequent calls use the systems excluded above.
16687 PTPART(II)=0.5D0*QMAX
16689 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16692 C...Look up showered copies of original showering particles.
16696 C...Particles without daughters need not be studied.
16697 IF(KSAV(II,1).LE.10) GOTO 260
16698 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16699 ELSEIF(K(I,1).EQ.11) THEN
16700 190 IMV=MOD(K(IMV,4),MSTU(5))
16701 IF(K(IMV,1).EQ.11) GOTO 190
16703 KDA1=MOD(K(I,4),MSTU(5))
16705 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16707 KDA2=MOD(K(I,5),MSTU(5))
16709 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16712 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
16715 KDA1=MOD(K(I3,4),MSTU(5))
16717 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16719 KDA2=MOD(K(I3,5),MSTU(5))
16721 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16727 C...Restore daughter info of original partons to showered copies.
16728 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
16729 IF(KSAV(II,1).LE.10) THEN
16730 ELSEIF(K(I,1).EQ.1) THEN
16731 K(IMV,4)=KSAV(II,4)
16732 K(IMV,5)=KSAV(II,5)
16734 K(IMV,4)=K(IMV,4)+KSAV(II,4)
16735 K(IMV,5)=K(IMV,5)+KSAV(II,5)
16738 C...Reset mother info of existing daughters to showered copies.
16739 DO 210 I3=IBEG(ISYS+1),NFIN
16740 IF(K(I3,3).EQ.I) K(I3,3)=IMV
16741 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
16742 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
16743 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
16747 C...Boost all original daughters to new frame of showered copy.
16748 C...Also update their colour tags.
16751 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
16753 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
16755 BETA(J)=FAC*BETA(J)
16757 DO 250 I3=IBEG(ISYS+1),NFIN
16760 IF(MSTP(128).LE.0) THEN
16761 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
16762 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
16764 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16765 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16766 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16769 IF(IMO.EQ.IMV) THEN
16770 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16771 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16772 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16773 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
16781 C...End of loop over showering systems
16787 C*********************************************************************
16790 C...Interface to UPVETO, which allows user to veto event generation
16791 C...on the parton level, after parton showers but before multiple
16792 C...interactions, beam remnants and hadronization is added.
16794 SUBROUTINE PYVETO(IVETO)
16796 C...All real arithmetic in double precision.
16797 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16798 C...Three Pythia functions return integers, so need declaring.
16799 INTEGER PYK,PYCHGE,PYCOMP
16801 C...PYTHIA commonblocks.
16802 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16803 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16804 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16805 COMMON/PYINT1/MINT(400),VINT(400)
16806 SAVE /PYJETS/,/PYPARS/,/PYINT1/
16807 C...HEPEVT commonblock.
16808 PARAMETER (NMXHEP=4000)
16809 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16810 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
16811 DOUBLE PRECISION PHEP,VHEP
16814 DIMENSION IRESO(100)
16816 C...Define longitudinal boost from initiator rest frame to cm frame.
16817 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
16818 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
16820 C...Presentation is different if using pT-ordered shower
16821 IF(MINT(35).EQ.3) THEN
16826 C... Reset counters.
16831 C...Oth pass: identify beam and incoming partons
16832 DO 140 I=MINT(83)+1,MINT(83)+6
16834 IF(K(I,2).EQ.94) THEN
16843 C...First pass: identify final locations of resonances
16844 C...and of their daughters before showering.
16845 DO 150 I=MINT(84)+3,N
16849 C...Skip shower CM frame documentation lines.
16850 IF(K(I,2).EQ.94) THEN
16852 C... Store a new intermediate product, when mother in documentation.
16853 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
16854 & K(I,3).LE.MINT(84)) THEN
16860 IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
16862 C... Store a new intermediate product, when mother in main section.
16863 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
16864 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
16870 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
16873 IF(ISTORE.EQ.1) THEN
16874 C...Copy parton info, boosting momenta along z axis to cm frame.
16879 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16880 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16882 C...Store one mother. Rest of history and vertex info zeroed.
16894 C...Second pass: identify current set of "final" partons.
16895 DO 200 I=MINT(84)+3,N
16899 C...Store a final parton.
16900 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
16904 C..Trace it back through shower, to check if from documented particle.
16908 IF(IHIST.GT.MINT(84)) THEN
16909 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
16911 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
16915 IF(IMOTH.EQ.0) GOTO 160
16916 IMOTH=MAX(0,IMOTH-6)
16917 ELSEIF(IHIST.LE.4) THEN
16918 IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
16927 IF(ISTORE.EQ.1) THEN
16928 C...Copy parton info, boosting momenta along z axis to cm frame.
16933 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16934 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16936 C...Store one mother. Rest of history and vertex info zeroed.
16947 C...Call user-written routine to decide whether to keep events.
16951 C*********************************************************************
16954 C...Allows resonances to decay (including parton showers for hadronic
16957 SUBROUTINE PYRESD(IRES)
16959 C...Double precision and integer declarations.
16960 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16961 IMPLICIT INTEGER(I-N)
16962 INTEGER PYK,PYCHGE,PYCOMP
16963 C...Parameter statement to help give large particle numbers.
16964 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16965 &KEXCIT=4000000,KDIMEN=5000000)
16966 C...Parameter statement for maximum size of showers.
16967 PARAMETER (MAXNUR=1000)
16969 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16970 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16971 COMMON/PYCTAG/NCT,MCT(4000,2)
16972 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16973 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16974 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16975 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16976 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16977 COMMON/PYINT1/MINT(400),VINT(400)
16978 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16979 COMMON/PYINT4/MWID(500),WIDS(500,5)
16980 COMMON/PYPUED/IUED(0:99),RUED(0:99)
16981 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
16982 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/
16983 C...Local arrays and complex and character variables.
16984 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
16985 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
16986 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
16987 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
16988 &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(3),ITRI(3),IOCT(3)
16989 COMPLEX FGK,HA(6,6),HC(6,6)
16991 CHARACTER CODE*9,MASS*9
16993 C...The F, Xi and Xj functions of Gunion and Kunszt
16994 C...(Phys. Rev. D33, 665, plus errata from the authors).
16995 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
16996 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
16997 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
16998 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
16999 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
17000 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
17001 &2D0*(D34/D56+D56/D34))
17003 C...Some general constants.
17006 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
17010 GMMZ=PMAS(23,1)*PMAS(23,2)
17012 GMMW=PMAS(24,1)*PMAS(24,2)
17015 C...Boost and rotate to rest frame of incoming partons,
17016 C...to get proper amount of smearing of decay angles.
17022 C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons
17023 C...(101,102) are off shell and can have inconsistent momenta, resulting
17024 C...in boosts larger than unity. However, the corresponding docu partons
17025 C...(5,6) are kept on shell, and have consistent momenta that can be used
17026 C...to derive this boost instead. Ultimately, should change the way the new
17027 C...shower stores intermediate partons, but just using partons (5,6) for now
17028 C...does define the boost and furnishes a quick and much needed solution.
17029 IF (MINT(35).EQ.3) THEN
17033 ETOTIN=P(IIN1,4)+P(IIN2,4)
17034 BEXIN=(P(IIN1,1)+P(IIN2,1))/ETOTIN
17035 BEYIN=(P(IIN1,2)+P(IIN2,2))/ETOTIN
17036 BEZIN=(P(IIN1,3)+P(IIN2,3))/ETOTIN
17037 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
17038 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
17039 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
17040 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
17041 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
17044 C...Reset original resonance configuration.
17049 C...Define initial one, two or three objects for subprocess.
17053 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
17054 IREF(1,1)=MINT(84)+2+ISET(ISUB)
17055 IREF(1,4)=MINT(83)+6+ISET(ISUB)
17057 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
17058 IREF(1,1)=MINT(84)+1+ISET(ISUB)
17059 IREF(1,2)=MINT(84)+2+ISET(ISUB)
17060 IREF(1,4)=MINT(83)+5+ISET(ISUB)
17061 IREF(1,5)=MINT(83)+6+ISET(ISUB)
17063 ELSEIF(ISET(ISUB).EQ.5) THEN
17064 IREF(1,1)=MINT(84)+3
17065 IREF(1,2)=MINT(84)+4
17066 IREF(1,3)=MINT(84)+5
17067 IREF(1,4)=MINT(83)+7
17068 IREF(1,5)=MINT(83)+8
17069 IREF(1,6)=MINT(83)+9
17073 C...Define original resonance for odd cases.
17076 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
17078 IF(IHDEC.EQ.1) ISUB=3
17080 IREF(1,4)=K(IRES,3)
17082 IF(IREF(1,4).GT.MINT(84)) THEN
17083 110 ITMPMO=IREF(1,4)
17084 IF(K(ITMPMO,2).EQ.94) THEN
17085 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
17086 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
17087 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
17089 C...Explicitly check that reference particle exists, otherwise stop recursion
17090 IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
17091 IREF(1,4)=K(ITMPMO,3)
17096 IF(IREF(1,4).GT.MINT(84)) THEN
17099 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
17100 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
17103 EMATCH=ABS(P(II,4)-P(IREF14,4))
17110 C...Check if initial resonance has been moved (in resonance + jet).
17112 IF(IREF(1,JT).GT.0) THEN
17113 IF(K(IREF(1,JT),1).GT.10) THEN
17114 KFA=IABS(K(IREF(1,JT),2))
17115 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
17116 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17117 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17118 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17119 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17121 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17122 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17124 DO 130 I=IREF(1,JT)+1,N
17125 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
17128 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17129 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17130 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17131 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17133 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17134 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17139 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
17140 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
17146 C...Set decay vertex for initial resonances
17149 V(IREF(1,JT),I)=0D0
17153 C...Loop over decay history.
17159 IF(IREF(IP,2).EQ.0) JTMAX=1
17160 IF(IREF(IP,3).NE.0) JTMAX=3
17164 C...Check for Higgs which appears as decay product of user-process.
17167 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17169 IF(IHDEC.EQ.1) ISUB=3
17172 C...Start treatment of one, two or three resonances in parallel.
17184 C...Check whether particle can/is allowed to decay.
17185 IF(ID.EQ.0) GOTO 330
17188 IF(MWID(KCA).EQ.0) GOTO 330
17189 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
17190 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
17191 & KFA.EQ.18) IT4=IT4+1
17192 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
17193 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
17195 C...Choose lifetime and determine decay vertex.
17196 IF(K(ID,1).EQ.5) THEN
17198 ELSEIF(K(ID,1).NE.4) THEN
17199 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
17202 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
17205 C...Determine whether decay allowed or not.
17207 IF(MSTJ(22).EQ.2) THEN
17208 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
17209 ELSEIF(MSTJ(22).EQ.3) THEN
17210 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
17211 ELSEIF(MSTJ(22).EQ.4) THEN
17212 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
17213 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
17215 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
17220 C...Info for selection of decay channel: sign, pairings.
17221 IF(KCHG(KCA,3).EQ.0) THEN
17224 IPM=(5-ISIGN(1,K(ID,2)))/2
17227 IF(JTMAX.EQ.2) THEN
17228 KFB=IABS(K(IREF(IP,3-JT),2))
17229 ELSEIF(JTMAX.EQ.3) THEN
17231 KFB=IABS(K(IREF(IP,JT2),2))
17232 IF(KFB.NE.KFA) THEN
17233 JT2=JT+2-3*((JT+1)/3)
17234 KFB=IABS(K(IREF(IP,JT2),2))
17238 C...Select decay channel.
17239 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
17240 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
17241 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
17242 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
17243 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
17244 IF(WDTE0S.LE.0D0) GOTO 330
17248 IDC=IDL+MDCY(KCA,2)-1
17249 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
17250 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
17251 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
17253 C...Read out flavours and colour charges of decay channel chosen.
17254 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
17255 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
17256 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
17257 KFC1A=PYCOMP(IABS(KFL1(JT)))
17258 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
17259 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
17260 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
17261 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
17262 KFC2A=PYCOMP(IABS(KFL2(JT)))
17263 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
17264 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
17265 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
17266 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
17268 IF(KFL3(JT).NE.0) THEN
17269 KFC3A=PYCOMP(IABS(KFL3(JT)))
17270 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
17271 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
17272 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
17275 C...Set/save further info on channel.
17277 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
17279 HGZ(JT,1)=VINT(111)
17280 HGZ(JT,2)=VINT(112)
17281 HGZ(JT,3)=VINT(114)
17284 C...Select masses; to begin with assume resonances narrow.
17289 KFLW=IABS(KFL1(JT))
17291 ELSEIF(I.EQ.2) THEN
17292 KFLW=IABS(KFL2(JT))
17294 ELSEIF(I.EQ.3) THEN
17295 IF(KFL3(JT).EQ.0) GOTO 220
17296 KFLW=IABS(KFL3(JT))
17299 P(N+I,5)=PMAS(KCW,1)
17301 C...This prevents SUSY/t particles from becoming too light.
17302 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
17303 PMMN(I)=PMAS(KCW,1)
17304 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
17305 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
17306 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
17307 & PMAS(PYCOMP(KFDP(IDC,2)),1)
17308 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
17309 & PMAS(PYCOMP(KFDP(IDC,3)),1)
17310 PMMN(I)=MIN(PMMN(I),PMSUM)
17314 ELSEIF(KFLW.EQ.6) THEN
17315 PMMN(I)=PMAS(24,1)+PMAS(5,1)
17317 C...UED: select a graviton mass from continuous distribution
17318 C...(stored in PMAS(39,1) so no value returned)
17319 IF (IUED(1).EQ.1.AND.IUED(2).EQ.1.AND.KFLW.EQ.39)
17323 C...Check which two out of three are widest.
17326 PWID1=PMAS(KFC1A,2)
17327 PWID2=PMAS(KFC2A,2)
17328 KFLW1=IABS(KFL1(JT))
17329 KFLW2=IABS(KFL2(JT))
17330 IF(KFL3(JT).NE.0) THEN
17331 PWID3=PMAS(KFC3A,2)
17332 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
17335 KFLW1=IABS(KFL3(JT))
17336 ELSEIF(PWID3.GT.PWID2) THEN
17339 KFLW2=IABS(KFL3(JT))
17343 C...If all narrow then only check that masses consistent.
17344 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
17345 & PWID2.LT.PARP(41))) THEN
17347 C....Handle near degeneracy cases.
17348 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
17349 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17350 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
17351 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
17355 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17356 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
17359 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
17360 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
17365 C...For three wide resonances select narrower of three
17366 C...according to BW decoupled from rest.
17369 IF(KFL3(JT).NE.0) THEN
17370 IWID3=6-IWID1-IWID2
17371 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
17375 P(N+IWID3,5)=PYMASS(KFLW3)
17376 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
17377 PMTOT=PMTOT-P(N+IWID3,5)
17379 C...Select other two correlated within remaining phase space.
17383 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
17384 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
17385 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17390 CKIN(49)=PMMN(IWID1)
17391 CKIN(50)=PMMN(IWID2)
17392 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17397 IF(MINT(51).EQ.1) GOTO 720
17400 C...Begin fill decay products, with colour flow for coloured objects.
17405 C...Three-body decays
17406 IF(KFL3(JT).NE.0) THEN
17423 C...Generate kinematics (default is flat)
17426 C...Set generic colour flows whenever unambiguous,
17427 C...(independently of the order of the decay products)
17428 C...Sum up total colour content
17437 IF (KCQ(J).EQ.-1) THEN
17440 ELSEIF (KCQ(J).EQ.1) THEN
17443 ELSEIF (KCQ(J).EQ.2) THEN
17449 C...Set color flow for generic 1 -> N processes (N arbitrary)
17450 IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
17451 C...All singlets: do nothing
17453 ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
17454 C...Two octets, zero triplets, n singlets:
17455 IF (KCQ(0).EQ.2) THEN
17457 K(ID,4)=K(ID,4)+IOCT(2)
17458 K(ID,5)=K(ID,5)+IOCT(2)
17460 K(IOCT(2),4)=MSTU(5)*ID
17461 K(IOCT(2),5)=MSTU(5)*ID
17462 MCT(IOCT(2),1)=MCT(ID,1)
17463 MCT(IOCT(2),2)=MCT(ID,2)
17465 C...1 -> 8 + 8 + n(1)
17467 K(IOCT(1),4)=MSTU(5)*IOCT(2)
17468 K(IOCT(1),5)=MSTU(5)*IOCT(2)
17470 K(IOCT(2),4)=MSTU(5)*IOCT(1)
17471 K(IOCT(2),5)=MSTU(5)*IOCT(1)
17480 ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
17481 C...Two triplets, zero octets, n singlets.
17482 IF (KCQ(0).EQ.1) THEN
17484 K(ID,4)=K(ID,4)+ITRI(2)
17486 K(ITRI(2),4)=MSTU(5)*ID
17487 MCT(ITRI(2),1)=MCT(ID,1)
17488 ELSEIF (KCQ(0).EQ.-1) THEN
17489 C...3bar -> 3bar + n(1)
17490 K(ID,5)=K(ID,5)+IANT(2)
17492 K(IANT(2),5)=MSTU(5)*ID
17493 MCT(IANT(2),2)=MCT(ID,2)
17495 C...1 -> 3 + 3bar + n(1)
17497 K(ITRI(1),4)=MSTU(5)*IANT(1)
17499 K(IANT(1),5)=MSTU(5)*ITRI(1)
17505 ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
17506 C...Two triplets, one octet, n singlets.
17507 IF (KCQ(0).EQ.2) THEN
17508 C...8 -> 3 + 3bar + n(1)
17509 K(ID,4)=K(ID,4)+ITRI(1)
17510 K(ID,5)=K(ID,5)+IANT(1)
17512 K(ITRI(1),4)=MSTU(5)*ID
17514 K(IANT(1),5)=MSTU(5)*ID
17515 MCT(ITRI(1),1)=MCT(ID,1)
17516 MCT(IANT(1),2)=MCT(ID,2)
17517 ELSEIF (KCQ(0).EQ.1) THEN
17518 C...3 -> 8 + 3 + n(1)
17519 K(ID,4)=K(ID,4)+IOCT(1)
17521 K(IOCT(1),4)=MSTU(5)*ID
17522 K(IOCT(1),5)=MSTU(5)*ITRI(2)
17524 K(ITRI(2),4)=MSTU(5)*IOCT(1)
17525 MCT(IOCT(1),1)=MCT(ID,1)
17529 ELSEIF (KCQ(0).EQ.-1) THEN
17530 C...3bar -> 8 + 3bar + n(1)
17531 K(ID,5)=K(ID,5)+IOCT(1)
17533 K(IOCT(1),5)=MSTU(5)*ID
17534 K(IOCT(1),4)=MSTU(5)*IANT(2)
17536 K(IANT(2),5)=MSTU(5)*IOCT(1)
17537 MCT(IOCT(1),2)=MCT(ID,2)
17542 C...1 -> 3 + 3bar + 8 + n(1)
17544 K(ITRI(1),4)=MSTU(5)*IOCT(1)
17546 K(IOCT(1),5)=MSTU(5)*ITRI(1)
17547 K(IOCT(1),4)=MSTU(5)*IANT(1)
17549 K(IANT(1),5)=MSTU(5)*IOCT(1)
17557 CPS-- End of generic cases
17558 C...(could three octets also be handled?)
17559 C...(could (some of) the RPV cases be made generic as well?)
17561 C...Special cases (= old treatment)
17562 C...Set colour flow for t -> W + b + Z.
17563 ELSEIF(KFA.EQ.6) THEN
17566 IF(KCQM(JT).EQ.-1) ISID=5
17568 K(ID,ISID)=K(ID,ISID)+IDAU
17569 K(IDAU,ISID)=MSTU(5)*ID
17571 C...Set colour flow in three-body decays - programmed as special cases.
17573 ELSEIF(KFC2A.LE.6) THEN
17577 IF(KFL2(JT).LT.0) ISID=5
17578 K(N+2,ISID)=MSTU(5)*(N+3)
17579 K(N+3,9-ISID)=MSTU(5)*(N+2)
17580 C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
17581 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
17582 & .AND.KFL3(JT).NE.0) THEN
17583 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
17584 C...3-body decays of squarks to colour singlets plus one quark
17585 IF (KQSUMA.EQ.1) THEN
17588 IF (KCQ1(JT).NE.0) IQ=1
17589 IF (KCQ2(JT).NE.0) IQ=2
17590 IF (KCQ3(JT).NE.0) IQ=3
17592 IF (K(N+IQ,2).LT.0) ISID=5
17594 K(ID,ISID)=K(ID,ISID)+(N+IQ)
17595 K(N+IQ,ISID)=MSTU(5)*ID
17598 ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
17603 IF(KFL2(JT).LT.0) ISID=5
17604 K(N+1,ISID)=MSTU(5)*(N+2)
17605 K(N+1,9-ISID)=MSTU(5)*(N+3)
17606 K(N+2,ISID)=MSTU(5)*(N+1)
17607 K(N+3,9-ISID)=MSTU(5)*(N+1)
17608 ELSEIF(KFA.EQ.KSUSY1+21) THEN
17612 IF(KFL2(JT).LT.0) ISID=5
17613 K(ID,ISID)=K(ID,ISID)+(N+2)
17614 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
17615 K(N+2,ISID)=MSTU(5)*ID
17616 K(N+3,9-ISID)=MSTU(5)*ID
17619 ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
17620 & IABS(KCQ2(JT)).EQ.1) THEN
17624 IF(KFL2(JT).LT.0) ISID=5
17625 K(N+2,ISID)=MSTU(5)*(N+3)
17626 K(N+3,9-ISID)=MSTU(5)*(N+2)
17631 C...Set colour flow in three-body decays with baryon number violation.
17632 C...Neutralino and chargino decays first.
17633 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
17634 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
17635 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
17636 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17637 C...Insert junction to keep track of colours.
17638 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17639 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17640 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17641 C...Set special junction codes:
17645 C...Order decay products by invariant mass. (will be used in PYSTRF).
17646 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)-
17647 & P(N+1,3)*P(N+2,3)
17648 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)-
17649 & P(N+1,3)*P(N+3,3)
17650 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)-
17651 & P(N+2,3)*P(N+3,3)
17652 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
17653 K(N+4,4)=N+3+K(N+4,4)
17654 K(N+4,5)=N+1+MSTU(5)*(N+2)
17655 ELSEIF(PM13.LT.PM23) THEN
17656 K(N+4,4)=N+2+K(N+4,4)
17657 K(N+4,5)=N+1+MSTU(5)*(N+3)
17659 K(N+4,4)=N+1+K(N+4,4)
17660 K(N+4,5)=N+2+MSTU(5)*(N+3)
17666 C...Connect daughters to junction.
17670 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
17672 C...Particle counter should be stepped up one extra for junction.
17676 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
17677 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
17678 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17679 C...Insert junction to keep track of colours.
17680 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17681 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17682 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17693 C...Start by connecting all daughters to junction.
17694 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
17695 C...Only consider colour topologies with off shell resonances.
17696 RMQ1=PMAS(PYCOMP(K(II,2)),1)
17697 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
17698 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
17699 IF (RMGLU-RMQ1.LT.RMRES) THEN
17700 C...Calculate propagators for each colour topology.
17701 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
17702 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
17703 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
17707 CTMSUM=CTMSUM+CTM2(II-N)
17709 CTMSUM=PYR(0)*CTMSUM
17710 C...Select colour topology J, with most off shell least likely.
17713 CTMSUM=CTMSUM-CTM2(J)
17714 IF (CTMSUM.GT.0D0) GOTO 300
17715 C...The lucky winner gets its colour (anti-colour) directly from gluino.
17716 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
17717 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
17718 C...The other gluino colour is connected to junction
17719 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
17721 K(N+4,4)=K(N+4,4)+ID
17722 C...Lastly, connect junction to remaining daughters.
17723 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
17724 C...Particle counter should be stepped up one extra for junction.
17728 C...Update particle counter.
17731 C...2) Everything else two-body decay.
17733 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
17738 C...First set colour flow as if mother colour singlet.
17739 IF(KCQ1(JT).NE.0) THEN
17741 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
17742 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
17744 IF(KCQ2(JT).NE.0) THEN
17746 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
17747 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
17749 C...Then redirect colour flow if mother (anti)triplet.
17750 IF(KCQM(JT).EQ.0) THEN
17751 ELSEIF(KCQM(JT).NE.2) THEN
17753 IF(KCQM(JT).EQ.-1) ISID=5
17755 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
17756 K(ID,ISID)=K(ID,ISID)+IDAU
17757 K(IDAU,ISID)=MSTU(5)*ID
17758 C...Then redirect colour flow if mother octet.
17759 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
17761 IF(KCQ1(JT).EQ.0) IDAU=N
17762 K(ID,4)=K(ID,4)+IDAU
17763 K(ID,5)=K(ID,5)+IDAU
17764 K(IDAU,4)=MSTU(5)*ID
17765 K(IDAU,5)=MSTU(5)*ID
17768 IF(KCQ1(JT).EQ.-1) ISID=5
17769 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
17770 K(ID,ISID)=K(ID,ISID)+(N-1)
17771 K(ID,9-ISID)=K(ID,9-ISID)+N
17772 K(N-1,ISID)=MSTU(5)*ID
17773 K(N,9-ISID)=MSTU(5)*ID
17776 C...Insert junction
17777 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
17779 C...~q* mother: type 3 junction. ~q mother: type 4.
17780 ITJUNC(JT)=(7+KCQM(JT))/2
17781 C...Specify junction KF and set colour flow from junction
17785 C...Junction type encoded together with mother:
17786 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
17787 K(N,5)=N-1+MSTU(5)*(N-2)
17788 C...Zero P and V for junction (V filled later)
17793 C...Set colour flow from mother to junction
17794 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
17795 C...Set colour flow from daughters to junction
17799 C...(Anti-)colour mother is junction.
17800 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
17805 C...End loop over resonances for daughter flavour and mass selection.
17807 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
17809 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
17810 & KFL1(JT).EQ.0) THEN
17811 WRITE(CODE,'(I9)') K(ID,2)
17812 WRITE(MASS,'(F9.3)') P(ID,5)
17813 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
17814 & CODE//' with mass'//MASS)
17820 C...Check for allowed combinations. Skip if no decays.
17821 IF(JTMAX.EQ.1) THEN
17822 IF(KDCY(1).EQ.0) GOTO 710
17823 ELSEIF(JTMAX.EQ.2) THEN
17824 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
17825 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17826 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17827 ELSEIF(JTMAX.EQ.3) THEN
17828 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
17829 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17830 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17831 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17832 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17833 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17834 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17837 C...Special case: matrix element option for Z0 decay to quarks.
17838 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
17839 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
17841 C...Check consistency of MSTJ options set.
17842 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
17844 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
17847 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
17849 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
17854 C...Select alpha_strong behaviour.
17857 MSTU(111)=MSTJ(108)
17858 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
17860 PARU(112)=PARJ(121)
17861 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
17863 C...Find axial fraction in total cross section for scalar gluon model.
17865 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
17866 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
17867 POLL=1D0-PARJ(131)*PARJ(132)
17868 SFF=1D0/(16D0*XW*XW1)
17869 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
17870 & (PARJ(123)*PARJ(124))**2)
17871 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
17873 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
17874 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
17875 & (PARJ(132)-PARJ(131)))
17878 QF=KCHG(KFLC,1)/3D0
17880 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
17881 & 1D0-(2D0*PMQ/P(ID,5))**2))
17882 VF=SIGN(1D0,QF)-4D0*QF*XW
17883 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
17884 & VF**2*HF1W)+VQ**3*HF1W
17885 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
17888 C...Choice of jet configuration.
17889 CALL PYXJET(P(ID,5),NJET,CUT)
17893 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
17894 ELSEIF(NJET.EQ.3) THEN
17895 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
17900 C...Fill jet configuration; return if incorrect kinematics.
17902 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
17903 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
17904 ELSEIF(NJET.EQ.2) THEN
17905 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
17906 ELSEIF(NJET.EQ.3) THEN
17907 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
17908 ELSEIF(KFLN.EQ.21) THEN
17909 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17912 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17915 IF(MSTU(24).NE.0) THEN
17922 C...Angular orientation according to matrix element.
17923 IF(MSTJ(106).EQ.1) THEN
17924 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
17925 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
17927 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
17928 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
17931 C...Boost partons to Z0 rest frame.
17932 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
17933 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17935 C...Mark decayed resonance and add documentation lines,
17937 IDOC=MINT(83)+MINT(4)
17939 I1=MINT(83)+MINT(4)+1
17941 IF(MSTP(128).GE.1) K(I,3)=ID
17942 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
17953 C...Generate parton shower.
17954 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
17955 CALL PYSHOW(N-1,N,P(ID,5))
17956 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
17960 PTPART(1)=0.5D0*P(ID,5)
17961 PTPART(2)=PTPART(1)
17963 IF(K(N-1,2).GT.0) THEN
17970 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
17973 C... End special case for Z0: skip ahead.
17979 C...Order incoming partons and outgoing resonances.
17980 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
17983 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
17984 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
17985 & ILIN(1)=2*MINT(84)+3-ILIN(1)
17986 ILIN(2)=2*MINT(84)+3-ILIN(1)
17988 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17992 IF(K(IREF(IP,1),2).EQ.23) IORD=2
17993 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
17994 IAKIPD=IABS(K(IREF(IP,IORD),2))
17995 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
17996 IF(KDCY(IORD).EQ.0) IORD=3-IORD
17998 C...Order decay products of resonances.
17999 DO 370 JT=IORD,3-IORD,3-2*IORD
18000 IF(KDCY(JT).EQ.0) THEN
18001 ILIN(IMAX+1)=NSD(JT)
18003 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
18004 ILIN(IMAX+1)=N+2*JT-1
18005 ILIN(IMAX+2)=N+2*JT
18007 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18008 K(N+2*JT,2)=K(NSD(JT)+2,2)
18010 ILIN(IMAX+1)=N+2*JT
18012 ILIN(IMAX+2)=N+2*JT-1
18014 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18015 K(N+2*JT,2)=K(NSD(JT)+2,2)
18019 C...Find charge, isospin, left- and righthanded couplings.
18024 KFA=IABS(K(ILIN(I),2))
18025 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
18026 COUP(I,1)=KCHG(KFA,1)/3D0
18027 COUP(I,2)=(-1)**MOD(KFA,2)
18028 COUP(I,4)=-2D0*COUP(I,1)*XWV
18029 COUP(I,3)=COUP(I,2)+COUP(I,4)
18032 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
18033 IF(ISUB.EQ.22) THEN
18036 IF(I.EQ.5) I1=3-IORD
18039 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
18040 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
18041 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
18046 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18047 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
18048 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
18049 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
18051 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
18055 C...Select angular orientation type - Z'/W' only.
18057 IF(ISUB.EQ.141) THEN
18058 IF(PYR(0).LT.PARU(130)) MZPWP=1
18060 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
18061 IAKIR=IABS(K(IREF(2,2),2))
18062 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18063 IF(IAKIR.LE.20) MZPWP=2
18065 IF(IP.GE.3) MZPWP=2
18066 ELSEIF(ISUB.EQ.142) THEN
18067 IF(PYR(0).LT.PARU(136)) MZPWP=1
18069 IAKIR=IABS(K(IREF(2,2),2))
18070 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18071 IF(IAKIR.LE.20) MZPWP=2
18073 IF(IP.GE.3) MZPWP=2
18076 C...Select random angles (begin of weighting procedure).
18077 430 DO 440 JT=1,JTMAX
18078 IF(KDCY(JT).EQ.0) GOTO 440
18079 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
18080 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
18081 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
18084 CTHE(JT)=2D0*PYR(0)-1D0
18085 PHI(JT)=PARU(2)*PYR(0)
18089 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
18090 C...Construct massless four-vectors.
18099 IF(KDCY(JT).EQ.0) GOTO 470
18101 P(N+2*JT-1,3)=0.5D0*P(ID,5)
18102 P(N+2*JT-1,4)=0.5D0*P(ID,5)
18103 P(N+2*JT,3)=-0.5D0*P(ID,5)
18104 P(N+2*JT,4)=0.5D0*P(ID,5)
18105 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
18106 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
18109 C...Store incoming and outgoing momenta, with random rotation to
18110 C...avoid accidental zeroes in HA expressions.
18114 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
18115 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
18116 P(N+4+I,5)=P(ILIN(I),5)
18118 P(N+4+I,J)=P(ILIN(I),J)
18121 500 THERR=ACOS(2D0*PYR(0)-1D0)
18122 PHIRR=PARU(2)*PYR(0)
18123 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
18125 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
18126 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
18133 C...Calculate internal products.
18134 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
18135 & ISUB.EQ.142) THEN
18136 DO 540 I1=IMIN,IMAX-1
18137 DO 530 I2=I1+1,IMAX
18138 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
18139 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
18140 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
18141 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
18142 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
18143 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
18144 HC(I1,I2)=CONJG(HA(I1,I2))
18145 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
18146 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
18147 HA(I2,I1)=-HA(I1,I2)
18148 HC(I2,I1)=-HC(I1,I2)
18153 C...Calculate four-products.
18160 DO 580 I1=IMIN,IMAX-1
18161 DO 570 I2=I1+1,IMAX
18162 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
18163 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
18164 PKK(I2,I1)=PKK(I1,I2)
18170 KFAGM=IABS(IREF(IP,7))
18171 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
18172 C...Isotropic decay selected by user.
18176 ELSEIF(JTMAX.EQ.3) THEN
18177 C...Isotropic decay when three mother particles.
18181 ELSEIF(IT4.GE.1) THEN
18182 C... Isotropic decay t -> b + W etc for 4th generation q and l.
18186 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
18187 & IREF(IP,7).EQ.36) THEN
18188 C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
18189 C...CP-odd case added by Kari Ertresvag Myklevoll.
18190 C...Now also with mixed Higgs CP-states
18192 IF(IP.EQ.1) WTMAX=SH**2
18193 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
18194 KFA=IABS(K(IREF(IP,1),2))
18195 KFT=IABS(K(IREF(IP,2),2))
18197 IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
18198 & MSTP(25).GE.3) THEN
18199 C...For mixed CP states need epsilon product.
18216 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
18217 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
18218 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
18219 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
18220 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
18221 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
18222 & P22*P30*P41+P13*P22*P31*P40
18223 C...For mixed CP states need gauge boson masses.
18224 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
18225 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
18226 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
18227 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
18232 IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
18233 KFLF1A=IABS(KFL1(1))
18234 EF1=KCHG(KFLF1A,1)/3D0
18235 AF1=SIGN(1D0,EF1+0.1D0)
18236 VF1=AF1-4D0*EF1*XWV
18237 KFLF2A=IABS(KFL1(2))
18238 EF2=KCHG(KFLF2A,1)/3D0
18239 AF2=SIGN(1D0,EF2+0.1D0)
18240 VF2=AF2-4D0*EF2*XWV
18241 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
18242 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18245 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
18246 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
18247 ELSEIF(MSTP(25).LE.2) THEN
18249 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18250 & -2*PKK(3,4)*PKK(5,6)
18251 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18252 & (PKK(3,4)*PKK(5,6))
18253 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18254 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
18256 C...Mixed CP states.
18257 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
18258 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
18259 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
18260 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
18261 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18262 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18263 & +PKK(3,4)*PKK(5,6)
18264 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18265 & +VA12AS*PKK(3,4)*PKK(5,6)
18266 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18267 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18268 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18269 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
18273 ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
18274 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18277 WT=16D0*PKK(3,5)*PKK(4,6)
18278 ELSEIF(MSTP(25).LE.2) THEN
18280 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18281 & -2*PKK(3,4)*PKK(5,6)
18282 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18283 & (PKK(3,4)*PKK(5,6))
18284 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18285 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
18287 C...Mixed CP states.
18288 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
18289 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
18290 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18291 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18292 & +PKK(3,4)*PKK(5,6)
18293 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18294 & +PKK(3,4)*PKK(5,6)
18295 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18296 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18297 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18298 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
18301 C...No angular correlations in other Higgs decays.
18306 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
18307 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
18309 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
18311 IF(MOD(KFAGM,2).EQ.0) THEN
18319 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
18320 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
18321 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
18322 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
18324 ELSEIF(ISUB.EQ.1) THEN
18325 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
18326 EI=KCHG(IABS(MINT(15)),1)/3D0
18327 AI=SIGN(1D0,EI+0.1D0)
18329 EF=KCHG(IABS(KFL1(1)),1)/3D0
18330 AF=SIGN(1D0,EF+0.1D0)
18333 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
18334 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18335 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
18336 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18337 & (VI**2+AI**2)*VINT(114)*VF**2)
18338 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
18339 & 4D0*VI*AI*VINT(114)*VF*AF)
18340 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18341 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18342 WTMAX=2D0*(WT1+ABS(WT3))
18344 ELSEIF(ISUB.EQ.2) THEN
18345 C...Angular weight for W+/- -> 2 quarks/leptons.
18346 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
18347 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
18348 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18349 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18352 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
18353 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
18354 C...-> gluon/gamma + 2 quarks/leptons.
18355 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18356 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18357 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18358 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18359 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18360 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18361 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18362 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18363 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18364 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18365 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18366 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18367 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
18368 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
18369 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18370 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
18372 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
18373 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
18374 C...-> gluon/gamma + 2 quarks/leptons.
18375 WT=PKK(1,3)**2+PKK(2,4)**2
18376 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
18378 ELSEIF(ISUB.EQ.22) THEN
18379 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
18380 S34=P(IREF(IP,IORD),5)**2
18381 S56=P(IREF(IP,3-IORD),5)**2
18382 TI=PKK(1,3)+PKK(1,4)+S34
18383 UI=PKK(1,5)+PKK(1,6)+S56
18386 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
18387 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
18388 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
18389 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
18390 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
18391 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
18392 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
18393 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
18396 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
18397 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
18398 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
18399 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
18400 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18401 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
18402 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
18405 ELSEIF(ISUB.EQ.23) THEN
18406 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
18407 D34=P(IREF(IP,IORD),5)**2
18408 D56=P(IREF(IP,3-IORD),5)**2
18409 DT=PKK(1,3)+PKK(1,4)+D34
18410 DU=PKK(1,5)+PKK(1,6)+D56
18411 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
18412 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18413 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18414 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
18416 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
18417 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
18418 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
18419 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18420 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
18421 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
18423 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
18424 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
18425 C...(or H0, or A0).
18426 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
18427 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
18428 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
18429 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
18430 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18432 ELSEIF(ISUB.EQ.25) THEN
18433 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
18434 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
18435 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
18436 D34=P(IREF(IP,IORD),5)**2
18437 D56=P(IREF(IP,3-IORD),5)**2
18438 DT=PKK(1,3)+PKK(1,4)+D34
18439 DU=PKK(1,5)+PKK(1,6)+D56
18440 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
18441 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
18442 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
18443 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
18444 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
18445 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
18446 & REAL(CBWW)*FGK(1,2,5,6,3,4))
18447 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18448 IF(MSTP(50).LE.0) THEN
18449 WT=FGK135**2+(CCWW*FGK253)**2
18450 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
18451 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
18454 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
18455 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
18456 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
18457 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
18460 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
18461 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
18462 C...(or H0, or A0).
18463 WT=PKK(1,3)*PKK(2,4)
18464 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18466 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
18467 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
18468 C...-> f + 2 quarks/leptons.
18469 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18470 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18471 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18472 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18473 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18474 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18475 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18476 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18477 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18478 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18479 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18480 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18481 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
18482 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
18483 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
18484 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
18485 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18486 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
18488 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
18489 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
18490 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
18491 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
18492 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
18494 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
18496 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
18497 WT=16D0*PKK(3,5)*PKK(4,6)
18500 ELSEIF(ISUB.EQ.110) THEN
18501 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
18505 ELSEIF(ISUB.EQ.141) THEN
18506 C...Special case: if only branching ratios known then isotropic decay.
18507 IF(MWID(32).EQ.2) THEN
18510 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18511 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
18512 C...Couplings of incoming flavour.
18513 KFAI=IABS(MINT(15))
18514 EI=KCHG(KFAI,1)/3D0
18515 AI=SIGN(1D0,EI+0.1D0)
18518 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
18519 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
18520 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
18521 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
18522 VPI=PARU(119+2*KFAIC)
18523 API=PARU(120+2*KFAIC)
18524 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
18525 VPI=PARJ(178+2*KFAIC)
18526 API=PARJ(179+2*KFAIC)
18528 VPI=PARJ(186+2*KFAIC)
18529 API=PARJ(187+2*KFAIC)
18531 C...Couplings of final flavour.
18533 EF=KCHG(KFAF,1)/3D0
18534 AF=SIGN(1D0,EF+0.1D0)
18537 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
18538 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
18539 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
18540 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
18541 VPF=PARU(119+2*KFAFC)
18542 APF=PARU(120+2*KFAFC)
18543 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
18544 VPF=PARJ(178+2*KFAFC)
18545 APF=PARJ(179+2*KFAFC)
18547 VPF=PARJ(186+2*KFAFC)
18548 APF=PARJ(187+2*KFAFC)
18550 C...Asymmetry and weight.
18551 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
18552 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
18553 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
18554 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18555 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
18556 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
18557 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
18558 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18559 WTMAX=2D0+ABS(ASYM)
18560 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
18561 C...Angular weight for f + fbar -> Z' -> W+ + W-.
18562 RM1=P(NSD(1)+1,5)**2/SH
18563 RM2=P(NSD(1)+2,5)**2/SH
18564 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18565 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18566 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18568 WT=CFLAT+CCOS2*CTHE(1)**2
18569 WTMAX=CFLAT+MAX(0D0,CCOS2)
18570 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
18571 & IABS(KFL1(1)).EQ.37)) THEN
18572 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
18575 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18576 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
18577 RM1=P(NSD(1)+1,5)**2/SH
18578 RM2=P(NSD(1)+2,5)**2/SH
18579 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18580 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18581 WTMAX=1D0+FLAM2/(8D0*RM1)
18582 ELSEIF(MZPWP.EQ.0) THEN
18583 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18584 C...(W:s like if intermediate Z).
18585 D34=P(IREF(IP,IORD),5)**2
18586 D56=P(IREF(IP,3-IORD),5)**2
18587 DT=PKK(1,3)+PKK(1,4)+D34
18588 DU=PKK(1,5)+PKK(1,6)+D56
18589 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18590 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18591 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
18592 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
18593 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18594 ELSEIF(MZPWP.EQ.1) THEN
18595 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18596 C...(W:s approximately longitudinal, like if intermediate H).
18597 WT=16D0*PKK(3,5)*PKK(4,6)
18600 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
18601 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
18606 ELSEIF(ISUB.EQ.142) THEN
18607 C...Special case: if only branching ratios known then isotropic decay.
18608 IF(MWID(34).EQ.2) THEN
18611 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18612 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
18613 KFAI=IABS(MINT(15))
18615 IF(KFAI.GT.10) KFAIC=2
18616 VI=PARU(129+2*KFAIC)
18617 AI=PARU(130+2*KFAIC)
18620 IF(KFAF.GT.10) KFAFC=2
18621 VF=PARU(129+2*KFAFC)
18622 AF=PARU(130+2*KFAFC)
18623 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
18624 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18625 WTMAX=2D0+ABS(ASYM)
18626 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
18627 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
18628 RM1=P(NSD(1)+1,5)**2/SH
18629 RM2=P(NSD(1)+2,5)**2/SH
18630 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18631 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18632 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18634 WT=CFLAT+CCOS2*CTHE(1)**2
18635 WTMAX=CFLAT+MAX(0D0,CCOS2)
18636 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18637 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
18638 RM1=P(NSD(1)+1,5)**2/SH
18639 RM2=P(NSD(1)+2,5)**2/SH
18640 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18641 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18642 WTMAX=1D0+FLAM2/(8D0*RM1)
18643 ELSEIF(MZPWP.EQ.0) THEN
18644 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18645 C...(W/Z like if intermediate W).
18646 D34=P(IREF(IP,IORD),5)**2
18647 D56=P(IREF(IP,3-IORD),5)**2
18648 DT=PKK(1,3)+PKK(1,4)+D34
18649 DU=PKK(1,5)+PKK(1,6)+D56
18650 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18651 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
18652 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18653 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
18654 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18655 ELSEIF(MZPWP.EQ.1) THEN
18656 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18657 C...(W/Z approximately longitudinal, like if intermediate H).
18658 WT=16D0*PKK(3,5)*PKK(4,6)
18661 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
18662 C...t + bbar -> t + W + bbar.
18667 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
18669 C...Isotropic decay of leptoquarks (assumed spin 0).
18673 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
18674 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
18676 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
18677 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
18678 WT=1D0+SIDE*CTHE(1)
18680 ELSEIF(IP.EQ.1) THEN
18682 RM1=P(NSD(1)+1,5)**2/SH
18683 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18684 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18686 C...W/Z decay assumed isotropic, since not known.
18691 ELSEIF(ISUB.EQ.149) THEN
18692 C...Isotropic decay of techni-eta.
18696 ELSEIF(ISUB.EQ.191) THEN
18697 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18698 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
18699 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
18702 ELSEIF(IP.EQ.1) THEN
18703 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
18704 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18705 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
18706 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18707 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18708 KFAI=IABS(MINT(15))
18709 EI=KCHG(KFAI,1)/3D0
18710 AI=SIGN(1D0,EI+0.1D0)
18714 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
18715 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
18717 EF=KCHG(KFAF,1)/3D0
18718 AF=SIGN(1D0,EF+0.1D0)
18722 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
18723 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
18724 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
18725 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
18726 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
18727 WTMAX=4D0*MAX(ASAME,AFLIP)
18729 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
18734 ELSEIF(ISUB.EQ.192) THEN
18735 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18736 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
18737 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
18740 ELSEIF(IP.EQ.1) THEN
18741 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
18742 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18746 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
18751 ELSEIF(ISUB.EQ.193) THEN
18752 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18753 C...Angular weight for f + fbar -> omega_tc0 ->
18754 C...gamma pi_tc0 or Z0 pi_tc0.
18757 ELSEIF(IP.EQ.1) THEN
18758 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
18759 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18760 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18761 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18762 KFAI=IABS(MINT(15))
18763 EI=KCHG(KFAI,1)/3D0
18764 AI=SIGN(1D0,EI+0.1D0)
18768 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
18769 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
18771 EF=KCHG(KFAF,1)/3D0
18772 AF=SIGN(1D0,EF+0.1D0)
18776 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
18777 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
18778 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
18779 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
18780 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
18781 WTMAX=4D0*MAX(BSAME,BFLIP)
18783 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
18788 ELSEIF(ISUB.EQ.353) THEN
18789 C...Angular weight for Z_R0 -> 2 quarks/leptons.
18790 EI=KCHG(IABS(MINT(15)),1)/3D0
18791 AI=SIGN(1D0,EI+0.1D0)
18793 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
18794 AF=SIGN(1D0,EF+0.1D0)
18796 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
18797 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
18798 WT2=RMF*(VI**2+AI**2)*VF**2
18799 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
18800 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18801 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18802 WTMAX=2D0*(WT1+ABS(WT3))
18804 ELSEIF(ISUB.EQ.354) THEN
18805 C...Angular weight for W_R+/- -> 2 quarks/leptons.
18806 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
18807 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
18808 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18809 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18812 ELSEIF(ISUB.EQ.391) THEN
18813 C...Angular weight for f + fbar -> G* -> f + fbar
18814 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18815 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
18817 C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
18818 C...implemented by M.-C. Lemaire
18819 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18820 & IABS(KFL1(1)).EQ.22)) THEN
18823 C...Other G* decays not yet implemented angular distributions.
18829 ELSEIF(ISUB.EQ.392) THEN
18830 C...Angular weight for g + g -> G* -> f + fbar
18831 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18834 C...Angular weight for g + g -> G* -> gamma +gamma or g + g
18835 C...implemented by M.-C. Lemaire
18836 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18837 & IABS(KFL1(1)).EQ.22)) THEN
18838 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
18840 C...Other G* decays not yet implemented angular distributions.
18846 C...Obtain correct angular distribution by rejection techniques.
18851 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
18853 C...Construct massive four-vectors using angles chosen.
18854 590 DO 690 JT=1,JTMAX
18855 IF(KDCY(JT).EQ.0) GOTO 690
18860 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
18862 IF(KFL3(JT).EQ.0) THEN
18863 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
18864 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18867 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
18868 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18873 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
18875 C...Fill in position of decay vertex.
18876 DO 630 I=NSD(JT)+1,N0
18885 C...Mark decayed resonances; trace history.
18889 IF(KCQM(JT).NE.0) THEN
18890 C...Do not kill colour flow through coloured resonance!
18894 C...If 3-body or 2-body with junction:
18895 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
18896 C...If 3-body with junction:
18897 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
18900 C...Add documentation lines.
18901 ISUBRG=MAX(1,MIN(500,MINT(1)))
18902 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
18903 IDOC=MINT(83)+MINT(4)
18906 IF(KFL3(JT).NE.0) IHI=IHI+1
18907 DO 650 I=NSD(JT)+1,IHI
18909 I1=MINT(83)+MINT(4)+1
18911 IF(MSTP(128).GE.1) K(I,3)=ID
18912 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18916 K(I1,3)=IREF(IP,JT+3)
18925 C...If 3-body or 2-body with junction:
18926 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
18927 C...If 3-body with junction:
18928 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
18931 C...Do showering of two or three objects.
18933 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
18934 IF(KFL3(JT).EQ.0) THEN
18935 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
18937 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
18940 c...For pT-ordered shower need set up first, especially colour tags.
18941 C...(Need to set up colour tags even if MSTP(71) = 0)
18942 ELSEIF(MINT(35).GE.2) THEN
18944 IF(KFL3(JT).NE.0) NPART=3
18948 PTPART(1)=0.5D0*P(ID,5)
18949 PTPART(2)=PTPART(1)
18950 PTPART(3)=PTPART(1)
18951 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
18952 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
18953 IF(MOTHER.LE.NSD(JT)) THEN
18954 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
18957 MCT(NSD(JT)+1,1)=NCT
18961 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
18962 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
18963 IF(MOTHER.LE.NSD(JT)) THEN
18964 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
18967 MCT(NSD(JT)+1,2)=NCT
18971 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
18972 & KCQ2(JT).EQ.2)) THEN
18973 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
18974 IF(MOTHER.LE.NSD(JT)) THEN
18975 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
18978 MCT(NSD(JT)+2,1)=NCT
18982 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
18983 & KCQ2(JT).EQ.2)) THEN
18984 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
18985 IF(MOTHER.LE.NSD(JT)) THEN
18986 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18989 MCT(NSD(JT)+2,2)=NCT
18993 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
18994 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
18995 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
18996 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
18998 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
18999 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
19000 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
19001 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
19003 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
19006 IF(JT.EQ.1) NAFT1=N
19008 C...Check if decay products moved by shower.
19012 IF(NSHAFT.GT.NSHBEF) THEN
19013 IF(K(NSD1,1).GT.10) THEN
19014 DO 660 I=NSHBEF+1,NSHAFT
19015 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
19018 IF(K(NSD2,1).GT.10) THEN
19019 DO 670 I=NSHBEF+1,NSHAFT
19020 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
19021 & I.NE.NSD1) NSD2=I
19024 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
19025 DO 680 I=NSHBEF+1,NSHAFT
19026 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
19027 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
19032 C...Store decay products for further treatment.
19037 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
19041 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
19042 IREF(NP,7)=K(IREF(IP,JT),2)
19043 IREF(NP,8)=IREF(IP,JT)
19047 C...Fill information for 2 -> 1 -> 2.
19048 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
19049 MINT(7)=MINT(83)+6+2*ISET(ISUB)
19050 MINT(8)=MINT(83)+7+2*ISET(ISUB)
19056 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19057 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
19058 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
19059 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
19060 VINT(47)=SQRT(VINT(48))
19063 C...Possibility of colour rearrangement in W+W- events.
19064 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
19065 IAKF1=IABS(KFL1(1))
19066 IAKF2=IABS(KFL1(2))
19067 IAKF3=IABS(KFL2(1))
19068 IAKF4=IABS(KFL2(2))
19069 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
19070 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
19071 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
19072 IF(MINT(51).NE.0) RETURN
19075 C...Loop back if needed.
19076 710 IF(IP.LT.NP) GOTO 170
19078 C...Boost back to standard frame.
19079 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
19085 C*********************************************************************
19088 C...Initializes treatment of multiple interactions, selects kinematics
19089 C...of hardest interaction if low-pT physics included in run, and
19090 C...generates all non-hardest interactions.
19092 SUBROUTINE PYMULT(MMUL)
19094 C...Double precision and integer declarations.
19095 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19096 IMPLICIT INTEGER(I-N)
19097 INTEGER PYK,PYCHGE,PYCOMP
19099 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19100 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19101 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19102 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19103 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19104 COMMON/PYINT1/MINT(400),VINT(400)
19105 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19106 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19107 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19108 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19109 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
19110 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
19111 C...Local arrays and saved variables.
19112 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
19113 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19114 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19115 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19117 C...Initialization of multiple interaction treatment.
19119 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19127 C...Loop over phase space points: xT2 choice in 20 bins.
19130 NMUL(IXT2)=MSTP(83)
19132 DO 110 ITRY=1,MSTP(83)
19133 RSCA=0.05D0*((21-IXT2)-PYR(0))
19134 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19135 XT2=MAX(0.01D0*VINT(149),XT2)
19138 C...Choose tau and y*. Calculate cos(theta-hat).
19139 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19140 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19141 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19143 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19149 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19150 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19151 CALL PYKMAP(2,MYST,PYR(0))
19152 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19154 C...Calculate differential cross-section.
19155 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19156 CALL PYSIGH(NCHN,SIGS)
19157 SIGM(IXT2)=SIGM(IXT2)+SIGS
19159 SIGSUM=SIGSUM+SIGM(IXT2)
19161 SIGSUM=SIGSUM/(20D0*MSTP(83))
19163 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19164 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19165 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19166 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19167 PARP(82)=0.9D0*PARP(82)
19168 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19172 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19173 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19175 C...Start iteration to find k factor.
19176 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19177 P83A=(1D0-PARP(83))**2
19178 P83B=2D0*PARP(83)*(1D0-PARP(83))
19180 CQ2I=1D0/PARP(84)**2
19181 CQ2R=2D0/(1D0+PARP(84)**2)
19189 130 IF(IIT.EQ.0) THEN
19191 ELSEIF(IIT.EQ.1) THEN
19194 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19197 C...Evaluate overlap integrals. Find where to divide the b range.
19198 IF(MSTP(82).EQ.2) THEN
19199 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19202 IF(MSTP(82).EQ.3) THEN
19204 ELSEIF(MSTP(82).EQ.4) THEN
19205 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19207 POWIP=MAX(0.4D0,PARP(83))
19208 RPWIP=2D0/POWIP-1D0
19209 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19219 IF(MSTP(82).EQ.3) THEN
19220 OV=EXP(-B**2)/PARU(2)
19221 ELSEIF(MSTP(82).EQ.4) THEN
19222 OV=(P83A*EXP(-MIN(50D0,B**2))+
19223 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19224 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19226 OV=EXP(-B**POWIP)/PARU(2)
19227 SO=SO+PARU(2)*B*DELTAB*OV
19229 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19230 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19231 SP=SP+PARU(2)*B*DELTAB*PACC
19232 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19233 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19234 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19236 BDIV=B+0.5D0*DELTAB
19238 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19240 YK=PARU(1)*XK*SO/SP
19242 C...Continue iteration until convergence.
19252 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19254 C...Store some results for subsequent use.
19262 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19263 PIK=(VNT146/VNT147)*YKE
19265 C...Find relative weight for low and high impact parameter.
19266 PLOWB=PARU(1)*BDIV**2
19267 IF(MSTP(82).EQ.3) THEN
19268 PHIGHB=PIK*0.5*EXP(-BDIV**2)
19269 ELSEIF(MSTP(82).EQ.4) THEN
19270 S4A=P83A*EXP(-BDIV**2)
19271 S4B=P83B*EXP(-BDIV**2*CQ2R)
19272 S4C=P83C*EXP(-BDIV**2*CQ2I)
19273 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19274 ELSEIF(PARP(83).GE.1.999D0) THEN
19280 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
19284 C...Initialize iteration in xT2 for hardest interaction.
19285 ELSEIF(MMUL.EQ.2) THEN
19289 IF(MSTP(82).LE.0) THEN
19290 ELSEIF(MSTP(82).EQ.1) THEN
19292 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19293 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19294 & VINT(317)/(VINT(318)*VINT(320))
19295 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19296 ELSEIF(MSTP(82).EQ.2) THEN
19298 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19299 & VINT(149)*(1D0+VINT(149))
19301 XC2=4D0*CKIN(3)**2/VINT(2)
19302 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
19305 C...Select impact parameter for hardest interaction.
19306 IF(MSTP(82).LE.2) RETURN
19307 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
19308 C...Treatment in low b region.
19310 B=BDIV*SQRT(PYR(0))
19311 IF(MSTP(82).EQ.3) THEN
19312 OV=EXP(-B**2)/PARU(2)
19313 ELSEIF(MSTP(82).EQ.4) THEN
19314 OV=(P83A*EXP(-MIN(50D0,B**2))+
19315 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19316 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19318 OV=EXP(-B**POWIP)/PARU(2)
19320 VINT(148)=OV/VNT147
19321 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
19323 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19324 & VINT(149)*(1D0+VINT(149))
19326 C...Treatment in high b region.
19328 IF(MSTP(82).EQ.3) THEN
19329 B=SQRT(BDIV**2-LOG(PYR(0)))
19330 OV=EXP(-B**2)/PARU(2)
19331 ELSEIF(MSTP(82).EQ.4) THEN
19332 S4RNDM=PYR(0)*(S4A+S4B+S4C)
19333 IF(S4RNDM.LT.S4A) THEN
19334 B=SQRT(BDIV**2-LOG(PYR(0)))
19335 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
19336 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
19338 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
19340 OV=(P83A*EXP(-MIN(50D0,B**2))+
19341 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19342 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19343 ELSEIF(PARP(83).GE.1.999D0) THEN
19344 144 B2RPW=B2RPDV-LOG(PYR(0))
19345 ACCIP=(B2RPW/B2RPDV)**RPWIP
19346 IF(ACCIP.LT.PYR(0)) GOTO 144
19347 OV=EXP(-B2RPW)/PARU(2)
19348 B=B2RPW**(1D0/POWIP)
19350 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
19351 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
19352 IF(ACCIP.LT.PYR(0)) GOTO 146
19353 OV=EXP(-B2RPW)/PARU(2)
19354 B=B2RPW**(1D0/POWIP)
19356 VINT(148)=OV/VNT147
19357 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
19359 IF(PACC.LT.PYR(0)) GOTO 142
19362 ELSEIF(MMUL.EQ.3) THEN
19363 C...Low-pT or multiple interactions (first semihard interaction):
19364 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19365 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19370 IF(MSTP(82).LE.0) THEN
19372 ELSEIF(MSTP(82).EQ.1) THEN
19373 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19374 C...Use with "Sudakov" for low b values when impact parameter dependence.
19375 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
19376 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
19377 & VINT(149)))).GT.PYR(0)) XT2=1D0
19378 IF(XT2.GE.1D0) THEN
19379 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
19380 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
19383 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
19384 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
19387 XT2=MAX(0.01D0*VINT(149),XT2)
19388 C...Use without "Sudakov" for high b values when impact parameter dep.
19390 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
19391 & PYR(0)*(1D0-XC2))-VINT(149)
19392 XT2=MAX(0.01D0*VINT(149),XT2)
19396 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19397 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
19398 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
19399 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
19402 VINT(21)=0.01D0*VINT(149)
19405 VINT(25)=0.01D0*VINT(149)
19408 C...Multiple interactions (first semihard interaction).
19409 C...Choose tau and y*. Calculate cos(theta-hat).
19410 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19411 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19412 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19414 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19420 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19421 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19422 CALL PYKMAP(2,MYST,PYR(0))
19423 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19425 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
19427 C...Store results of cross-section calculation.
19428 ELSEIF(MMUL.EQ.4) THEN
19434 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
19435 IF(ISET(ISUB).EQ.2)
19436 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
19437 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
19438 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
19439 & (XTS+VINT(149))))
19440 IRBIN=INT(1D0+20D0*RBIN)
19441 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
19442 NMUL(IRBIN)=NMUL(IRBIN)+1
19443 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
19446 C...Choose impact parameter if not already done.
19447 ELSEIF(MMUL.EQ.5) THEN
19452 150 IF(MINT(39).GT.0) THEN
19453 ELSEIF(MSTP(82).EQ.3) THEN
19456 VINT(148)=EXPB2/(PARU(2)*VNT147)
19457 VINT(139)=SQRT(B2)/BAVG
19458 ELSEIF(MSTP(82).EQ.4) THEN
19460 IF(RTYPE.LT.P83A) THEN
19462 ELSEIF(RTYPE.LT.P83A+P83B) THEN
19463 B2=-LOG(PYR(0))/CQ2R
19465 B2=-LOG(PYR(0))/CQ2I
19467 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
19468 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
19469 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
19470 VINT(139)=SQRT(B2)/BAVG
19471 ELSEIF(PARP(83).GE.1.999D0) THEN
19472 POWIP=MAX(2D0,PARP(83))
19473 RPWIP=2D0/POWIP-1D0
19474 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
19475 160 IF(PYR(0).LT.PROB1) THEN
19476 B2RPW=PYR(0)**(0.5D0*POWIP)
19479 B2RPW=1D0-LOG(PYR(0))
19482 IF(ACCIP.LT.PYR(0)) GOTO 160
19483 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19484 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19486 POWIP=MAX(0.4D0,PARP(83))
19487 RPWIP=2D0/POWIP-1D0
19488 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
19489 170 IF(PYR(0).LT.PROB1) THEN
19490 B2RPW=2D0*RPWIP*PYR(0)
19491 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
19493 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
19494 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
19496 IF(ACCIP.LT .PYR(0)) GOTO 170
19497 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19498 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19501 C...Multiple interactions (variable impact parameter) : reject with
19502 C...probability exp(-overlap*cross-section above pT/normalization).
19503 C...Does not apply to low-b region, where "Sudakov" already included.
19505 IF(MINT(39).NE.1) THEN
19506 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
19507 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
19508 DO 180 IBIN=IRBIN+1,20
19509 RNCOR=RNCOR+NMUL(IBIN)
19510 SIGCOR=SIGCOR+SIGM(IBIN)
19512 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
19513 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
19514 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
19515 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
19517 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
19518 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
19519 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
19520 IF(VINT(150).LT.PYR(0)) GOTO 150
19524 C...Generate additional multiple semihard interactions.
19525 ELSEIF(MMUL.EQ.6) THEN
19538 C...Reconstruct strings in hard scattering.
19540 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
19541 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
19543 DO 210 I=MINT(84)+1,NMAX
19544 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
19545 IF(KCS.EQ.0) GOTO 210
19547 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
19548 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
19550 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
19552 IST=MOD(K(I,J+1),MSTU(5))
19554 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
19555 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
19557 IF(J.EQ.1.OR.J.EQ.4) THEN
19567 C...Set up starting values for iteration in xT2.
19568 XT2=4D0*VINT(62)/VINT(2)
19569 IF(MSTP(82).LE.1) THEN
19570 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19571 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19572 & VINT(317)/(VINT(318)*VINT(320))
19573 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19575 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
19576 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
19580 VINT(143)=1D0-VINT(141)
19581 VINT(144)=1D0-VINT(142)
19583 C...Iterate downwards in xT2.
19584 220 IF(MSTP(82).LE.1) THEN
19585 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19586 IF(XT2.LT.VINT(149)) GOTO 270
19588 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
19589 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
19590 & LOG(PYR(0)))-VINT(149)
19591 IF(XT2.LE.0D0) GOTO 270
19592 XT2=MAX(0.01D0*VINT(149),XT2)
19596 C...Choose tau and y*. Calculate cos(theta-hat).
19597 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19598 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19599 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19601 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19607 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19608 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19609 CALL PYKMAP(2,MYST,PYR(0))
19610 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19612 C...Check that x not used up. Accept or reject kinematical variables.
19613 X1M=SQRT(TAU)*EXP(VINT(22))
19614 X2M=SQRT(TAU)*EXP(-VINT(22))
19615 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
19616 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19617 CALL PYSIGH(NCHN,SIGS)
19618 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
19619 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
19621 C...Reset K, P and V vectors. Select some variables.
19630 PT=0.5D0*VINT(1)*SQRT(XT2)
19634 C...Add first parton to event record.
19637 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
19638 & 1+INT((2D0+PARJ(2))*PYR(0))
19639 P(N+1,1)=PT*COS(PHI)
19640 P(N+1,2)=PT*SIN(PHI)
19641 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
19642 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
19645 C...Add second parton to event record.
19648 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
19651 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
19652 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
19655 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
19656 C....Choose relevant string pieces to place gluons on.
19662 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
19663 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
19664 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
19665 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
19666 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
19674 C....Colour flow adjustments, new string pieces.
19675 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
19676 & MOD(K(IST1,4),MSTU(5))
19677 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
19678 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
19679 K(I,5)=MSTU(5)*IST1
19680 K(I,4)=MSTU(5)*IST2
19681 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
19682 & MOD(K(IST2,5),MSTU(5))
19683 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
19684 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
19687 KSTR(NSTR+1,2)=IST2
19691 C...String drawing and colour flow for gluon loop.
19692 ELSEIF(K(N+1,2).EQ.21) THEN
19693 K(N+1,4)=MSTU(5)*(N+2)
19694 K(N+1,5)=MSTU(5)*(N+2)
19695 K(N+2,4)=MSTU(5)*(N+1)
19696 K(N+2,5)=MSTU(5)*(N+1)
19703 C...String drawing and colour flow for qqbar pair.
19705 K(N+1,4)=MSTU(5)*(N+2)
19706 K(N+2,5)=MSTU(5)*(N+1)
19712 C...Global statistics.
19713 MINT(351)=MINT(351)+1
19714 VINT(351)=VINT(351)+PT
19715 IF (MINT(351).EQ.1) VINT(356)=PT
19717 C...Update remaining energy; iterate.
19719 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
19720 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
19724 MINT(31)=MINT(31)+1
19725 VINT(151)=VINT(151)+VINT(41)
19726 VINT(152)=VINT(152)+VINT(42)
19727 VINT(143)=VINT(143)-VINT(41)
19728 VINT(144)=VINT(144)-VINT(42)
19729 C...Allow FSR for UE (always handle with old showers)
19730 IF(MSTP(152).EQ.1) THEN
19732 IF (MSTJ(41).EQ.10) MSTJ(41)=2
19733 MSTJ(41)=MOD(MSTJ(41),10)
19734 CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
19737 IF(MINT(31).LT.240) GOTO 220
19745 C...Format statements for printout.
19746 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
19747 &'actions for MSTP(82) =',I2,' ******')
19748 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19749 &D9.2,' mb: rejected')
19750 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19751 &D9.2,' mb: accepted')
19756 C*********************************************************************
19759 C...Adds on target remnants (one or two from each side) and
19760 C...includes primordial kT for hadron beams.
19762 SUBROUTINE PYREMN(IPU1,IPU2)
19764 C...Double precision and integer declarations.
19765 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19766 IMPLICIT INTEGER(I-N)
19767 INTEGER PYK,PYCHGE,PYCOMP
19769 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19770 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19771 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19772 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19773 COMMON/PYINT1/MINT(400),VINT(400)
19774 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19776 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
19777 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
19779 C...Find event type and remaining energy.
19782 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
19783 VINT(143)=1D0-VINT(141)
19784 VINT(144)=1D0-VINT(142)
19787 C...Define initial partons.
19792 IF(JT.EQ.1) IPU=IPU1
19793 IF(JT.EQ.2) IPU=IPU2
19800 IF(MINT(47).EQ.1) THEN
19804 ELSEIF(ISUB.EQ.95) THEN
19809 C...No primordial kT, or chosen according to truncated Gaussian or
19810 C...exponential, or (for photon) predetermined or power law.
19811 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
19812 IF(MSTP(91).LE.0) THEN
19814 ELSEIF(MSTP(91).EQ.1) THEN
19815 PT=PARP(91)*SQRT(-LOG(PYR(0)))
19819 PT=-PARP(92)*LOG(RPT1*RPT2)
19821 IF(PT.GT.PARP(93)) GOTO 120
19822 ELSEIF(MINT(106+JT).EQ.3) THEN
19823 PTA=SQRT(VINT(282+JT))
19825 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
19826 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
19827 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
19830 PTB=-PARP(99)*LOG(RPT1*RPT2)
19832 IF(PTB.GT.PARP(100)) GOTO 120
19833 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
19834 PT=PT*0.8D0**MINT(57)
19835 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
19836 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
19837 IF(MSTP(93).LE.0) THEN
19839 ELSEIF(MSTP(93).EQ.1) THEN
19840 PT=PARP(99)*SQRT(-LOG(PYR(0)))
19841 ELSEIF(MSTP(93).EQ.2) THEN
19844 PT=-PARP(99)*LOG(RPT1*RPT2)
19845 ELSEIF(MSTP(93).EQ.3) THEN
19848 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
19852 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
19853 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
19855 IF(PT.GT.PARP(100)) GOTO 120
19863 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19866 IF(MINT(47).EQ.1) RETURN
19868 C...Kinematics construction for initial partons.
19871 IF(ISUB.EQ.95) THEN
19875 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
19876 & (P(I1,2)+P(I2,2))**2
19877 SHR=SQRT(MAX(0D0,SHS))
19878 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
19879 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
19880 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
19881 P(I2,4)=SHR-P(I1,4)
19884 C...Transform partons to overall CM-frame.
19885 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
19886 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
19887 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
19888 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
19889 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
19890 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
19891 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
19892 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
19893 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
19894 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
19895 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
19898 C...Optionally fix up x and Q2 definitions for leptoproduction.
19900 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
19901 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
19902 IF(IDISXQ.EQ.1) THEN
19904 C...Find where incoming and outgoing leptons/partons are sitting.
19906 IF(MINT(42).EQ.1) LESD=2
19907 LPIN=MINT(83)+3-LESD
19909 LQIN=MINT(84)+3-LESD
19910 LEOUT=MINT(84)+2+LESD
19911 LQOUT=MINT(84)+5-LESD
19912 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
19913 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
19915 DO 140 I=MINT(84)+5,N
19916 IF(K(I,2).EQ.94) THEN
19923 IF(LESD.EQ.1) LQBG=IPU2
19925 C...Calculate actual and wanted momentum transfer.
19928 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
19929 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
19930 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
19931 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
19932 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
19933 P(N+1,1)=FAC*P(LEOUT,1)
19934 P(N+1,2)=FAC*P(LEOUT,2)
19935 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
19936 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
19937 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
19940 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
19941 QNEW(J)=P(LEIN,J)-P(N+1,J)
19944 C...Boost outgoing electron and daughters.
19945 IF(LSCMS.EQ.0) THEN
19947 P(LEOUT,J)=P(N+1,J)
19951 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
19953 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
19955 DBE(J)=PINV*P(N+2,J)
19959 190 IORIG=K(IORIG,3)
19960 IF(IORIG.GT.LEOUT) GOTO 190
19961 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
19962 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
19966 C...Copy shower initiator and all outgoing partons.
19970 P(NCOP,J)=P(LQBG,J)
19972 DO 240 I=MINT(84)+1,N
19974 IF(K(I,1).GT.10) GOTO 240
19975 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
19979 220 IORIG=K(IORIG,3)
19980 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
19982 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
19995 C...Calculate relative rescaling factors.
19999 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
20002 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
20005 C...Transfer extra three-momentum of current.
20008 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
20010 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20013 C...Iterate change of initiator momentum to get energy right.
20016 PEEX=-P(N+1,4)-QNEW(4)
20017 PEMV=-P(N+1,3)/P(N+1,4)
20020 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
20022 IF(ABS(PEMV).LT.1D-10) THEN
20024 MINT(57)=MINT(57)+1
20028 P(N+1,3)=P(N+1,3)+PZCH
20029 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)
20031 P(I,3)=P(I,3)+V(I,1)*PZCH
20032 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20034 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
20036 C...Modify momenta in event record.
20037 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
20038 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
20039 IF(ABS(HBE).GE.1D0) THEN
20041 MINT(57)=MINT(57)+1
20045 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
20054 C...Check minimum invariant mass of remnant system(s).
20055 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
20056 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
20057 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20058 PMIN(0)=SQRT(PMS(0))
20060 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
20061 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
20063 IF(MINT(44+JT).EQ.1) GOTO 340
20064 MINT(105)=MINT(102+JT)
20065 MINT(109)=MINT(106+JT)
20066 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
20067 IF(MINT(51).NE.0) THEN
20068 MINT(57)=MINT(57)+1
20071 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
20072 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
20073 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
20074 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
20075 & P(MINT(83)+JT+2,2)**2)
20077 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
20078 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
20081 MINT(57)=MINT(57)+1
20085 C...Loop over two remnants; skip if none there.
20089 IF(MINT(44+JT).EQ.1) GOTO 410
20090 IF(JT.EQ.1) IPU=IPU1
20091 IF(JT.EQ.2) IPU=IPU2
20093 C...Store first remnant parton.
20105 P(I,5)=PYMASS(K(I,2))
20107 C...First parton colour connections and kinematics.
20108 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
20111 K(I,4)=MSTU(5)*IPU+IPU
20112 K(I,5)=MSTU(5)*IPU+IPU
20113 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20114 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20115 ELSEIF(KCOL.NE.0) THEN
20117 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
20119 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20121 IF(KFLCH(JT).EQ.0) THEN
20122 P(I,1)=-P(MINT(83)+JT+2,1)
20123 P(I,2)=-P(MINT(83)+JT+2,2)
20124 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20125 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20129 C...When extra remnant parton or hadron: store extra remnant.
20141 P(I,5)=PYMASS(K(I,2))
20143 C...Find parton colour connections of extra remnant.
20144 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
20147 K(I,4)=MSTU(5)*IPU+IPU
20148 K(I,5)=MSTU(5)*IPU+IPU
20149 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20150 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20151 ELSEIF(KCOL.NE.0) THEN
20153 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
20155 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20158 C...Relative transverse momentum when two remnants.
20161 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
20162 IF(IABS(MINT(10+JT)).LT.20) THEN
20166 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
20167 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
20169 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
20170 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
20171 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
20172 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20174 C...Meson or baryon; photon as meson. For splitup below.
20176 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
20178 C***Relative distribution for electron into two electrons. Temporary!
20179 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
20183 C...Relative distribution of electron energy into electron plus parton.
20184 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
20187 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
20189 C...Relative distribution of energy for particle into two jets.
20190 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
20191 CHIK=PARP(92+2*IMB)
20192 IF(MSTP(92).LE.1) THEN
20193 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20194 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20195 ELSEIF(MSTP(92).EQ.2) THEN
20196 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
20197 ELSEIF(MSTP(92).EQ.3) THEN
20198 CUT=2D0*0.3D0/VINT(1)
20199 380 CHI(JT)=PYR(0)**2
20200 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
20201 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
20202 ELSEIF(MSTP(92).EQ.4) THEN
20203 CUT=2D0*0.3D0/VINT(1)
20204 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
20205 390 CHIR=CUT*CUTR**PYR(0)
20206 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
20207 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
20209 CUT=2D0*0.3D0/VINT(1)
20210 CUTA=CUT**(1D0-PARP(98))
20211 CUTB=(1D0+CUT)**(1D0-PARP(98))
20212 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
20213 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
20214 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
20217 C...Relative distribution of energy for particle into jet plus particle.
20219 IF(MSTP(94).LE.1) THEN
20220 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20221 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20222 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20223 ELSEIF(MSTP(94).EQ.2) THEN
20224 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
20225 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20226 ELSEIF(MSTP(94).EQ.3) THEN
20227 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
20230 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
20235 C...Construct total transverse mass; reject if too large.
20236 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
20237 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
20238 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
20239 IF(LOOP.LT.100) THEN
20243 MINT(57)=MINT(57)+1
20247 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20248 VINT(158+JT)=CHI(JT)
20250 C...Subdivide longitudinal momentum according to value selected above.
20251 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
20252 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
20253 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
20254 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
20255 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
20260 C...Check if longitudinal boosts needed - if so pick two systems.
20261 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
20262 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
20263 IF(PDEV.LE.1D-6*VINT(1)) RETURN
20264 IF(ISN(1).EQ.0) THEN
20267 ELSEIF(ISN(2).EQ.0) THEN
20270 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
20273 ELSEIF(VINT(143).GT.0.2D0) THEN
20276 ELSEIF(VINT(144).GT.0.2D0) THEN
20279 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
20288 C...E+-pL wanted for system to be modified.
20289 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
20293 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
20294 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
20297 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
20298 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
20299 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
20300 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
20304 DO 450 I=MINT(84)+1,NS
20305 IF(K(I,1).GT.10) GOTO 450
20308 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20310 IF(IORIG.GT.LPIN) GOTO 430
20311 IF(INCL.EQ.0) GOTO 450
20313 PSYS(0,J)=PSYS(0,J)+P(I,J)
20316 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20317 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
20318 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
20321 C...Construct longitudinal boosts.
20325 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
20326 IF(DSQLAM.LE.1D-6*DPMTB) THEN
20328 MINT(57)=MINT(57)+1
20331 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
20332 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
20333 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
20334 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
20335 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
20336 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
20337 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
20339 C...Perform longitudinal boosts.
20340 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
20342 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
20343 ELSEIF(IR.EQ.1) THEN
20344 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
20345 ELSEIF(IDISXQ.EQ.1) THEN
20349 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20351 IF(IORIG.GT.LPIN) GOTO 460
20352 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
20355 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
20357 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
20359 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
20360 ELSEIF(IL.EQ.2) THEN
20361 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
20362 ELSEIF(IDISXQ.EQ.1) THEN
20366 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20368 IF(IORIG.GT.LPIN) GOTO 480
20369 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
20372 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
20375 C...Final check that energy-momentum conservation worked.
20378 DO 500 I=MINT(84)+1,N
20379 IF(K(I,1).GT.10) GOTO 500
20383 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
20384 IF(PDEV.GT.1D-4*VINT(1)) THEN
20386 MINT(57)=MINT(57)+1
20390 C...Calculate rotation and boost from overall CM frame to
20391 C...hadronic CM frame in leptoproduction.
20393 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20396 IF(MINT(42).EQ.1) LESD=2
20397 LPIN=MINT(83)+3-LESD
20399 C...Sum upp momenta of everything not lepton or photon to define boost.
20404 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
20405 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
20406 IF(K(I,2).EQ.22) GOTO 530
20408 PSUM(J)=PSUM(J)+P(I,J)
20411 VINT(223)=-PSUM(1)/PSUM(4)
20412 VINT(224)=-PSUM(2)/PSUM(4)
20413 VINT(225)=-PSUM(3)/PSUM(4)
20415 C...Boost incoming hadron to hadronic CM frame to determine rotations.
20421 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
20422 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
20423 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
20425 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
20427 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
20434 C*********************************************************************
20437 C...Initializes treatment of new multiple interactions scenario,
20438 C...selects kinematics of hardest interaction if low-pT physics
20439 C...included in run, and generates all non-hardest interactions.
20441 SUBROUTINE PYMIGN(MMUL)
20443 C...Double precision and integer declarations.
20444 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20445 IMPLICIT INTEGER(I-N)
20446 INTEGER PYK,PYCHGE,PYCOMP
20448 DOUBLE PRECISION PYALPS
20450 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20451 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20452 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20453 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20454 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20455 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20456 COMMON/PYINT1/MINT(400),VINT(400)
20457 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20458 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20459 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20460 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20461 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20462 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20463 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20464 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20465 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
20466 C...Local arrays and saved variables.
20467 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
20468 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
20469 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
20470 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
20471 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
20473 C...Initialization of multiple interaction treatment.
20475 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
20483 C...Loop over phase space points: xT2 choice in 20 bins.
20486 NMUL(IXT2)=MSTP(83)
20488 DO 110 ITRY=1,MSTP(83)
20489 RSCA=0.05D0*((21-IXT2)-PYR(0))
20490 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
20491 XT2=MAX(0.01D0*VINT(149),XT2)
20494 C...Choose tau and y*. Calculate cos(theta-hat).
20495 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20496 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20497 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20499 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20505 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20506 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20507 CALL PYKMAP(2,MYST,PYR(0))
20508 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20510 C...Calculate differential cross-section.
20511 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20512 CALL PYSIGH(NCHN,SIGS)
20513 SIGM(IXT2)=SIGM(IXT2)+SIGS
20515 SIGSUM=SIGSUM+SIGM(IXT2)
20517 SIGSUM=SIGSUM/(20D0*MSTP(83))
20519 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
20520 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
20521 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
20522 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
20523 PARP(82)=0.9D0*PARP(82)
20524 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
20528 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
20529 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
20531 C...Start iteration to find k factor.
20532 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
20533 P83A=(1D0-PARP(83))**2
20534 P83B=2D0*PARP(83)*(1D0-PARP(83))
20536 CQ2I=1D0/PARP(84)**2
20537 CQ2R=2D0/(1D0+PARP(84)**2)
20545 130 IF(IIT.EQ.0) THEN
20547 ELSEIF(IIT.EQ.1) THEN
20550 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
20553 C...Evaluate overlap integrals. Find where to divide the b range.
20554 IF(MSTP(82).EQ.2) THEN
20555 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
20558 IF(MSTP(82).EQ.3) THEN
20560 ELSEIF(MSTP(82).EQ.4) THEN
20561 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
20563 POWIP=MAX(0.4D0,PARP(83))
20564 RPWIP=2D0/POWIP-1D0
20565 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
20575 IF(MSTP(82).EQ.3) THEN
20576 OV=EXP(-B**2)/PARU(2)
20577 ELSEIF(MSTP(82).EQ.4) THEN
20578 OV=(P83A*EXP(-MIN(50D0,B**2))+
20579 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20580 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20582 OV=EXP(-B**POWIP)/PARU(2)
20583 SO=SO+PARU(2)*B*DELTAB*OV
20585 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
20586 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
20587 SP=SP+PARU(2)*B*DELTAB*PACC
20588 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
20589 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
20590 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
20592 BDIV=B+0.5D0*DELTAB
20594 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
20596 YK=PARU(1)*XK*SO/SP
20598 C...Continue iteration until convergence.
20608 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
20610 C...Store some results for subsequent use.
20618 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
20619 PIK=(VNT146/VNT147)*YKE
20621 C...Find relative weight for low and high impact parameter..
20622 PLOWB=PARU(1)*BDIV**2
20623 IF(MSTP(82).EQ.3) THEN
20624 PHIGHB=PIK*0.5*EXP(-BDIV**2)
20625 ELSEIF(MSTP(82).EQ.4) THEN
20626 S4A=P83A*EXP(-BDIV**2)
20627 S4B=P83B*EXP(-BDIV**2*CQ2R)
20628 S4C=P83C*EXP(-BDIV**2*CQ2I)
20629 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
20630 ELSEIF(PARP(83).GE.1.999D0) THEN
20636 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
20640 C...Initialize iteration in xT2 for hardest interaction.
20641 ELSEIF(MMUL.EQ.2) THEN
20645 IF(MSTP(82).LE.0) THEN
20646 ELSEIF(MSTP(82).EQ.1) THEN
20648 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20649 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20650 & VINT(317)/(VINT(318)*VINT(320))
20651 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20652 ELSEIF(MSTP(82).EQ.2) THEN
20654 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20655 & VINT(149)*(1D0+VINT(149))
20657 XC2=4D0*CKIN(3)**2/VINT(2)
20658 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
20661 C...Select impact parameter for hardest interaction.
20662 IF(MSTP(82).LE.2) RETURN
20663 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
20664 C...Treatment in low b region.
20666 B=BDIV*SQRT(PYR(0))
20667 IF(MSTP(82).EQ.3) THEN
20668 OV=EXP(-B**2)/PARU(2)
20669 ELSEIF(MSTP(82).EQ.4) THEN
20670 OV=(P83A*EXP(-MIN(50D0,B**2))+
20671 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20672 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20674 OV=EXP(-B**POWIP)/PARU(2)
20676 VINT(148)=OV/VNT147
20677 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
20679 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20680 & VINT(149)*(1D0+VINT(149))
20682 C...Treatment in high b region.
20684 IF(MSTP(82).EQ.3) THEN
20685 B=SQRT(BDIV**2-LOG(PYR(0)))
20686 OV=EXP(-B**2)/PARU(2)
20687 ELSEIF(MSTP(82).EQ.4) THEN
20688 S4RNDM=PYR(0)*(S4A+S4B+S4C)
20689 IF(S4RNDM.LT.S4A) THEN
20690 B=SQRT(BDIV**2-LOG(PYR(0)))
20691 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
20692 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
20694 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
20696 OV=(P83A*EXP(-MIN(50D0,B**2))+
20697 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20698 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20699 ELSEIF(PARP(83).GE.1.999D0) THEN
20700 144 B2RPW=B2RPDV-LOG(PYR(0))
20701 ACCIP=(B2RPW/B2RPDV)**RPWIP
20702 IF(ACCIP.LT.PYR(0)) GOTO 144
20703 OV=EXP(-B2RPW)/PARU(2)
20704 B=B2RPW**(1D0/POWIP)
20706 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
20707 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
20708 IF(ACCIP.LT.PYR(0)) GOTO 146
20709 OV=EXP(-B2RPW)/PARU(2)
20710 B=B2RPW**(1D0/POWIP)
20712 VINT(148)=OV/VNT147
20713 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
20715 IF(PACC.LT.PYR(0)) GOTO 142
20718 ELSEIF(MMUL.EQ.3) THEN
20719 C...Low-pT or multiple interactions (first semihard interaction):
20720 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
20721 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
20726 IF(MSTP(82).LE.0) THEN
20728 ELSEIF(MSTP(82).EQ.1) THEN
20729 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20730 C...Use with "Sudakov" for low b values when impact parameter dependence.
20731 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
20732 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
20733 & VINT(149)))).GT.PYR(0)) XT2=1D0
20734 IF(XT2.GE.1D0) THEN
20735 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
20736 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
20739 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
20740 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
20743 XT2=MAX(0.01D0*VINT(149),XT2)
20744 C...Use without "Sudakov" for high b values when impact parameter dep.
20746 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
20747 & PYR(0)*(1D0-XC2))-VINT(149)
20748 XT2=MAX(0.01D0*VINT(149),XT2)
20752 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
20753 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
20754 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
20755 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
20758 VINT(21)=1D-12*VINT(149)
20761 VINT(25)=1D-12*VINT(149)
20764 C...Multiple interactions (first semihard interaction).
20765 C...Choose tau and y*. Calculate cos(theta-hat).
20766 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20767 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20768 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20770 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20776 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20777 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20778 CALL PYKMAP(2,MYST,PYR(0))
20779 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20781 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
20783 C...Store results of cross-section calculation.
20784 ELSEIF(MMUL.EQ.4) THEN
20790 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
20791 IF(ISET(ISUB).EQ.2)
20792 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20793 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
20794 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
20795 & (XTS+VINT(149))))
20796 IRBIN=INT(1D0+20D0*RBIN)
20797 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
20798 NMUL(IRBIN)=NMUL(IRBIN)+1
20799 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
20802 C...Choose impact parameter if not already done.
20803 ELSEIF(MMUL.EQ.5) THEN
20808 150 IF(MINT(39).GT.0) THEN
20809 ELSEIF(MSTP(82).EQ.3) THEN
20812 VINT(148)=EXPB2/(PARU(2)*VNT147)
20813 VINT(139)=SQRT(B2)/BAVG
20814 ELSEIF(MSTP(82).EQ.4) THEN
20816 IF(RTYPE.LT.P83A) THEN
20818 ELSEIF(RTYPE.LT.P83A+P83B) THEN
20819 B2=-LOG(PYR(0))/CQ2R
20821 B2=-LOG(PYR(0))/CQ2I
20823 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
20824 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
20825 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
20826 VINT(139)=SQRT(B2)/BAVG
20827 ELSEIF(PARP(83).GE.1.999D0) THEN
20828 POWIP=MAX(2D0,PARP(83))
20829 RPWIP=2D0/POWIP-1D0
20830 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
20831 160 IF(PYR(0).LT.PROB1) THEN
20832 B2RPW=PYR(0)**(0.5D0*POWIP)
20835 B2RPW=1D0-LOG(PYR(0))
20838 IF(ACCIP.LT.PYR(0)) GOTO 160
20839 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20840 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20842 POWIP=MAX(0.4D0,PARP(83))
20843 RPWIP=2D0/POWIP-1D0
20844 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
20845 170 IF(PYR(0).LT.PROB1) THEN
20846 B2RPW=2D0*RPWIP*PYR(0)
20847 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
20849 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
20850 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
20852 IF(ACCIP.LT .PYR(0)) GOTO 170
20853 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20854 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20857 C...Multiple interactions (variable impact parameter) : reject with
20858 C...probability exp(-overlap*cross-section above pT/normalization).
20859 C...Does not apply to low-b region, where "Sudakov" already included.
20861 IF(MINT(39).NE.1) THEN
20862 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
20863 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
20864 DO 180 IBIN=IRBIN+1,20
20865 RNCOR=RNCOR+NMUL(IBIN)
20866 SIGCOR=SIGCOR+SIGM(IBIN)
20868 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
20869 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
20870 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
20871 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
20873 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
20874 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
20875 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20876 IF(VINT(150).LT.PYR(0)) GOTO 150
20880 C...Generate additional multiple semihard interactions.
20881 ELSEIF(MMUL.EQ.6) THEN
20883 C...Save data for hardest initeraction, to be restored.
20900 C...Store data on hardest interaction.
20907 C...Change process to generate; sum of x values so far.
20910 VINT(143)=1D0-VINT(141)
20911 VINT(144)=1D0-VINT(142)
20915 C...Initialize factors for PDF reshaping.
20919 KFSBM=ISIGN(1,KFBEAM)
20921 C...Zero flavour content of incoming beam particle.
20925 C...Flavour content of baryon.
20926 IF(KFABM.GT.1000) THEN
20927 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
20928 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
20929 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
20930 C...Flavour content of pi+-, K+-.
20931 ELSEIF(KFABM.EQ.211) THEN
20932 KFIVAL(JS,1)=KFSBM*2
20933 KFIVAL(JS,2)=-KFSBM
20934 ELSEIF(KFABM.EQ.321) THEN
20935 KFIVAL(JS,1)=-KFSBM*3
20936 KFIVAL(JS,2)=KFSBM*2
20937 C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
20940 C...Zero initial valence and companion content.
20945 C...Initiate listing of all incoming partons from two sides.
20947 DO 210 I=MINT(84)+1,N
20948 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
20954 C...Decide whether quarks in hard scattering were valence or sea.
20955 IFL=K(IMI(JS,1,1),2)
20956 IF (IABS(IFL).GT.6) GOTO 230
20958 C...Get PDFs at X and Q2 of the parton shower initiator for the
20959 C...hard scattering.
20961 IF(MSTP(61).GE.1) THEN
20966 C...Note: XPSVC = x*pdf.
20969 C.... Store side in MINT(124)
20972 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20976 C...Decide (Extra factor x cancels in the division).
20977 RVCS=PYR(0)*(SEA+VAL)
20979 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20980 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20982 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20983 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20984 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20985 IF(KFIVAL(JS,1).EQ.0) THEN
20986 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20987 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20988 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20989 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20991 IF(IVNOW.EQ.0) GOTO 220
20994 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20995 IF(KFIVAL(JS,1).EQ.0) THEN
20996 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20999 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21001 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21002 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21006 C...If sea, add opposite sign companion parton. Store X and I.
21008 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21009 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21010 C...Set pointer to companion
21011 IMI(JS,1,2)=-NVC(JS,-IFL)
21015 C...Update counter number of multiple interactions.
21019 C...Set up starting values for iteration in xT2.
21020 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
21021 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
21022 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
21023 & ISUBSV.NE.96)) THEN
21024 XT2=(1D0-VINT(141))*(1D0-VINT(142))
21027 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
21028 IF(ISET(ISUBSV).EQ.2)
21029 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
21030 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
21032 IF(MSTP(82).LE.1) THEN
21033 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
21034 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
21035 & VINT(317)/(VINT(318)*VINT(320))
21036 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
21038 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
21039 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
21044 C...Iterate downwards in xT2.
21045 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
21048 ELSEIF(MSTP(82).LE.1) THEN
21049 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
21050 IF(XT2.LT.VINT(149)) GOTO 440
21052 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
21053 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
21054 & LOG(PYR(0)))-VINT(149)
21055 IF(XT2.LE.0D0) GOTO 440
21056 XT2=MAX(0.01D0*VINT(149),XT2)
21060 C...Choose tau and y*. Calculate cos(theta-hat).
21061 IF(PYR(0).LE.COEF(ISUB,1)) THEN
21062 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
21063 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
21065 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
21068 C...New: require shat > 1.
21069 IF(TAU*VINT(2).LT.1D0) GOTO 240
21073 IF(RYST.GT.COEF(ISUB,8)) MYST=2
21074 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21075 CALL PYKMAP(2,MYST,PYR(0))
21076 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21078 C...Check that x not used up. Accept or reject kinematical variables.
21079 X1M=SQRT(TAU)*EXP(VINT(22))
21080 X2M=SQRT(TAU)*EXP(-VINT(22))
21081 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
21082 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
21083 CALL PYSIGH(NCHN,SIGS)
21084 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
21085 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
21086 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
21088 C...Reset K, P and V vectors.
21096 PT=0.5D0*VINT(1)*SQRT(XT2)
21098 C...Choose flavour of reacting partons (and subprocess).
21103 ICONMI=ISIG(ICHN,3)
21104 RSIGS=RSIGS-SIGH(ICHN)
21105 IF(RSIGS.LE.0D0) GOTO 280
21108 C...Reassign to appropriate process codes.
21109 280 ISUBMI=ICONMI/10
21110 ICONMI=MOD(ICONMI,10)
21112 C...Choose new quark flavour for annihilation graphs
21113 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
21115 CALL PYWIDT(21,SH,WDTP,WDTE)
21116 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
21117 DO 300 I=1,MDCY(21,3)
21118 KFLF=KFDP(I+MDCY(21,2)-1,1)
21119 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
21120 IF(RKFL.LE.0D0) GOTO 310
21122 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
21123 IF(KFLF.GE.4) GOTO 290
21124 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
21127 ELSEIF(ISUBMI.EQ.53) THEN
21133 C...Final state flavours and colour flow: default values
21140 IF(ISUBMI.EQ.11) THEN
21141 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
21143 IF(KFL1*KFL2.LT.0) KCC=KCC+2
21145 ELSEIF(ISUBMI.EQ.12) THEN
21146 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
21147 KFL3=ISIGN(KFLF,KFL1)
21151 ELSEIF(ISUBMI.EQ.13) THEN
21152 C...f + fbar -> g + g; th arbitrary
21157 ELSEIF(ISUBMI.EQ.28) THEN
21158 C...f + g -> f + g; th = (p(f)-p(f))**2
21159 IF(KFL1.EQ.21) JS=2
21161 IF(KFL1.EQ.21) KCC=KCC+2
21162 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
21163 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
21165 ELSEIF(ISUBMI.EQ.53) THEN
21166 C...g + g -> f + fbar; th arbitrary
21167 KCS=(-1)**INT(1.5D0+PYR(0))
21168 KFL3=ISIGN(KFLF,KCS)
21172 ELSEIF(ISUBMI.EQ.68) THEN
21173 C...g + g -> g + g; th arbitrary
21175 KCS=(-1)**INT(1.5D0+PYR(0))
21178 C...Store flavours of scattering.
21186 C...Set flavours and mothers of scattering partons.
21195 K(N+1,3)=MINT(83)+1
21196 K(N+2,3)=MINT(83)+2
21200 C...Store colour connection indices.
21203 IF(KCS.EQ.-1) JC=3-J
21204 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
21205 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
21206 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
21207 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
21210 C...Store incoming and outgoing partons in their CM-frame.
21211 SHR=SQRT(TAU)*VINT(1)
21214 P(N+2,3)=-0.5D0*SHR
21216 P(N+3,5)=PYMASS(K(N+3,2))
21217 P(N+4,5)=PYMASS(K(N+4,2))
21218 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
21219 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
21220 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
21221 P(N+4,4)=SHR-P(N+3,4)
21224 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
21226 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
21228 C...Set up default values before showers.
21229 MINT(31)=MINT(31)+1
21238 C...Showering of initial state partons (optional).
21239 C...Note: no showering of final state partons here; it comes later.
21240 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21247 KSAV(I,J)=K(N-4+I,J)
21248 PSAV(I,J)=P(N-4+I,J)
21251 CALL PYSSPA(IPU1,IPU2)
21253 C...If shower failed then restore to situation before shower.
21254 IF(MINT(51).GE.1) THEN
21258 K(N-4+I,J)=KSAV(I,J)
21259 P(N-4+I,J)=PSAV(I,J)
21269 C...Keep track of loose colour ends and information on scattering.
21270 370 IMI(1,MINT(31),1)=IPU1
21271 IMI(2,MINT(31),1)=IPU2
21272 IMI(1,MINT(31),2)=0
21273 IMI(2,MINT(31),2)=0
21274 XMI(1,MINT(31))=VINT(141)
21275 XMI(2,MINT(31))=VINT(142)
21276 PT2MI(MINT(31))=VINT(54)
21279 C...Decide whether quarks in last scattering were valence, companion or
21283 KFSBM=ISIGN(1,MINT(10+JS))
21284 IFL=K(IMI(JS,MINT(31),1),2)
21285 IMI(JS,MINT(31),2)=0
21286 IF (IABS(IFL).GT.6) GOTO 430
21288 C...Get PDFs at X and Q2 of the parton shower initiator for the
21289 C...last scattering. At this point VINT(143:144) do not yet
21290 C...include the scattered x values VINT(141:142).
21291 X=VINT(140+JS)/VINT(142+JS)
21292 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21297 C...Note: XPSVC = x*pdf.
21300 C.... Store side in MINT(124)
21303 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
21307 DO 380 IVC=1,NVC(JS,IFL)
21308 CMP=CMP+XPSVC(IFL,IVC)
21311 C...Decide (Extra factor x cancels in the dvision).
21312 RVCS=PYR(0)*(SEA+VAL+CMP)
21314 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
21315 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21317 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
21318 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
21319 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
21320 IF(KFIVAL(JS,1).EQ.0) THEN
21321 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
21322 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
21323 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
21324 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
21326 DO 400 I1=1,NMI(JS)
21327 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
21331 IF(IVNOW.EQ.0) GOTO 390
21333 IMI(JS,MINT(31),2)=0
21334 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21335 IF(KFIVAL(JS,1).EQ.0) THEN
21336 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21339 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21341 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21342 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21346 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
21347 C...If sea, add opposite sign companion parton. Store X and I.
21348 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21349 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21350 C...Set pointer to companion
21351 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
21353 C...If companion, decide which one.
21357 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
21358 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
21359 C...Find original sea (anti-)quark:
21361 DO 420 I1=1,NMI(JS)
21362 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
21363 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
21364 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
21365 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
21368 C...Change X to what associated companion had, so that the correct
21369 C...amount of momentum can be subtracted from the companion sum below.
21370 X=XASSOC(JS,IFL,ISEL)
21371 C...Mark companion read.
21372 XASSOC(JS,IFL,ISEL)=0D0
21376 C...Global statistics.
21377 MINT(351)=MINT(351)+1
21378 VINT(351)=VINT(351)+PT
21379 IF (MINT(351).EQ.1) VINT(356)=PT
21381 C...Update remaining energy and other counters.
21382 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
21383 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
21389 VINT(151)=VINT(151)+VINT(41)
21390 VINT(152)=VINT(152)+VINT(42)
21391 VINT(143)=VINT(143)-VINT(141)
21392 VINT(144)=VINT(144)-VINT(142)
21394 C...Iterate, with more interactions allowed.
21395 IF(MINT(31).LT.240) GOTO 240
21398 C...Restore saved quantities for hardest interaction.
21414 C...Format statements for printout.
21415 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
21416 &'actions for MSTP(82) =',I2,' ******')
21417 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21418 &D9.2,' mb: rejected')
21419 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21420 &D9.2,' mb: accepted')
21425 C*********************************************************************
21428 C...Finds left-behind remnant flavour content and hooks up
21429 C...the colour flow between the hard scattering and remnants
21433 C...Double precision and integer declarations.
21434 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21435 IMPLICIT INTEGER(I-N)
21436 INTEGER PYK,PYCHGE,PYCOMP
21437 C...The event record
21438 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21440 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21441 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21442 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21443 COMMON/PYINT1/MINT(400),VINT(400)
21444 C...The common block of dangling ends
21445 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
21446 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
21447 & XMI(2,240),PT2MI(240),IMISEP(0:240)
21448 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
21449 C...Local variables
21450 PARAMETER (NERSIZ=4000)
21451 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
21453 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
21454 SAVE /PYCBLS/,/PYCTAG/
21455 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
21456 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
21459 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)
21461 C...Set up error checkers
21464 C...Initialize colour arrays: MCO (Original) and MCT (New)
21465 DO 110 I=MINT(84)+1,NERSIZ
21470 C...Also zero colour tracing information, if existed.
21472 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21473 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21477 C...Initialize colour tag collapse arrays:
21478 C...JCCO (Original) and JCCN (New).
21479 DO 130 MG=MINT(84)+1,NERSIZ
21486 C...Zero gluon insertion array
21493 C...Compute hard scattering system rapidities
21494 IF (MSTP(89).EQ.1) THEN
21496 IF (IM.LE.MINT(31)) THEN
21497 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
21499 C...Set (unsigned) rapidity = 100 for beam remnant systems.
21505 C...Treat each side separately
21508 C...Initialize side.
21511 KFS=ISIGN(1,MINT(10+JS))
21513 C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
21514 IF(KFIVAL(JS,1).EQ.0) THEN
21515 IF(MINT(10+JS).EQ.111) THEN
21516 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
21517 KFIVAL(JS,2)=-KFIVAL(JS,1)
21518 ELSEIF(MINT(10+JS).EQ.22) THEN
21521 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
21522 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
21523 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
21524 KFIVAL(JS,2)=-KFIVAL(JS,1)
21525 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
21526 IF(PYR(0).GT.0.5D0) THEN
21536 C...Initialize beam remnant sea and valence content flavour by flavour.
21540 C...Count up original number of JFA valence quarks and antiquarks.
21545 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
21546 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
21548 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
21549 C...Subtract kicked out valence and determine sea from flavour cons.
21550 DO 180 IM=1,NMI(JS)
21551 IFL = K(IMI(JS,IM,1),2)
21554 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
21555 C...Subtract K.O. valence quark from remainder.
21557 JV=NVSUM(JS)-NVALQ-NVALQB
21558 IV(JS,JV)=IMI(JS,IM,1)
21559 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
21560 C...Subtract K.O. valence antiquark from remainder.
21562 JV=NVSUM(JS)-NVALQ-NVALQB
21563 IV(JS,JV)=IMI(JS,IM,1)
21564 ELSEIF (IFA.EQ.JFA) THEN
21565 C...Outside sea without companion: add opposite sea flavour inside.
21566 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
21569 C...Check if space left in PYJETS for additional BR flavours
21570 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
21571 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
21572 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
21573 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
21577 C...Add required val+sea content to beam remnant.
21578 IF (NFLSUM.GT.0) THEN
21580 C...Insert beam remnant quark as p.t. symbolic parton in ER.
21588 K(N,2)=ISIGN(JFA,NSEA)
21589 IF (IA.LE.NVALQ) K(N,2)=JFA
21590 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
21592 C...Also update NMI, IMI, and IV arrays.
21594 IMI(JS,NMI(JS),1)=N
21595 IMI(JS,NMI(JS),2)=-1
21596 IF (IA.LE.NVALQ+NVALQB) THEN
21597 IMI(JS,NMI(JS),2)=0
21599 IV(JS,JV)=IMI(JS,NMI(JS),1)
21607 IF (IM.LE.NMI(JS)) THEN
21608 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
21610 C...Add fictitious parent gluons for companion pairs.
21611 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
21612 C...Randomly assign companions to sea quarks which have none.
21613 IF (IMI(JS,IM,2).LT.0) THEN
21615 230 IMC=MOD(IMC,NMI(JS))+1
21616 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
21617 IF (IMI(JS,IMC,2).GE.0) GOTO 230
21618 IMI(JS, IM,2) = IMI(JS,IMC,1)
21619 IMI(JS,IMC,2) = IMI(JS, IM,1)
21621 C...Add fictitious parent gluon
21631 C...Set gluon (anti-)colour daughter pointers
21632 K(N,4)=IMI(JS, IM,1)
21633 K(N,5)=IMI(JS, IM,2)
21634 C...Set quark (anti-)colour parent pointers
21635 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
21636 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
21637 C...Add gluon to IMI
21639 IMI(JS,NMI(JS),1)=N
21640 IMI(JS,NMI(JS),2)=0
21645 C...If incoming (anti-)baryon, insert inside (anti-)junction.
21646 C...Set up initial v-v-j-v configuration. Otherwise set up
21647 C...mesonic v-vbar configuration
21648 IF (IABS(MINT(10+JS)).GT.1000) THEN
21649 C...Determine junction type (1: B=1 2: B=-1)
21650 ITJUNC(JS) = (3-KFS)/2
21651 C...Insert junction.
21658 C...Set special junction codes:
21661 C...Set parent to side.
21663 K(N,4)=ITJUNC(JS)*MSTU(5)
21665 C...Connect valence quarks to junction.
21668 C...Set (anti)colour mother = junction.
21670 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21672 C...Keep track of partons adjacent to junction:
21673 JST(JS,JV)=IV(JS,JV)
21676 C...Mesons: set up initial q-qbar topology
21678 IF (K(IV(JS,1),2).GT.0) THEN
21689 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21690 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21691 C...Special for mesons. Insert gluon if BR empty.
21692 IF (NBRTOT(JS).EQ.0) THEN
21706 C...Add gluon to IMI
21708 IMI(JS,NMI(JS),1)=N
21709 IMI(JS,NMI(JS),2)=0
21714 C...Count up number of valence quarks outside BR.
21716 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
21717 & MOUT(JS)=MOUT(JS)+1
21722 C...Now both sides have been prepared in an initial vvjv (baryonic) or
21723 C...v(g)vbar (mesonic) configuration.
21725 C...Create colour line tags starting from initiators.
21727 DO 320 IM=1,MINT(31)
21728 C...Consider each side in turn.
21733 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
21735 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
21738 CALL PYCTTR(I1,KCS,I2)
21739 IF(MINT(51).NE.0) RETURN
21746 C...Create colour tags for beam remnant partons.
21747 DO 330 IM=MINT(31)+1,NMI(JS)
21749 IF (K(IP,2).NE.21) THEN
21750 JC=(3-ISIGN(1,K(IP,2)))/2
21751 IF (MCT(IP,JC).EQ.0) THEN
21760 C...Fictituous gluons just inherit from their quark daughters.
21764 C...Real beam remnant gluons get their own colours
21775 C...Create colour tags for colour lines which are detached from the
21779 DO 350 I=MINT(84)+1,N
21781 C...Look for coloured string endpoint, or (later) leftover gluon.
21782 IF (K(I,1).NE.3) GOTO 350
21784 IF(KC.EQ.0) GOTO 350
21786 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
21788 C...Pick up loose string end with no previous tag.
21790 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
21791 IF(MCT(I,KCS-3).NE.0) GOTO 350
21793 CALL PYCTTR(I,KCS,I)
21794 IF(MINT(51).NE.0) RETURN
21799 C...Store original colour tags
21800 DO 370 I=MINT(84)+1,N
21805 C...Iteratively add gluons to already existing string pieces, enforcing
21806 C...various possible orderings, and rejecting insertions that would give
21807 C...rise to singlet gluons.
21808 C...<kappa tau> normalization.
21813 C...Set up simplified kinematics.
21814 C...Boost hard interaction systems.
21816 DO 380 IM=1,MINT(31)
21817 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21818 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21820 C...Assign preliminary beam remnant momenta.
21821 DO 390 I=MINT(53)+1,N
21825 IF (K(I,2).NE.88) THEN
21826 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
21828 IF (JS.EQ.2) P(I,3)=-P(I,3)
21830 C...Junctions are wildcards for the present.
21836 C...Reset colour processing information.
21837 400 DO 410 I=MINT(84)+1,N
21838 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21839 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21844 C...If meson, without gluon in BR, collapse q-qbar colour tags:
21845 IF (ITJUNC(JS).EQ.0) THEN
21846 JC1=MCT(JST(JS,1),1)
21847 JC2=MCT(JST(JS,2),2)
21849 JCCO(NCC,1)=MAX(JC1,JC2)
21850 JCCO(NCC,2)=MIN(JC1,JC2)
21851 C...Collapse colour tags in event record
21852 DO 420 I=MINT(84)+1,N
21853 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
21854 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
21860 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
21861 IF (NG(JS).GT.0) THEN
21864 C...Start at random gluon (optimizes speed for random attachments)
21866 IMGL=PYR(0)*NMI(JS)+1
21867 450 IMGL=MOD(IMGL,NMI(JS))+1
21869 C...Only loop through NMI once (with upper limit to save time)
21870 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
21871 IGL = IMI(JS,IMGL,1)
21872 C...If not gluon or if already connected, try next.
21873 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
21874 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
21875 C...Now loop through all possible insertions of this gluon.
21877 IMP1=PYR(0)*NMI(JS)+1
21878 460 IMP1=MOD(IMP1,NMI(JS))+1
21880 IF (IMP1.EQ.IMGL) GOTO 460
21881 C...Only loop through NMI once (with upper limit to save time).
21882 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
21883 IP1 = IMI(JS,IMP1,1)
21884 C...Try both colour mother and colour anti-mother.
21885 C...Randomly select which one to try first.
21888 470 MANTI=MOD(MANTI+1,2)
21890 IF (NANTI.LE.2) THEN
21891 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
21892 C...Reject if no appropriate mother (or if mother is fictitious
21894 IF (IP2.LE.0) GOTO 470
21895 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
21896 C...Also reject if this link has already been tried.
21897 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21898 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21899 C...Set flag to indicate that this link has now been tried for this
21900 C...gluon. IP2 may be junction, which has several mothers.
21901 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
21902 IF (K(IP2,2).NE.88) THEN
21903 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
21906 C...JCG1: Original colour tag of gluon on IP1 side
21907 C...JCG2: Original colour tag of gluon on IP2 side
21908 C...JCP1: Original colour tag of IP1 on gluon side
21909 C...JCP2: Original colour tag of IP2 on gluon side.
21910 JCG1=MCO(IGL,2-MANTI)
21911 JCG2=MCO(IGL,1+MANTI)
21912 JCP1=MCO(IP1,1+MANTI)
21913 JCP2=MCO(IP2,2-MANTI)
21915 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
21916 C...Reject gluon attachments that give rise to singlet gluons.
21917 IF (MACCPT.EQ.0) GOTO 470
21920 JCG1=MCT(IGL,2-MANTI)
21921 JCG2=MCT(IGL,1+MANTI)
21922 JCP1=MCT(IP1,1+MANTI)
21923 JCP2=MCT(IP2,2-MANTI)
21925 C...Select whether to accept this insertion
21926 IF (MSTP(89).EQ.0) THEN
21927 C...Random insertions: no measure.
21929 C...For random ordering, we want to suppress beam remnant breakups
21930 C...already at this point.
21931 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
21932 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
21937 ELSEIF (MSTP(89).EQ.1) THEN
21938 C...Rapidity ordering:
21939 C...YGL = Rapidity of gluon.
21941 C...If fictitious gluon
21942 IF (YGL.EQ.100D0) THEN
21944 IDA1=MOD(K(IGL,4),MSTU(5))
21945 IDA2=MOD(K(IGL,5),MSTU(5))
21946 DO 480 IMT=1,NMI(JS)
21947 C...Select (arbitrarily) the most central daughter.
21948 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21950 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
21954 C...YP1 = Rapidity IP1
21956 C...If fictitious gluon
21957 IF (YP1.EQ.100D0) THEN
21959 IDA1=MOD(K(IP1,4),MSTU(5))
21960 IDA2=MOD(K(IP1,5),MSTU(5))
21961 DO 490 IMT=1,NMI(JS)
21962 C...Select (arbitrarily) the most central daughter.
21963 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21965 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
21969 C...YP2 = Rapidity of mother system
21970 IF (K(IP2,2).NE.88) THEN
21971 DO 500 IMT=1,NMI(JS)
21972 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
21974 C...If fictitious gluon
21975 IF (YP2.EQ.100D0) THEN
21977 IDA1=MOD(K(IP2,4),MSTU(5))
21978 IDA2=MOD(K(IP2,5),MSTU(5))
21979 DO 510 IMT=1,NMI(JS)
21980 C...Select (arbitrarily) the most central daughter.
21981 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
21983 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
21987 C...Assign (arbitrarily) 100D0 to junction also
21991 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
21992 ELSEIF (MSTP(89).EQ.2) THEN
21993 C...Lambda ordering:
21994 C...Compute lambda measure for this insertion.
21999 C...If IP2 is junction, not caught below.
22000 IF (JCP2.EQ.0) THEN
22001 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
22002 C...Anti-junction is colour endpoint et vv., always on JCG2.
22005 DO 530 I=MINT(84)+1,N
22006 IF (K(I,1).LT.10) THEN
22007 C...The new string pieces
22008 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
22009 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
22010 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
22011 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
22014 C...Also identify junctions as string endpoints.
22015 DO 540 I=MINT(84)+1,N
22016 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
22017 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
22018 C...Find partons adjacent to junctions.
22019 IF (ICMO.GT.0.AND.ICMO.LE.N) THEN
22020 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
22021 & .EQ.0) ISTR(2) = ICMO
22022 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
22023 & .EQ.0) ISTR(4) = ICMO
22025 IF (IAMO.GT.0.AND.IAMO.LE.N) THEN
22026 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
22027 & .EQ.0) ISTR(1) = IAMO
22028 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
22029 & .EQ.0) ISTR(3) = IAMO
22032 C...The old string piece
22033 ISTR(5)=ISTR(1+2*MANTI)
22034 ISTR(6)=ISTR(4-2*MANTI)
22035 IF (ISTR(1).EQ.0.OR.ISTR(2).EQ.0.OR.ISTR(3).EQ.0.OR.
22036 & ISTR(4).EQ.0.OR.ISTR(5).EQ.0.OR.ISTR(6).EQ.0) THEN
22037 C...If one or more of the colour tags for this connection is/are still
22038 C...dangling, skip this attempt for the time being.
22041 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
22042 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
22046 C...Allow some breadth to speed things up.
22047 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
22049 ELSEIF (RL.GT.RLOPT) THEN
22055 C...INSR(NOPT,1)=Gluon colour mother
22056 C...INSR(NOPT,2)=Gluon
22057 C...INSR(NOPT,3)=Gluon anticolour mother
22058 IF (NOPT.GT.1000) GOTO 470
22059 INSR(NOPT,1+2*MANTI)=IP2
22061 INSR(NOPT,3-2*MANTI)=IP1
22062 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
22064 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
22066 C...Reset link test information.
22067 DO 550 I=MINT(84)+1,N
22068 K(I,4)=MOD(K(I,4),MSTU(5)**2)
22069 K(I,5)=MOD(K(I,5),MSTU(5)**2)
22071 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
22073 C...Now we have a list of best gluon insertions, none of which cause
22074 C...singlets to arise. If list is empty, try again a few times. Note:
22075 C...this should never happen if we have a meson with a gluon inserted
22076 C...in the beam remnant, since that breaks up the colour line.
22077 IF (NOPT.EQ.0) THEN
22078 C...Abandon BR-g-BR suppression for retries. This is not serious, it
22079 C...just means we happened to start with trying a bad sequence.
22081 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
22082 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
22085 IF (ITJUNC(JS).NE.0) THEN
22089 C...Reset valence quark parent pointers
22090 DO 560 I=MINT(53)+1,N
22091 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
22094 C...Set (anti)colour mother = junction.
22096 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
22100 C...Same for mesons. JST unchanged, so needn't be restored.
22103 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
22104 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
22106 C...Also reset gluon parent pointers.
22108 DO 580 IM=1,NMI(JS)
22110 IF (K(I,2).EQ.21) THEN
22111 K(I,4)=MOD(K(I,4),MSTU(5))
22112 K(I,5)=MOD(K(I,5),MSTU(5))
22117 C...Reset colour tags
22118 DO 600 I=MINT(84)+1,N
22124 IF(NERRPR.LT.5) THEN
22127 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
22128 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
22130 C...Kill event and start another.
22135 C...Select between insertions, suppressing insertions wholly in the BR.
22137 610 IIN=MOD(IIN,NOPT)+1
22138 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
22139 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
22142 C...Now we know which gluon to insert where. Colour tags in JCCO and
22143 C...colour connection information should be updated, NG(JS) should be
22144 C...counted down, and a new loop performed if there are still gluons
22145 C...left on any side.
22149 C...JCG : Original gluon colour tag
22150 C...JCAG: Original gluon anticolour tag.
22151 C...JCM : Original anticolour tag of gluon colour mother
22152 C...JACM: Original colour tag of gluon anticolour mother
22158 CALL PYMIHG(JACM,JACG,JCM,JCG)
22159 IF (MACCPT.EQ.0) THEN
22160 IF(NERRPR.LT.5) THEN
22163 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
22164 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
22166 C...Kill event and start another.
22170 C...If everything went fine, store new JCCN in JCCO.
22173 JCCO(ICC,1)=JCCN(ICC,1)
22174 JCCO(ICC,2)=JCCN(ICC,2)
22178 C...One gluon attached is counted as equivalent to one end outside.
22180 C...Set IGL colour mother = ICM.
22181 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
22182 C...Set ICM anticolour mother = IGL colour.
22183 IF (K(ICM,2).NE.88) THEN
22184 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
22186 C...If ICM is junction, just update JST array for now.
22188 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
22191 C...Set IGL anticolour mother = IACM.
22192 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
22193 C...Set IACM anticolour mother = IGL anticolour.
22194 IF (K(IACM,2).NE.88) THEN
22195 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
22197 C...If IACM is junction, just update JST array for now.
22199 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
22202 C...Count down # unconnected gluons.
22205 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
22208 C...Collapse fictitious gluons.
22209 DO 670 IGL=MINT(53)+1,N
22210 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
22211 & K(IGL,1).EQ.14) THEN
22212 ICM=K(IGL,4)/MSTU(5)
22213 IAM=K(IGL,5)/MSTU(5)
22214 ICD=MOD(K(IGL,4),MSTU(5))
22215 IAD=MOD(K(IGL,5),MSTU(5))
22216 C...Set gluon daughters pointing to gluon mothers
22217 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
22218 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
22219 C...Set gluon mothers pointing to gluon daughters.
22220 IF (K(ICM,2).NE.88) THEN
22221 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
22223 C...Special case: mother=junction. Just update JST array for now.
22225 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
22228 IF (K(IAM,2).NE.88) THEN
22229 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
22232 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
22238 C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
22241 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
22242 IF (IM.GT.MINT(31)) THEN
22244 DO 690 IMR=IM,NMI(JS)
22245 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
22246 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
22251 C...Finally, connect junction.
22252 IF (ITJUNC(JS).NE.0) THEN
22253 DO 700 I=MINT(53)+1,N
22254 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
22256 C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
22261 C...Find jq with no glue inbetween inside beam remnant.
22262 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
22265 C...Set IDQ = -I if q non-valence and = +I if q valence.
22266 IDQ(NBRJQ)=-JST(JS,MSJ)
22268 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
22269 IDQ(NBRJQ)=JST(JS,MSJ)
22276 IF (MSJ.EQ.3) I45=4
22277 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
22280 C...Check if diquark can be formed.
22281 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
22283 C...If there is less than 2 valence quarks connected to junction
22284 C...and MSTP(88)>1, use random non-valence quarks to fill up.
22285 IF (NBRVQ.LE.1) THEN
22287 730 JFLIP=NBRJQ*PYR(0)+1
22288 IF (IDQ(JFLIP).LT.0) THEN
22289 IDQ(JFLIP)=-IDQ(JFLIP)
22292 IF (NDIQ.LE.1) GOTO 730
22294 C...Place selected quarks first in IDQ, ordered in flavour.
22296 IF (IDQ(JDQ).LE.0) THEN
22300 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
22307 C...Choose diquark spin.
22308 IF (NBRVQ.EQ.2) THEN
22309 C...If the selected quarks are both valence, we may use SU(6) rules
22310 C...to figure out which spin the diquark has, by a subdivision of the
22311 C...original beam hadron into the selected diquark system plus a kicked
22312 C...out quark, IKO.
22316 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
22320 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
22322 C...If one or more of the selected quarks are not valence, we cannot use
22323 C...SU(6) subdivisions of the original beam hadron. Instead, with the
22324 C...flavours of the diquark already selected, we assume for now
22325 C...50:50 spin-1:spin-0 (where spin-0 possible).
22326 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
22328 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
22329 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
22330 KFDQ=KFDQ+ISIGN(IS,KFDQ)
22333 C...Collapse diquark-j-quark system to baryon, if allowed and possible.
22334 C...Note: third quark can per definition not also be valence,
22335 C...therefore we can only do this if we are allowed to use sea quarks.
22336 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
22339 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
22340 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
22342 ELSEIF(NTRY.GT.100) THEN
22343 C...If no baryon can be found, give up and form diquark.
22347 C...Replace junction by baryon.
22350 K(IJU,3)=MINT(83)+JS
22353 P(IJU,5)=PYMASS(KFBAR)
22355 C...Prepare removal of participating quarks from ER.
22356 K(JST(JS,MSJ),1)=-1
22360 C...If collapse to baryon not possible or not allowed, replace junction
22361 C...by diquark. This way, collapsed gluons that were pointing at the
22362 C...junction will now point (correctly) at diquark.
22366 K(IJU,3)=MINT(83)+JS
22371 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
22373 K(IJU,5-MANTI)=IP*MSTU(5)
22374 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
22376 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
22378 C...Prepare removal of participating quarks from ER.
22384 C...Update so ER pointers to collapsed quarks
22385 C...now go to collapsed object.
22386 DO 820 I=MINT(84)+1,N
22387 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
22388 & .K(I,1).GT.0) THEN
22390 IMO=K(I,ISID)/MSTU(5)
22391 IDA=MOD(K(I,ISID),MSTU(5))
22393 IF (K(IMO,1).EQ.-1) IMO=IJU
22396 IF (K(IDA,1).EQ.-1) IDA=IJU
22398 K(I,ISID)=IDA+MSTU(5)*IMO
22405 C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
22406 C...(this only happens for baryons, where we want to force the gluon
22407 C...to sit next to the junction. Mesons handled above.)
22408 IF (NBRTOT(JS).EQ.0) THEN
22418 K(IGL,3)=MINT(83)+JS
22419 IF (ITJUNC(JS).NE.0) THEN
22420 C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
22421 JLEG=PYR(0)*NVSUM(JS)+1
22424 JCT=MCT(I1,ITJUNC(JS))
22425 MCT(IGL,3-ITJUNC(JS))=JCT
22427 MCT(IGL,ITJUNC(JS))=NCT
22430 C...Meson. Should not happen.
22431 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
22432 IF(NERRPR.LT.5) THEN
22433 WRITE(MSTU(11),*) 'This should not have been possible!'
22440 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
22441 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
22442 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
22443 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
22444 IF (K(I2,2).NE.88) THEN
22445 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
22447 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
22448 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
22449 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
22450 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
22452 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
22458 C...Remove collapsed quarks and junctions from ER and update IMI.
22461 C...Also update beam remnant part of IMI.
22464 DO 850 I=MINT(53)+1,N
22465 IF (K(I,1).LE.0) GOTO 850
22466 C...Restore BR quark/diquark/baryon pointers in IMI.
22467 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
22470 IMI(JS,NMI(JS),1)=I
22471 IMI(JS,NMI(JS),2)=0
22475 C...Restore companion information from collapsed gluons.
22476 DO 870 I=MINT(53)+1,N
22477 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
22479 JCD=MOD(K(I,4),MSTU(5))
22480 JAD=MOD(K(I,5),MSTU(5))
22481 DO 860 IM=1,NMI(JS)
22482 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
22483 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
22485 IMI(JS,IMC,2)=IMI(JS,IMA,1)
22486 IMI(JS,IMA,2)=IMI(JS,IMC,1)
22490 C...Renumber colour lines (since some have disappeared)
22498 IF (MFOUND.EQ.0) JCD=JCD+1
22499 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
22502 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
22506 IF (I.LE.N) GOTO 890
22507 IF (JCT.LT.NCT) GOTO 880
22510 C...Reset hard interaction subsystems to their CM frames.
22511 IF (IBOOST.EQ.1) THEN
22512 DO 900 IM=1,MINT(31)
22513 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22514 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
22516 C...Zero beam remnant longitudinal momenta and energies
22517 DO 910 I=MINT(53)+1,N
22523 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
22524 C...Kill event and start another.
22531 C*********************************************************************
22534 C...Adapted from PYPREP.
22535 C...Assigns LHA1 colour tags to coloured partons based on
22536 C...K(I,4) and K(I,5) colour connection record.
22537 C...KCS negative signifies that a previous tracing should be continued.
22538 C...(in case the tag to be continued is empty, the routine exits)
22539 C...Starts at I and ends at I or IEND.
22540 C...Special considerations for systems with junctions.
22541 C...Special: if IEND=-1, means trace this parton to its color partner,
22542 C... then exit. If no partner found, exit with 0.
22544 SUBROUTINE PYCTTR(I,KCS,IEND)
22545 C...Double precision and integer declarations.
22546 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22547 INTEGER PYK,PYCHGE,PYCOMP
22549 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22550 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22551 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22552 COMMON/PYINT1/MINT(400),VINT(400)
22553 C...The common block of colour tags.
22554 COMMON/PYCTAG/NCT,MCT(4000,2)
22555 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
22559 C...Skip if parton not existing or does not have KCS
22560 IF (K(I,1).LE.0) GOTO 120
22562 IF (KC.EQ.0) GOTO 120
22564 IF (KQ.EQ.0) GOTO 120
22565 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
22570 C...Set colour tag of first parton.
22576 IF (NCS.EQ.0) GOTO 120
22582 IF(NSTP.GT.4*N) THEN
22583 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
22587 C...Finished if reached final-state triplet.
22588 IF(K(IA,1).EQ.3) THEN
22589 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
22592 C...Also finished if reached junction.
22593 IF(K(IA,1).EQ.42) THEN
22597 C...GOTO next parton in colour space.
22599 C...If IB's KCS daughter not traced and exists, goto KCS daughter.
22600 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
22602 IA=MOD(K(IB,KCS),MSTU(5))
22603 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
22606 C...If KCS mother traced or KCS mother nonexistent, switch colour.
22607 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
22608 & MSTU(5)).EQ.0) THEN
22612 C...Assign new colour tag on other side of old parton.
22615 C...Goto (new) KCS mother, set mother traced tag
22616 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
22617 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
22620 IF(IA.LE.0.OR.IA.GT.N) THEN
22621 IF (IEND.EQ.-1) THEN
22625 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
22626 IF(NERRPR.LT.5) THEN
22627 write(*,*) 'began at ',I
22628 write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
22629 & ' NCS=',NCS,' MREV=',MREV
22636 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
22637 & MSTU(5)).EQ.IB) THEN
22638 IF(MREV.EQ.1) KCS=9-KCS
22639 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
22640 C...Set KSC mother traced tag for IA
22641 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
22643 IF(MREV.EQ.0) KCS=9-KCS
22644 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
22645 C...Set KCS daughter traced tag for IA
22646 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
22648 C...Assign new colour tag
22650 C...Finish if IEND=-1 and found final-state color partner
22651 IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN
22655 IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100
22660 *********************************************************************
22663 C...Collapse JCP1 and connecting tags to JCG1.
22664 C...Collapse JCP2 and connecting tags to JCG2.
22666 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
22667 C...Double precision and integer declarations.
22668 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22669 IMPLICIT INTEGER(I-N)
22670 INTEGER PYK,PYCHGE,PYCOMP
22671 C...The event record
22672 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22674 COMMON/PYINT1/MINT(400),VINT(400)
22675 SAVE /PYJETS/,/PYINT1/
22676 C...Local variables
22677 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
22678 COMMON /PYCTAG/NCT,MCT(4000,2)
22679 SAVE /PYCBLS/,/PYCTAG/
22681 C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
22682 C...in temporary tag collapse array JCCN. Only break up one connection.
22686 JCCN(ICC,1)=JCCO(ICC,1)
22687 JCCN(ICC,2)=JCCO(ICC,2)
22688 C...If there was a mother, it was previously connected to JCP1.
22689 C...Should be changed to JCP2.
22690 IF (MCLPS.EQ.0) THEN
22691 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
22693 JCCN(ICC,1)=MAX(JCG2,JCP2)
22694 JCCN(ICC,2)=MIN(JCG2,JCP2)
22699 C...Also collapse colours on JCP1 side of JCG1
22700 IF (JCP1.NE.0) THEN
22701 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
22702 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
22704 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
22705 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
22708 C...Initialize event record colour tag array MCT array to MCO.
22709 DO 110 I=MINT(84)+1,N
22715 C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
22716 C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
22717 C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
22718 C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
22720 C...Skip if junction.
22721 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
22722 C...Define starting point in tag space.
22723 C...JCA = previous tag
22724 C...JCO = present tag
22726 IF (MOD(IS,2).EQ.1) THEN
22730 ELSEIF (MOD(IS,2).EQ.0) THEN
22736 120 ITRACE=ITRACE+1
22737 IF (ITRACE.GT.1000) THEN
22738 C...NB: Proper error message should be defined here.
22740 & ,'(PYMIHG:) Inf loop when collapsing colours.')
22741 MINT(57)=MINT(57)+1
22745 C...Collapse all JCN tags to JCALL
22746 DO 130 I=MINT(84)+1,N
22747 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22748 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22750 C...IS = 1,2: first step forward. IS = 3,4: first step backward.
22751 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
22758 C...If possible, step from JCO to new tag JCN not equal to JCA.
22760 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
22762 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
22765 C...Iterate if new colour was arrived at, but don't go in circles.
22766 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
22767 C...Change all JCN tags in MCO to JCALL in MCT.
22768 DO 150 I=MINT(84)+1,N
22769 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22770 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22771 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22772 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22777 DO 200 JCL=NCT,1,-1
22782 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
22784 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
22787 C...Overpaint all JCN with JCL
22788 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
22789 DO 190 I=MINT(84)+1,N
22790 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
22791 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
22792 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22793 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22804 C*********************************************************************
22807 C...Picks primordial kT and shares longitudinal momentum among
22812 C...Double precision and integer declarations.
22813 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22814 IMPLICIT INTEGER(I-N)
22815 INTEGER PYK,PYCHGE,PYCOMP
22816 C...The event record
22817 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22819 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22820 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22821 COMMON/PYINT1/MINT(400),VINT(400)
22822 C...The common block of colour tags.
22823 COMMON/PYCTAG/NCT,MCT(4000,2)
22824 C...The common block of dangling ends
22825 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
22826 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
22827 & XMI(2,240),PT2MI(240),IMISEP(0:240)
22828 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
22829 C...Local variables
22830 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
22831 C...W(I,J)| J=0 | 1 | 2 |
22832 C... I=0 | Wrem**2 | W+ | W- |
22833 C... 1 | W1**2 | W1+ | W1- |
22834 C... 2 | W2**2 | W2+ | W2- |
22836 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)
22837 C...Tentative parametrization of <kT> as a function of Q.
22838 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
22839 C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
22840 C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
22841 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
22842 C...Lambda kinematic function.
22843 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
22845 C...Beginning and end of beam remnant partons
22849 C...Loopback point if kinematic choices gives impossible configuration.
22853 C...Assign kT values on each side separately.
22856 C...First zero all kT on this side. Skip if no kT to generate.
22857 DO 110 IM=1,NMI(JS)
22858 P(IMI(JS,IM,1),1)=0D0
22859 P(IMI(JS,IM,1),2)=0D0
22861 IF(MSTP(91).LE.0) GOTO 180
22863 C...Now assign kT to each (non-collapsed) parton in IMI.
22864 DO 170 IM=1,NMI(JS)
22866 C...Select kT according to truncated gaussian or 1/kt6 tails.
22867 C...For first interaction, either use rms width = PARP(91) or fitted.
22870 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
22875 C...For subsequent interactions and BR partons use fragmentation width.
22880 IF(NTRY.LE.100) THEN
22881 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
22885 ELSEIF (MSTP(91).EQ.2) THEN
22886 CALL PYERRM(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
22887 & 'available, using MSTP(91)=1.')
22888 CALL PYGIVE('MSTP(91)=1')
22890 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
22891 C...Use distribution with kt**6 tails, rms width = PARP(91).
22892 EPS=SQRT(3D0/2D0)*SIGMA
22893 C...Generate PTX and PTY separately, each propto 1/KT**6
22895 C...Decide which interval to try
22896 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
22897 IF (PYR(0).LT.P12) THEN
22898 C...Use flat approx with accept/reject up to EPS.
22900 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
22901 IF (PYR(0).GT.WT) GOTO 112
22903 C...Above EPS, use 1/kt**6 approx with accept/reject.
22904 PT=EPS/(PYR(0)**(1D0/5D0))
22905 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
22906 IF (PYR(0).GT.WT) GOTO 112
22909 IF (PYR(0).GT.0.5D0) MSIGN=-1
22910 IF (IXY.EQ.1) PTX=MSIGN*PT
22911 IF (IXY.EQ.2) PTY=MSIGN*PT
22913 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
22914 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22915 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22917 C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
22918 PT=SQRT(PTX**2+PTY**2)
22920 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
22921 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
22924 PT=SQRT(PTX**2+PTY**2)
22930 C...Compensation kicks, with varying degree of local anticorrelations.
22932 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
22933 PTCX=-PTX/(NMI(JS)-1)
22934 PTCY=-PTY/(NMI(JS)-1)
22935 IF(ISUB.EQ.95) THEN
22936 PTCX=-PTX/(NMI(JS)-2)
22937 PTCY=-PTY/(NMI(JS)-2)
22939 DO 120 IMC=1,NMI(JS)
22940 IF (IMC.EQ.IM) GOTO 120
22941 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
22942 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
22943 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
22945 ELSEIF (MCORR.GE.1) THEN
22948 C...Count up # of neighbours on either side
22950 130 IMO=K(IMO,MSID)/MSTU(5)
22951 IF (IMO.EQ.0) GOTO 140
22952 NNXT(MSID-3)=NNXT(MSID-3)+1
22953 C...Stop at quarks and junctions
22954 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
22956 C...How should compensation be shared when unequal numbers on the
22957 C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
22958 NSUM=NNXT(1)+NNXT(2)
22961 C...Total momentum to be compensated on this side
22962 IF (NNXT(MSID-3).EQ.0) GOTO 160
22963 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
22964 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
22965 C...RS: compensation supression factor as we go out from parton I.
22966 C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
22967 C...since (for now) MSTP(90) provides enough variability.
22969 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
22972 IMO=K(IMO,MSID)/MSTU(5)
22973 IF (IMO.EQ.0) GOTO 160
22975 IF (K(IMO,2).NE.88) THEN
22976 P(IMO,1)=P(IMO,1)+FAC*PTCX
22977 P(IMO,2)=P(IMO,2)+FAC*PTCY
22978 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
22979 C...If we reach junction, divide out the kT that would have been
22980 C...assigned to the junction on each of its other legs.
22982 L1=MOD(K(IMO,4),MSTU(5))
22983 L2=K(IMO,5)/MSTU(5)
22984 L3=MOD(K(IMO,5),MSTU(5))
22985 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
22986 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
22987 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
22988 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
22989 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
22990 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
22991 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
22992 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
22998 C...End assignment of kT values to initiators and remnants.
23001 C...Check kinematics constraints for non-BR partons.
23002 DO 190 IM=1,MINT(31)
23003 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
23004 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
23005 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
23006 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
23007 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
23008 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
23009 IF(NTRY.GE.100) THEN
23010 C...Kill this event and start another.
23012 & '(PYMIRM:) No consistent (x,kT) sets found')
23020 C...Calculate W+ and W- available for combined remnant system.
23023 DO 200 IM=1,MINT(31)
23024 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
23025 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
23026 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
23027 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
23028 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
23030 C...Also store Wrem**2 = W+ * W-
23031 W(0,0)=W(0,1)*W(0,2)
23033 IF ((W(0,0).LT.0D0.OR.W(0,1)+W(0,2).LT.0D0).AND.NTRY.LE.100) THEN
23034 IF(NTRY.GE.100) THEN
23035 C...Kill this event and start another.
23037 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
23044 C...Assign unscaled x values to partons/hadrons in each of the
23045 C...beam remnants and calculate unscaled W+ and W- from them.
23051 DO 270 IM=MINT(31)+1,NMI(JS)
23057 C...Skip collapsed gluons and junctions. Reset.
23058 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
23059 IF (KFA.EQ.88) GOTO 270
23066 C...If gluon then only beam remnant, so takes all.
23069 C...If valence quark then use parametrized valence distribution.
23070 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
23072 C...If companion quark then derive from companion x.
23073 ELSEIF(KFA.LE.6) THEN
23075 C...If valence diquark then use two parametrized valence distributions.
23076 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23078 IVALQ(1)=ISIGN(KFA/1000,KF)
23079 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
23080 C...If valence+sea diquark then combine valence + companion choices.
23081 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23082 & ICOMP.LT.MSTU(5)) THEN
23083 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
23084 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
23086 IVALQ(1)=ISIGN(KFA/1000,KF)
23089 C...Extra code: workaround for diquark made out of two sea
23090 C...quarks, but where not (yet) ICOMP > MSTU(5).
23091 DO 220 IM1=1,MINT(31)
23092 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
23093 ICOMQ(2)=IMI(JS,IM1,1)
23097 C...If sea diquark then sum of two derived from companion x.
23098 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
23099 ICOMQ(1)=MOD(ICOMP,MSTU(5))
23100 ICOMQ(2)=ICOMP/MSTU(5)
23101 C...If meson or baryon then use fragmentation function.
23102 C...Somewhat arbitrary split into old and new flavour, but OK normally.
23104 KFL3=MOD(KFA/10,10)
23105 IF(MOD(KFA/1000,10).EQ.0) THEN
23106 KFL1=MOD(KFA/100,10)
23108 KFL1=MOD(KFA,10000)-10*KFL3-1
23109 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
23110 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
23112 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
23113 CALL PYZDIS(KFL1,KFL3,PR,X)
23117 C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
23118 C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
23119 C...In other baryons combine u and d from proton appropriately.
23120 IF(IVALQ(IQ).NE.0) THEN
23122 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
23123 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
23124 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
23126 IF(KFIVAL(JS,3).EQ.0) THEN
23128 C...Baryon with three identical quarks: mix u and d forms.
23129 ELSEIF(NVAL.EQ.3) THEN
23130 MDU=INT(PYR(0)+5D0/3D0)
23131 C...Baryon, one of two identical quarks: u form.
23132 ELSEIF(NVAL.EQ.2) THEN
23134 C...Baryon with two identical quarks, but not the one picked: d form.
23135 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
23136 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
23138 C...Baryon with three nonidentical quarks: mix u and d forms.
23140 MDU=INT(PYR(0)+5D0/3D0)
23143 IF(MDU.EQ.1) XPOW=3.5D0
23144 IF(MDU.EQ.2) XPOW=2D0
23146 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
23150 C...Calculation of x of companion quark.
23151 IF(ICOMQ(IQ).NE.0) THEN
23153 DO 240 IM1=1,MINT(31)
23154 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
23156 NPOW=MAX(0,MIN(4,MSTP(87)))
23157 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
23158 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
23159 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
23160 IF(CORR.LT.PYR(0)) GOTO 250
23165 C...Optionally enchance x of composite systems (e.g. diquarks)
23166 IF (KFA.GT.100) X=PARP(79)*X
23168 C...Store x. Also calculate light cone energies of each system.
23170 W(JS,JS)=W(JS,JS)+X
23171 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
23173 W(JS,JS)=W(JS,JS)*W(0,JS)
23174 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
23175 W(JS,0)=W(JS,1)*W(JS,2)
23178 C...Check W1 W2 < Wrem (can be done before rescaling, since W
23179 C...insensitive to global rescalings of the BR x values).
23180 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
23183 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
23185 ELSEIF (NTRYX.GT.100) THEN
23186 CALL PYERRM(1,'(PYMIRM:) No consistent (x,kT) sets found')
23187 MINT(57)=MINT(57)+1
23192 C...Compute x rescaling factors
23193 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
23194 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
23195 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
23197 IF (R1.LT.0.OR.R2.LT.0) THEN
23198 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
23199 MINT(57)=MINT(57)+1
23203 C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
23209 C...Rescale BR x values.
23210 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
23211 XMI(1,IM)=XMI(1,IM)*R1
23212 XMI(2,IM)=XMI(2,IM)*R2
23215 C...Now we have a consistent set of x and kT values.
23216 C...First set up the initiators and their daughters correctly.
23217 DO 300 IM=1,MINT(31)
23220 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
23221 & (P(I1,2)+P(I2,2))**2
23222 PT12=P(I1,1)**2+P(I1,2)**2
23223 PT22=P(I2,1)**2+P(I2,2)**2
23225 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
23227 C...Energies (masses should be zero at this stage)
23228 P(I1,4)=SQRT(PT12+P(I1,3)**2)
23229 P(I2,4)=SQRT(PT22+P(I2,3)**2)
23231 C...Transverse 12 system initiator velocity:
23232 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
23233 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
23234 C...Boost to overall initiator system rest frame
23235 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
23236 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
23238 C...Compute phi,theta coordinates of I1 and rotate z axis.
23239 PHI=PYANGL(P(I1,1),P(I1,2))
23240 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
23241 IMIN=IMISEP(IM-1)+1
23242 C...(include documentation lines if MI = 1)
23243 IF (IM.EQ.1) IMIN=MINT(83)+5
23245 C...Rotate entire system in phi
23246 CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
23247 C...Only rotate 12 system in theta
23248 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
23249 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
23251 C...Now boost entire system back to LAB
23252 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
23253 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
23254 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
23259 C...For the beam remnant partons/hadrons, we only need to set pz and E.
23261 DO 310 IM=MINT(31)+1,NMI(JS)
23263 C...Skip collapsed gluons and junctions.
23264 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
23265 IF (KFA.EQ.88) GOTO 310
23266 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
23267 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
23268 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
23269 IF (JS.EQ.2) P(I,3)=-P(I,3)
23274 C...Documentation lines
23280 K(IN,3)=MINT(83)+JS
23287 MCT(IN,1)=MCT(IO,1)
23288 MCT(IN,2)=MCT(IO,2)
23291 C...Final state colour reconnections.
23292 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
23294 C...Number of colour tags for which a recoupling will be tried.
23296 C...Number of recouplings to try
23304 IF (IITER.LE.PARP(78)*NTOT) THEN
23305 C...Select two colour tags at random
23306 C...NB: jj strings do not have colour tags assigned to them,
23307 C...thus they are as yet not affected by anything done here.
23309 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
23314 C...Find final state partons with this (anti)colour
23315 DO 370 I=MINT(84)+1,N
23316 IF (K(I,1).EQ.3) THEN
23317 IF (MCT(I,1).EQ.JCT) IJ1=I
23318 IF (MCT(I,2).EQ.JCT) IJ2=I
23319 IF (MCT(I,1).EQ.KCT) IK1=I
23320 IF (MCT(I,2).EQ.KCT) IK2=I
23323 C...Only consider recouplings not involving junctions for now.
23324 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
23326 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
23327 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
23328 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
23331 C...Count up number of reconnections
23332 MINT(34)=MINT(34)+1
23334 IF (MINT(34).LE.1000) THEN
23337 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
23341 IF (NRECP.LT.MINT(34)) GOTO 350
23343 C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
23349 C*********************************************************************
23352 C...Performs colour annealing.
23353 C...MSTP(95) : CR Type
23354 C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
23355 C... = 2 : Type I(no gg loops); hadron-hadron only
23356 C... = 3 : Type I(no gg loops); all beams
23357 C... = 4 : Type II(gg loops) ; hadron-hadron only
23358 C... = 5 : Type II(gg loops) ; all beams
23359 C... = 6 : Type S ; hadron-hadron only
23360 C... = 7 : Type S ; all beams
23361 C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
23362 C...Type S is driven by starting only from free triplets, not octets.
23363 C...A string piece remains unchanged with probability
23364 C... PKEEP = (1-PARP(78))**N
23365 C...This scaling corresponds to each string piece having to go through
23366 C...N other ones, each with probability PARP(78) for reconnection, where
23367 C...N is here chosen simply as the number of multiple interactions,
23368 C...for a rough scaling with the general level of activity.
23370 SUBROUTINE PYFSCR(IP)
23371 C...Double precision and integer declarations.
23372 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23373 INTEGER PYK,PYCHGE,PYCOMP
23375 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23376 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23377 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23378 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23379 COMMON/PYINT1/MINT(400),VINT(400)
23380 C...The common block of colour tags.
23381 COMMON/PYCTAG/NCT,MCT(4000,2)
23382 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
23384 C...MCN: Temporary storage of new colour tags
23385 INTEGER MCN(4000,2)
23386 C...Arrays for storing color string lengths
23387 INTEGER ICR(4000),MSCR(4000)
23389 DOUBLE PRECISION RLOPTC(4000)
23391 C...Function to give four-product.
23392 FOUR(I,J)=P(I,4)*P(J,4)
23393 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
23395 C...Check valid range of MSTP(95), local copy
23396 IF (MSTP(95).LE.1.OR.MSTP(95).GE.10) RETURN
23397 MSTP95=MOD(MSTP(95),10)
23398 C...Set whether CR allowed inside resonance systems or not
23399 C...(not implemented yet)
23401 C IF (MSTP(95).GE.10) MRESCR=0
23403 C...Check whether colour tags already defined
23404 IF (MINT(33).EQ.0) THEN
23405 C...Erase any existing colour tags for this event
23410 C...Create colour tags for this event
23412 IF (K(I,1).EQ.3) THEN
23415 IF (MCT(I,KCSIN-3).EQ.0) THEN
23416 CALL PYCTTR(I,KCSIN,I)
23421 C...Instruct PYPREP to use colour tags
23425 C...For MSTP(95) even, only apply to hadron-hadron
23428 IF (MOD(MSTP(95),2).EQ.0.AND.(KA1.LT.100.OR.KA2.LT.100)) GOTO 9999
23430 C...Initialize new tag array (but do not delete old yet)
23432 DO 130 I=MAX(1,IP),N
23437 C...For each final-state dipole, check whether string should be
23446 DO 140 I=MAX(1,IP),N
23447 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
23448 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
23450 IF (IC.NE.0.AND.IA.NE.0) THEN
23452 C...Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
23453 C...(so far ignores the possibility that the whole "muck" may be moving.)
23454 IF (PARP(77).GT.0D0) THEN
23455 PT2STR=(P(IA,1)+P(IC,1))**2+(P(IA,2)+P(IC,2))**2
23456 C...For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
23457 IF (KA1.LT.100.AND.KA2.LT.100) THEN
23458 P2STR = PT2STR + (P(IA,3)+P(IC,3))**2
23460 P2STR = 3D0/2D0 * PT2STR
23462 RM2STR=(P(IA,4)+P(IC,4))**2-(P(IA,3)+P(IC,3))**2-PT2STR
23463 RM2STR=MAX(RM2STR,PMAS(PYCOMP(111),1)**2)
23464 C...Estimate number of particles ~ log(M2), cut off at 1.
23465 RLOGM2=MAX(1D0,LOG(RM2STR))
23467 C...Supress reconnection probability by 1/(1+P77*P2AVG)
23468 CRMODF=1D0/(1D0+PARP(77)**2*P2AVG)
23470 PKEEP=(1D0-PARP(78)*CRMODF)**MINT(31)
23471 IF (PYR(0).LE.PKEEP) THEN
23476 C...Add coloured parton
23482 C...Add anti-coloured parton
23492 C...Skip if there is only one possibility
23497 C...Reorder, so ordered in I (in order to correspond to old algorithm)
23508 MSCR(IC1)=MSCR(IC1+1)
23514 C...Max do 1000 reordering loops
23515 IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 151
23517 C...Loop over CR partons
23518 C...(Ignore junctions for now.)
23523 C...Loop over coloured partons
23525 C...Retrieve parton Event Record index and Colour Side
23528 C...Skip already connected partons
23529 IF (MCN(I,MSI).NE.0) GOTO 230
23530 C...Shorthand for colour charge
23531 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
23532 C...For Seattle algorithm, only start from partons with one dangling
23534 IF (MSTP(95).GE.6.AND.MSTP(95).LE.9) THEN
23535 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
23537 C...Retrieve saved optimal partner
23540 C...Reject saved optimal partner if latter is now connected
23541 C...(Also reject if using model S1, since saved partner may
23542 C...now give rise to gg loop.)
23543 IF (MCN(IO,3-MSI).NE.0.OR.MSTP(95).LE.3) THEN
23549 C...Search for new optimal partner if necessary
23550 IF (IOPT(IC1).EQ.0) THEN
23554 C...Loop over partons you can connect to
23558 C...Skip if already connected
23559 IF (MCN(J,MSJ).NE.0) GOTO 210
23560 C...Skip if this not colour-anticolour pair
23561 IF (MSI.EQ.MSJ) GOTO 210
23562 C...And do not let gluons connect to themselves
23563 IF (I.EQ.J) GOTO 210
23564 C...Suppress direct connections between partons in same Beam Remnant
23566 IF (K(I,3).LE.2.AND.K(I,3).GE.1.AND.K(I,3).EQ.K(J,3))
23568 C...Shorthand for colour charge
23569 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
23570 C...Check for gluon loops
23572 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
23573 IF (MCN(I,2).EQ.MCN(J,1).AND.MSTP(95).LE.3.AND.
23574 & MCN(I,2).NE.0) MGGSTR=1
23576 C...Save connection with smallest lambda measure
23578 C...Optional: Seattle v2: multiply gluons by 1/2 since two strings connected
23579 IF (MSTP(95).GE.7.AND.MSTP(95).LE.8) THEN
23580 IF (K(I,2).EQ.21) RL=0.5D0*RL
23581 IF (K(J,2).EQ.21) RL=0.5D0*RL
23583 C...If best so far was a BR string and this is not, also save.
23584 C...If best so far was a gg string and this is not, also save.
23585 C...NB: this is not fool-proof. If the algorithm finds a BR or gg
23586 C...string with a small Lambda measure as the last step, this connection
23587 C...will be saved regardless of whether other possibilities existed.
23588 C...I.e., there should really be a check whether another possibility has
23589 C...already been found, but since these models are now actively in use
23590 C...and uncertainties are anyway large, the algorithm is left as it is.
23591 C...(correction --> Pythia 8 ?)
23592 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
23593 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
23594 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
23603 IF (IOPT(IC1).NE.0) THEN
23604 C...Save pair with largest RLOPT so far
23605 IF (RLOPT.GE.RLMAX) THEN
23611 C...Save and iterate
23612 IF (ICRMAX.GT.0) THEN
23618 MCN(ILMAX,ICMAX)=LCT
23619 MCN(JLMAX,JCMAX)=LCT
23620 IF (NLOOP.LE.2*(N-IP)) THEN
23623 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
23627 C...Save and exit. First check for leftover gluon(s)
23628 DO 260 I=MAX(1,IP),N
23629 C...Check colour charge
23630 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
23631 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
23632 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
23633 C...Decide where to put left-over gluon (minimal insertion)
23636 DO 250 KCT=NCT+1,LCT
23637 DO 240 IT=MAX(1,IP),N
23638 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
23639 IF (MCN(IT,1).EQ.KCT) IC=IT
23640 IF (MCN(IT,2).EQ.KCT) IA=IT
23642 RL=FOUR(IC,I)*FOUR(IA,I)
23643 IF (RL.LT.RLMAX) THEN
23650 MCN(I,1)=MCN(ICMAX,1)
23655 C...Here we need to loop over entire event.
23656 DO 270 IZ=MAX(1,IP),N
23657 C...Do not erase parton shower colour history
23658 IF (K(IZ,1).NE.3) GOTO 270
23659 C...Check colour charge
23660 MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2))
23661 IF (MCI.EQ.0) GOTO 270
23662 IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1)
23663 IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2)
23670 C*********************************************************************
23673 C...Handles diffractive and elastic scattering.
23677 C...Double precision and integer declarations.
23678 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23679 IMPLICIT INTEGER(I-N)
23680 INTEGER PYK,PYCHGE,PYCOMP
23682 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23683 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23684 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23685 COMMON/PYINT1/MINT(400),VINT(400)
23686 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
23688 C...Reset K, P and V vectors. Store incoming particles.
23689 DO 110 JT=1,MSTP(126)+10
23709 P(I,J)=VINT(285+5*JT+J)
23714 C...Subprocess; kinematics.
23715 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
23716 PZ=SQRT(SQLAM)/(2D0*VINT(1))
23719 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
23722 C...Elastically scattered particle. (Except elastic GVMD states.)
23723 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
23724 & MINT(106+JT).NE.3)) THEN
23729 P(N,3)=PZ*(-1)**(JT+1)
23731 P(N,5)=SQRT(VINT(62+JT))
23733 C...Decay rho from elastic scattering of gamma with sin**2(theta)
23734 C...distribution of decay products (in rho rest frame).
23735 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
23737 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
23741 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
23742 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
23743 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
23744 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
23745 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
23746 140 CTHE=2D0*PYR(0)-1D0
23747 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
23748 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
23750 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
23753 C...Diffracted particle: low-mass system to two particles.
23754 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
23760 PMMAS=SQRT(VINT(62+JT))
23763 IF(NTRY.LT.20) THEN
23764 MINT(105)=MINT(102+JT)
23765 MINT(109)=MINT(106+JT)
23766 CALL PYSPLI(KFH,21,KFL1,KFL2)
23767 CALL PYKFDI(KFL1,0,KFL3,KF1)
23768 IF(KF1.EQ.0) GOTO 150
23769 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
23770 IF(KF2.EQ.0) GOTO 150
23777 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
23782 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
23783 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
23786 P(N-1,4)=SQRT(PM1**2+PZP**2)
23787 P(N,4)=SQRT(PM2**2+PZP**2)
23788 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
23790 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
23791 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
23793 C...Diffracted particle: valence quark kicked out.
23794 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
23801 MINT(105)=MINT(102+JT)
23802 MINT(109)=MINT(106+JT)
23803 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
23804 P(N-1,5)=PYMASS(K(N-1,2))
23805 P(N,5)=PYMASS(K(N,2))
23806 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
23807 & 4D0*P(N-1,5)**2*P(N,5)**2
23808 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
23809 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
23810 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
23811 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
23812 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23814 C...Diffracted particle: gluon kicked out.
23823 MINT(105)=MINT(102+JT)
23824 MINT(109)=MINT(106+JT)
23825 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
23827 P(N-2,5)=PYMASS(K(N-2,2))
23829 P(N,5)=PYMASS(K(N,2))
23830 C...Energy distribution for particle into two jets.
23832 IF(MOD(KFH/1000,10).NE.0) IMB=2
23833 CHIK=PARP(92+2*IMB)
23834 IF(MSTP(92).LE.1) THEN
23835 IF(IMB.EQ.1) CHI=PYR(0)
23836 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23837 ELSEIF(MSTP(92).EQ.2) THEN
23838 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
23839 ELSEIF(MSTP(92).EQ.3) THEN
23840 CUT=2D0*0.3D0/VINT(1)
23842 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
23844 ELSEIF(MSTP(92).EQ.4) THEN
23845 CUT=2D0*0.3D0/VINT(1)
23846 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
23847 180 CHIR=CUT*CUTR**PYR(0)
23848 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
23849 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
23851 CUT=2D0*0.3D0/VINT(1)
23852 CUTA=CUT**(1D0-PARP(98))
23853 CUTB=(1D0+CUT)**(1D0-PARP(98))
23854 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
23855 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
23856 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
23858 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
23859 & VINT(62+JT)) GOTO 160
23860 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
23861 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
23862 & (2D0*VINT(62+JT))
23863 PEI=SQRT(PZI**2+SQM)
23864 PQQP=(1D0-CHI)*(PEI+PZI)
23865 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
23866 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
23867 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
23868 P(N-1,3)=P(N-1,4)*(-1)**JT
23869 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
23870 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23873 C...Documentation lines.
23875 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
23876 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
23877 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
23879 P(I+2,3)=PZ*(-1)**(JT+1)
23881 P(I+2,5)=SQRT(VINT(62+JT))
23884 C...Rotate outgoing partons/particles using cos(theta).
23885 IF(VINT(23).LT.0.9D0) THEN
23886 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
23888 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
23894 C*********************************************************************
23897 C...Set up a DIS process as gamma* + f -> f, with beam remnant
23898 C...and showering added consecutively. Photon flux by the PYGAGA
23899 C...routine (if at all).
23903 C...Double precision and integer declarations.
23904 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23905 IMPLICIT INTEGER(I-N)
23906 INTEGER PYK,PYCHGE,PYCOMP
23907 C...Parameter statement to help give large particle numbers.
23908 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23909 &KEXCIT=4000000,KDIMEN=5000000)
23911 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23912 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23913 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23914 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23915 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23916 COMMON/PYINT1/MINT(400),VINT(400)
23917 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
23921 C...Choice of subprocess, number of documentation lines
23929 IF(MINT(107).EQ.4) ISIDE=2
23931 C...Reset K, P and V vectors. Store incoming particles
23932 DO 110 JT=1,MSTP(126)+20
23945 P(I,J)=VINT(285+5*JT+J)
23950 C...Store incoming partons in hadronic CM-frame
23955 K(I,3)=MINT(83)+2+JT
23957 IF(MINT(15).EQ.22) THEN
23958 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
23959 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
23960 P(MINT(84)+1,5)=-SQRT(VINT(307))
23961 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
23962 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
23966 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
23967 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
23968 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
23969 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
23970 P(MINT(84)+1,5)=-SQRT(VINT(308))
23974 SIDESG=(-1D0)**(ISIDE-1)
23976 C...Copy incoming partons to documentation lines.
23987 C...Second copy for partons before ISR shower, since no such.
23997 C...Define initial partons.
24000 IF(NTRY.GT.100) THEN
24005 C...Scattered quark in hadronic CM frame.
24010 P(IPU3,5)=PYMASS(KFRES)
24011 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
24012 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
24016 K(I,3)=MINT(83)+4+ISIDE
24024 C...No primordial kT, or chosen according to truncated Gaussian or
24025 C...exponential, or (for photon) predetermined or power law.
24026 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
24027 IF(MSTP(91).LE.0) THEN
24029 ELSEIF(MSTP(91).EQ.1) THEN
24030 PT=PARP(91)*SQRT(-LOG(PYR(0)))
24034 PT=-PARP(92)*LOG(RPT1*RPT2)
24036 IF(PT.GT.PARP(93)) GOTO 190
24037 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
24038 PTA=SQRT(VINT(282+ISIDE))
24040 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
24041 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
24042 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
24045 PTB=-PARP(99)*LOG(RPT1*RPT2)
24047 IF(PTB.GT.PARP(100)) GOTO 190
24048 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
24049 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
24050 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
24051 IF(MSTP(93).LE.0) THEN
24053 ELSEIF(MSTP(93).EQ.1) THEN
24054 PT=PARP(99)*SQRT(-LOG(PYR(0)))
24055 ELSEIF(MSTP(93).EQ.2) THEN
24058 PT=-PARP(99)*LOG(RPT1*RPT2)
24059 ELSEIF(MSTP(93).EQ.3) THEN
24062 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
24066 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
24067 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
24069 IF(PT.GT.PARP(100)) GOTO 190
24075 P(IPU3,1)=PT*COS(PHI)
24076 P(IPU3,2)=PT*SIN(PHI)
24077 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
24078 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
24079 PCP=P(IPU3,4)+ABS(P(IPU3,3))
24081 C...Find one or two beam remnants.
24082 MINT(105)=MINT(102+ISIDE)
24083 MINT(109)=MINT(106+ISIDE)
24084 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
24085 IF(MINT(51).NE.0) THEN
24090 C...Store first remnant parton, with colour info and kinematics.
24094 K(I,3)=MINT(83)+ISIDE
24095 P(I,5)=PYMASS(K(I,2))
24096 KCOL=KCHG(PYCOMP(KFLSP),2)
24099 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
24100 K(I,KFLS+3)=MSTU(5)*IPU3
24101 K(IPU3,6-KFLS)=MSTU(5)*I
24104 IF(KFLCH.EQ.0) THEN
24107 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24109 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
24110 PRP=P(I,4)+ABS(P(I,3))
24112 C...When extra remnant parton or hadron: store extra remnant.
24117 K(I,3)=MINT(83)+ISIDE
24118 P(I,5)=PYMASS(K(I,2))
24119 KCOL=KCHG(PYCOMP(KFLCH),2)
24122 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
24123 K(I,KFLS+3)=MSTU(5)*IPU3
24124 K(IPU3,6-KFLS)=MSTU(5)*I
24128 C...Relative transverse momentum when two remnants.
24131 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
24132 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
24133 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
24134 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
24135 P(I,1)=-P(IPU3,1)-P(I-1,1)
24136 P(I,2)=-P(IPU3,2)-P(I-1,2)
24137 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24139 C...Relative distribution of energy for particle into jet plus particle.
24141 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
24142 IF(MSTP(94).LE.1) THEN
24143 IF(IMB.EQ.1) CHI=PYR(0)
24144 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
24145 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24146 ELSEIF(MSTP(94).EQ.2) THEN
24147 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
24148 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24149 ELSEIF(MSTP(94).EQ.3) THEN
24150 CALL PYZDIS(1,0,PMS(4),ZZ)
24153 CALL PYZDIS(1000,0,PMS(4),ZZ)
24157 C...Construct total transverse mass; reject if too large.
24158 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
24159 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
24160 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
24161 IF(LOOP.LT.10) GOTO 200
24164 VINT(158+ISIDE)=CHI
24166 C...Subdivide longitudinal momentum according to value selected above.
24167 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
24169 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
24170 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
24172 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
24173 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
24177 C...Boost current and remnant systems to correct frame.
24178 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
24179 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
24180 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
24182 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
24184 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
24185 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
24186 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
24187 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
24189 C...Let current quark shower; recoil but no showering by colour partner.
24190 QMAX=2D0*SQRT(VINT(309-ISIDE))
24195 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
24202 C*********************************************************************
24205 C...Handles the documentation of the process in MSTI and PARI,
24206 C...and also computes cross-sections based on accumulated statistics.
24210 C...Double precision and integer declarations.
24211 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24212 IMPLICIT INTEGER(I-N)
24213 INTEGER PYK,PYCHGE,PYCOMP
24215 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24216 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24217 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24218 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24219 COMMON/PYINT1/MINT(400),VINT(400)
24220 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24221 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
24222 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
24225 C...Calculate Monte Carlo estimates of cross-sections.
24227 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
24228 NGEN(0,3)=NGEN(0,3)+1
24231 IF(I.EQ.96.OR.I.EQ.97) THEN
24233 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
24234 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
24235 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24236 & DBLE(NGEN(96,2)))
24237 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
24238 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24239 & DBLE(NGEN(96,2)))
24240 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
24242 ELSEIF(NGEN(I,2).EQ.0) THEN
24243 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
24246 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
24249 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
24252 C...Rescale to known low-pT cross-section for standard QCD processes.
24253 IF(MSUB(95).EQ.1) THEN
24254 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
24255 & XSEC(68,3)+XSEC(95,3)
24256 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
24257 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
24259 XSEC(11,3)=FAC*XSEC(11,3)
24260 XSEC(12,3)=FAC*XSEC(12,3)
24261 XSEC(13,3)=FAC*XSEC(13,3)
24262 XSEC(28,3)=FAC*XSEC(28,3)
24263 XSEC(53,3)=FAC*XSEC(53,3)
24264 XSEC(68,3)=FAC*XSEC(68,3)
24265 XSEC(95,3)=FAC*XSEC(95,3)
24266 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
24270 C...Save information for gamma-p and gamma-gamma.
24271 IF(MINT(121).GT.1) THEN
24277 C...Reset information on hard interaction.
24283 C...Copy integer valued information from MINT into MSTI.
24287 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
24289 C...Store cross-section variables in PARI.
24291 PARI(2)=XSEC(0,3)/MINT(5)
24295 VINT(98)=VINT(98)+VINT(100)
24296 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
24298 C...Store kinematics variables in PARI.
24301 IF(ISUB.NE.95) THEN
24311 PARI(35)=PARI(33)-PARI(34)
24318 PARI(42)=2D0*VINT(47)/VINT(1)
24321 C...Store information on scattered partons in PARI.
24322 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
24325 PARI(36+IS)=P(I,3)/VINT(1)
24326 PARI(38+IS)=P(I,4)/VINT(1)
24327 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
24328 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24329 & SQRT(PR),1D20)),P(I,3))
24330 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
24331 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24332 & SQRT(PR),1D20)),P(I,3))
24333 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
24334 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
24335 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
24339 C...Store sum up transverse and longitudinal momenta.
24340 PARI(65)=2D0*PARI(17)
24341 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
24342 DO 150 I=MSTP(126)+1,N
24343 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
24344 PT=SQRT(P(I,1)**2+P(I,2)**2)
24345 PARI(69)=PARI(69)+PT
24346 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
24347 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
24359 C...Store various other pieces of information into PARI.
24367 C...Store information on lepton -> lepton + gamma in PYGAGA.
24370 PARI(101)=VINT(301)
24371 PARI(102)=VINT(302)
24373 PARI(I)=VINT(I+202)
24376 C...Set information for PYTABU.
24377 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
24380 ELSEIF(ISET(ISUB).EQ.5) THEN
24391 C*********************************************************************
24394 C...Performs transformations between different coordinate frames.
24396 SUBROUTINE PYFRAM(IFRAME)
24398 C...Double precision and integer declarations.
24399 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24400 IMPLICIT INTEGER(I-N)
24401 INTEGER PYK,PYCHGE,PYCOMP
24403 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24404 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24405 COMMON/PYINT1/MINT(400),VINT(400)
24406 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
24408 C...Check that transformation can and should be done.
24409 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
24410 &MINT(91).EQ.1)) THEN
24411 IF(IFRAME.EQ.MINT(6)) RETURN
24413 WRITE(MSTU(11),5000) IFRAME,MINT(6)
24417 IF(MINT(6).EQ.1) THEN
24418 C...Transform from fixed target or user specified frame to
24419 C...overall CM frame.
24420 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
24421 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
24422 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
24423 ELSEIF(MINT(6).EQ.3) THEN
24424 C...Transform from hadronic CM frame in DIS to overall CM frame.
24425 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
24429 IF(IFRAME.EQ.1) THEN
24430 C...Transform from overall CM frame to fixed target or user specified
24432 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
24433 ELSEIF(IFRAME.EQ.3) THEN
24434 C...Transform from overall CM frame to hadronic CM frame in DIS.
24435 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
24436 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
24437 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
24440 C...Set information about new frame.
24444 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
24445 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
24451 C*********************************************************************
24454 C...Calculates full and partial widths of resonances.
24456 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
24458 C...Double precision and integer declarations.
24459 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24460 IMPLICIT INTEGER(I-N)
24461 INTEGER PYK,PYCHGE,PYCOMP
24462 C...Parameter statement to help give large particle numbers.
24463 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24464 &KEXCIT=4000000,KDIMEN=5000000)
24466 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24467 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24468 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
24469 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24470 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24471 COMMON/PYINT1/MINT(400),VINT(400)
24472 COMMON/PYINT4/MWID(500),WIDS(500,5)
24473 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24474 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24475 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
24476 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
24477 COMMON/PYPUED/IUED(0:99),RUED(0:99)
24478 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
24479 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/
24480 C...Local arrays and saved variables.
24481 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
24482 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
24483 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
24484 C...UED: equivalences between ordered particles (451->475)
24485 C...and UED particle code (5 000 000 + id)
24486 PARAMETER(KKFLMI=451,KKFLMA=475)
24487 DIMENSION CHIDEL(3), IUEDPR(25)
24488 DIMENSION IUEDEQ(KKFLMA),MUED(2)
24489 COMMON/SW1/SW21,CW21
24490 DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/
24491 & 6100001,6100002,6100003,6100004,6100005,6100006,
24492 & 5100001,5100002,5100003,5100004,5100005,5100006,
24493 & 6100011,6100013,6100015,
24494 & 5100012,5100011,5100014,5100013,5100016,5100015,
24495 & 5100021,5100022,5100023,5100024/
24496 C...Save local variables
24497 SAVE MOFSV,WIDWSV,WID2SV
24499 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
24500 DATA CHIDEL/1.1D-03,1.D0,7.4D+2/
24502 C...UED: inline functions used in kk width calculus
24503 FKAC1(X,Y)=1.-X**2/Y**2
24504 FKAC2(X,Y)=2.+X**2/Y**2
24506 C...Compressed code and sign; mass.
24513 C...Reset width information.
24514 DO 110 I=0,MDCY(KC,3)
24521 C...Allow for fudge factor to rescale resonance width.
24523 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
24524 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
24525 IF(MSTP(110).EQ.KFLA) THEN
24527 ELSEIF(MSTP(110).EQ.-1) THEN
24528 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
24529 ELSEIF(MSTP(110).EQ.-2) THEN
24534 C...Not to be treated as a resonance: return.
24535 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
24544 C...Treatment as a resonance based on tabulated branching ratios.
24545 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
24546 C...Loop over possible decay channels; skip irrelevant ones.
24547 DO 120 I=1,MDCY(KC,3)
24549 IF(MDME(IDC,1).LT.0) GOTO 120
24551 C...Read out decay products and nominal masses.
24554 C...Skip dummy modes or unrecognized particles
24555 IF (KFD1.EQ.0.OR.KFC1.EQ.0) GOTO 120
24556 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
24560 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
24566 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
24570 C...Naive partial width and alternative threshold factors.
24571 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
24572 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
24573 & PM1+PM2+PM3.GE.SHR) THEN
24575 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
24576 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
24577 & 4D0*PM1**2*PM2**2))/SH
24578 ELSEIF(MDME(IDC,2).EQ.52) THEN
24579 PMA=MAX(PM1,PM2,PM3)
24580 PMC=MIN(PM1,PM2,PM3)
24581 PMB=PM1+PM2+PM3-PMA-PMC
24582 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
24587 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
24588 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24589 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24590 & ((SHR-PMA)**2-(PMB+PMC)**2)*
24591 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
24592 & ((1D0-PMBCN)*PMBCN*SH)
24593 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
24594 WDTP(I)=WDTP(I)*SQRT(
24595 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
24596 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
24597 ELSEIF(MDME(IDC,2).EQ.53) THEN
24598 PMA=MAX(PM1,PM2,PM3)
24599 PMC=MIN(PM1,PM2,PM3)
24600 PMB=PM1+PM2+PM3-PMA-PMC
24601 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
24606 FACACT=SQRT(MAX(0D0,
24607 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24608 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24609 & ((SHR-PMA)**2-(PMB+PMC)**2)*
24610 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
24611 & ((1D0-PMBCN)*PMBCN*SH)
24612 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
24616 PMBCN=PMBC**2/PMR**2
24617 FACNOM=SQRT(MAX(0D0,
24618 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24619 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24620 & ((PMR-PMA)**2-(PMB+PMC)**2)*
24621 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
24622 & ((1D0-PMBCN)*PMBCN*PMR**2)
24623 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
24625 WDTP(I)=FUDGE*WDTP(I)
24626 WDTP(0)=WDTP(0)+WDTP(I)
24628 C...Calculate secondary width (at most two identical/opposite).
24630 IF(MDME(IDC,1).GT.0) THEN
24631 IF(KFD2.EQ.KFD1) THEN
24632 IF(KCHG(KFC1,3).EQ.0) THEN
24634 ELSEIF(KFD1.GT.0) THEN
24640 WID2=WID2*WIDS(KFC3,2)
24641 ELSEIF(KFD3.LT.0) THEN
24642 WID2=WID2*WIDS(KFC3,3)
24644 ELSEIF(KFD2.EQ.-KFD1) THEN
24647 WID2=WID2*WIDS(KFC3,2)
24648 ELSEIF(KFD3.LT.0) THEN
24649 WID2=WID2*WIDS(KFC3,3)
24651 ELSEIF(KFD3.EQ.KFD1) THEN
24652 IF(KCHG(KFC1,3).EQ.0) THEN
24654 ELSEIF(KFD1.GT.0) THEN
24660 WID2=WID2*WIDS(KFC2,2)
24661 ELSEIF(KFD2.LT.0) THEN
24662 WID2=WID2*WIDS(KFC2,3)
24664 ELSEIF(KFD3.EQ.-KFD1) THEN
24667 WID2=WID2*WIDS(KFC2,2)
24668 ELSEIF(KFD2.LT.0) THEN
24669 WID2=WID2*WIDS(KFC2,3)
24671 ELSEIF(KFD3.EQ.KFD2) THEN
24672 IF(KCHG(KFC2,3).EQ.0) THEN
24674 ELSEIF(KFD2.GT.0) THEN
24680 WID2=WID2*WIDS(KFC1,2)
24681 ELSEIF(KFD1.LT.0) THEN
24682 WID2=WID2*WIDS(KFC1,3)
24684 ELSEIF(KFD3.EQ.-KFD2) THEN
24687 WID2=WID2*WIDS(KFC1,2)
24688 ELSEIF(KFD1.LT.0) THEN
24689 WID2=WID2*WIDS(KFC1,3)
24698 WID2=WID2*WIDS(KFC2,2)
24700 WID2=WID2*WIDS(KFC2,3)
24703 WID2=WID2*WIDS(KFC3,2)
24704 ELSEIF(KFD3.LT.0) THEN
24705 WID2=WID2*WIDS(KFC3,3)
24709 C...Store effective widths according to case.
24710 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24711 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24712 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24713 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24723 C...Here begins detailed dynamical calculation of resonance widths.
24724 C...Shared treatment of Higgs states.
24727 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
24732 C...Common electroweak and strong constants.
24735 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
24738 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
24740 RADC=1D0+AS/PARU(1)
24744 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24745 RADCT=1D0-2.5D0*AS/PARU(1)
24746 DO 140 I=1,MDCY(KC,3)
24748 IF(MDME(IDC,1).LT.0) GOTO 140
24749 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24750 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24751 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
24753 IF(I.GE.4.AND.I.LE.7) THEN
24754 C...t -> W + q; including approximate QCD correction factor.
24755 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
24756 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24757 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24760 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24763 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24765 ELSEIF(I.EQ.9) THEN
24767 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
24768 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24769 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
24770 & 4D0*SQRT(RM2R*RM2))
24772 IF(KFLR.LT.0) WID2=WIDS(37,3)
24774 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
24775 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
24778 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
24781 KFC1=PYCOMP(KFDP(IDC,1))
24782 KFC2=PYCOMP(KFDP(IDC,2))
24783 PMNCHI=PMAS(KFC1,1)
24784 PMSTOP=PMAS(KFC2,1)
24785 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24788 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
24790 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
24791 AR=-ET*ZMIXC(IZ,1)*TANW
24792 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
24794 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
24795 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
24796 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24797 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24798 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
24799 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
24800 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
24802 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24804 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24807 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
24809 KFC1=PYCOMP(KFDP(IDC,1))
24810 KFC2=PYCOMP(KFDP(IDC,2))
24811 PMNCHI=PMAS(KFC1,1)
24812 PMSTOP=PMAS(KFC2,1)
24813 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24816 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24817 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24818 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
24819 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
24821 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24823 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24826 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
24827 C...t -> ~gravitino + ~t
24829 KFC1=PYCOMP(KFDP(IDC,1))
24830 XMGR2=PMAS(KFC1,1)**2
24831 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
24832 KFC2=PYCOMP(KFDP(IDC,2))
24834 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
24837 WDTP(I)=FUDGE*WDTP(I)
24838 WDTP(0)=WDTP(0)+WDTP(I)
24839 IF(MDME(IDC,1).GT.0) THEN
24840 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24841 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24842 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24843 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24847 ELSEIF(KFLA.EQ.7) THEN
24849 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24850 DO 150 I=1,MDCY(KC,3)
24852 IF(MDME(IDC,1).LT.0) GOTO 150
24853 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24854 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24855 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
24857 IF(I.GE.4.AND.I.LE.7) THEN
24859 WDTP(I)=FAC*VCKM(I-3,4)*
24860 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24861 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24864 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
24865 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
24868 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
24869 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
24872 IF(KFLR.LT.0) WID2=WIDS(24,2)
24873 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24875 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24876 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24879 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
24882 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
24885 WDTP(I)=FUDGE*WDTP(I)
24886 WDTP(0)=WDTP(0)+WDTP(I)
24887 IF(MDME(IDC,1).GT.0) THEN
24888 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24889 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24890 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24891 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24895 ELSEIF(KFLA.EQ.8) THEN
24897 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24898 DO 160 I=1,MDCY(KC,3)
24900 IF(MDME(IDC,1).LT.0) GOTO 160
24901 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24902 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24903 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
24905 IF(I.GE.4.AND.I.LE.7) THEN
24907 WDTP(I)=FAC*VCKM(4,I-3)*
24908 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24909 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24912 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24915 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24917 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24919 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24920 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24923 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
24926 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
24929 WDTP(I)=FUDGE*WDTP(I)
24930 WDTP(0)=WDTP(0)+WDTP(I)
24931 IF(MDME(IDC,1).GT.0) THEN
24932 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24933 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24934 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24935 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24939 ELSEIF(KFLA.EQ.17) THEN
24941 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24942 DO 170 I=1,MDCY(KC,3)
24944 IF(MDME(IDC,1).LT.0) GOTO 170
24945 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24946 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24947 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
24950 C...tau' -> W + nu'_tau.
24951 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24952 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24955 WID2=WID2*WIDS(18,2)
24958 WID2=WID2*WIDS(18,3)
24960 ELSEIF(I.EQ.5) THEN
24961 C...tau' -> H + nu'_tau.
24962 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24963 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24966 WID2=WID2*WIDS(18,2)
24969 WID2=WID2*WIDS(18,3)
24972 WDTP(I)=FUDGE*WDTP(I)
24973 WDTP(0)=WDTP(0)+WDTP(I)
24974 IF(MDME(IDC,1).GT.0) THEN
24975 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24976 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24977 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24978 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24982 ELSEIF(KFLA.EQ.18) THEN
24983 C...nu'_tau neutrino.
24984 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24985 DO 180 I=1,MDCY(KC,3)
24987 IF(MDME(IDC,1).LT.0) GOTO 180
24988 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24989 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24990 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
24993 C...nu'_tau -> W + tau'.
24994 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24995 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24998 WID2=WID2*WIDS(17,2)
25001 WID2=WID2*WIDS(17,3)
25003 ELSEIF(I.EQ.3) THEN
25004 C...nu'_tau -> H + tau'.
25005 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25006 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
25009 WID2=WID2*WIDS(17,2)
25012 WID2=WID2*WIDS(17,3)
25015 WDTP(I)=FUDGE*WDTP(I)
25016 WDTP(0)=WDTP(0)+WDTP(I)
25017 IF(MDME(IDC,1).GT.0) THEN
25018 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25019 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25020 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25021 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25025 ELSEIF(KFLA.EQ.21) THEN
25027 C***Note that widths are not given in dimensional quantities here.
25028 DO 190 I=1,MDCY(KC,3)
25030 IF(MDME(IDC,1).LT.0) GOTO 190
25031 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25032 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25033 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
25036 C...QCD -> q + qbar
25037 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25038 IF(I.EQ.6) WID2=WIDS(6,1)
25039 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25041 WDTP(I)=FUDGE*WDTP(I)
25042 WDTP(0)=WDTP(0)+WDTP(I)
25043 IF(MDME(IDC,1).GT.0) THEN
25044 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25045 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25046 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25047 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25051 ELSEIF(KFLA.EQ.22) THEN
25053 C***Note that widths are not given in dimensional quantities here.
25054 DO 200 I=1,MDCY(KC,3)
25056 IF(MDME(IDC,1).LT.0) GOTO 200
25057 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25058 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25059 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
25062 C...QED -> q + qbar.
25065 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25066 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25067 IF(I.EQ.6) WID2=WIDS(6,1)
25068 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25069 ELSEIF(I.LE.12) THEN
25070 C...QED -> l+ + l-.
25071 EF=KCHG(9+2*(I-8),1)/3D0
25072 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25073 IF(I.EQ.12) WID2=WIDS(17,1)
25075 WDTP(I)=FUDGE*WDTP(I)
25076 WDTP(0)=WDTP(0)+WDTP(I)
25077 IF(MDME(IDC,1).GT.0) THEN
25078 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25079 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25080 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25081 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25085 ELSEIF(KFLA.EQ.23) THEN
25088 XWC=1D0/(16D0*XW*XW1)
25089 FAC=(AEM*XWC/3D0)*SHR
25091 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25096 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25098 IF(KFI.GT.20) KFI=IABS(MINT(16))
25104 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
25105 IF(MSTP(43).EQ.3) VINT(112)=
25106 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25107 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25108 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25110 DO 220 I=1,MDCY(KC,3)
25112 IF(MDME(IDC,1).LT.0) GOTO 220
25113 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25114 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25115 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
25120 AF=SIGN(1D0,EF+0.1D0)
25123 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25124 IF(I.EQ.6) WID2=WIDS(6,1)
25125 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25126 ELSEIF(I.LE.16) THEN
25127 C...Z0 -> l+ + l-, nu + nubar
25129 AF=SIGN(1D0,EF+0.1D0)
25132 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25134 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25135 IF(ICASE.EQ.1) THEN
25136 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
25138 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25139 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25140 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
25141 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
25142 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25143 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25144 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25145 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25147 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
25148 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
25149 IF(MDME(IDC,1).GT.0) THEN
25150 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25151 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25152 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25153 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25154 & WDTE(I,MDME(IDC,1))
25155 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25156 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25158 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25159 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
25160 & VINT(111)+FGGF*WID2
25161 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
25162 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25163 & VINT(114)+FZZF*WID2
25167 IF(MINT(61).GE.1) ICASE=3-ICASE
25168 IF(ICASE.EQ.2) GOTO 210
25170 ELSEIF(KFLA.EQ.24) THEN
25172 FAC=(AEM/(24D0*XW))*SHR
25173 DO 230 I=1,MDCY(KC,3)
25175 IF(MDME(IDC,1).LT.0) GOTO 230
25176 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25177 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25178 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
25181 C...W+/- -> q + qbar'
25182 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
25184 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25185 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25186 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25188 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25189 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25190 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25192 ELSEIF(I.LE.20) THEN
25193 C...W+/- -> l+/- + nu
25196 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25198 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25201 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25202 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25203 WDTP(I)=FUDGE*WDTP(I)
25204 WDTP(0)=WDTP(0)+WDTP(I)
25205 IF(MDME(IDC,1).GT.0) THEN
25206 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25207 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25208 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25209 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25213 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
25214 C...h0 (or H0, or A0):
25216 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25217 DO 270 I=1,MDCY(KFHIGG,3)
25218 IDC=I+MDCY(KFHIGG,2)-1
25219 IF(MDME(IDC,1).LT.0) GOTO 270
25220 KFC1=PYCOMP(KFDP(IDC,1))
25221 KFC2=PYCOMP(KFDP(IDC,2))
25222 RM1=PMAS(KFC1,1)**2/SH
25223 RM2=PMAS(KFC2,1)**2/SH
25224 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
25230 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
25231 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
25232 C...A0 behaves like beta, ho and H0 like beta**3.
25233 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25234 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25235 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
25236 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
25237 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
25238 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
25239 IF(IHIGG.NE.3) THEN
25240 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
25241 & PARU(151+10*IHIGG))**2
25245 IF(I.EQ.6) WID2=WIDS(6,1)
25246 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25247 ELSEIF(I.LE.12) THEN
25249 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
25250 C...A0 behaves like beta, ho and H0 like beta**3.
25251 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25252 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25253 & PARU(153+10*IHIGG)**2
25254 IF(I.EQ.12) WID2=WIDS(17,1)
25256 ELSEIF(I.EQ.13) THEN
25257 C...h0 -> g + g; quark loop contribution only
25260 DO 240 J=1,2*MSTP(1)
25261 EPS=(2D0*PMAS(J,1))**2/SH
25262 C...Loop integral; function of eps=4m^2/shat; different for A0.
25263 IF(EPS.LE.1D0) THEN
25264 IF(EPS.GT.1D-4) THEN
25266 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25268 RLN=LOG(4D0/EPS-2D0)
25270 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25271 PHIIM=0.5D0*PARU(1)*RLN
25273 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25276 IF(IHIGG.LE.2) THEN
25277 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25278 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
25280 ETAREJ=-0.5D0*EPS*PHIRE
25281 ETAIMJ=-0.5D0*EPS*PHIIM
25283 C...Couplings (=1 for standard model Higgs).
25284 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25285 IF(MOD(J,2).EQ.1) THEN
25286 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
25287 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
25289 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
25290 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
25296 ETA2=ETARE**2+ETAIM**2
25297 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
25299 ELSEIF(I.EQ.14) THEN
25300 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
25304 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25306 IF(J.LE.2*MSTP(1)) THEN
25308 EPS=(2D0*PMAS(J,1))**2/SH
25309 ELSEIF(J.LE.3*MSTP(1)) THEN
25310 JL=2*(J-2*MSTP(1))-1
25311 EJ=KCHG(10+JL,1)/3D0
25312 EPS=(2D0*PMAS(10+JL,1))**2/SH
25313 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25314 EPS=(2D0*PMAS(24,1))**2/SH
25316 EPS=(2D0*PMAS(37,1))**2/SH
25318 C...Loop integral; function of eps=4m^2/shat.
25319 IF(EPS.LE.1D0) THEN
25320 IF(EPS.GT.1D-4) THEN
25322 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25324 RLN=LOG(4D0/EPS-2D0)
25326 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25327 PHIIM=0.5D0*PARU(1)*RLN
25329 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25332 IF(J.LE.3*MSTP(1)) THEN
25333 C...Fermion loops: loop integral different for A0; charges.
25334 IF(IHIGG.LE.2) THEN
25335 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25336 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
25338 PHIPRE=-0.5D0*EPS*PHIRE
25339 PHIPIM=-0.5D0*EPS*PHIIM
25341 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25343 EJH=PARU(151+10*IHIGG)
25344 ELSEIF(J.LE.2*MSTP(1)) THEN
25346 EJH=PARU(152+10*IHIGG)
25349 EJH=PARU(153+10*IHIGG)
25351 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
25352 ETAREJ=EJC*EJH*PHIPRE
25353 ETAIMJ=EJC*EJH*PHIPIM
25354 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25355 C...W loops: loop integral and charges.
25356 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
25357 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
25358 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25359 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
25360 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
25363 C...Charged H loops: loop integral and charges.
25364 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
25365 & PARU(158+10*IHIGG+2*(IHIGG/3))
25366 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
25367 ETAIMJ=-EPS**2*PHIIM*FACHHH
25372 ETA2=ETARE**2+ETAIM**2
25373 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
25375 ELSEIF(I.EQ.15) THEN
25376 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
25380 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25382 IF(J.LE.2*MSTP(1)) THEN
25384 AJ=SIGN(1D0,EJ+0.1D0)
25386 EPS=(2D0*PMAS(J,1))**2/SH
25387 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
25388 ELSEIF(J.LE.3*MSTP(1)) THEN
25389 JL=2*(J-2*MSTP(1))-1
25390 EJ=KCHG(10+JL,1)/3D0
25391 AJ=SIGN(1D0,EJ+0.1D0)
25393 EPS=(2D0*PMAS(10+JL,1))**2/SH
25394 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
25396 EPS=(2D0*PMAS(24,1))**2/SH
25397 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
25399 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
25400 IF(EPS.LE.1D0) THEN
25402 IF(EPS.GT.1D-4) THEN
25403 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25405 RLN=LOG(4D0/EPS-2D0)
25407 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25408 PHIIM=0.5D0*PARU(1)*RLN
25409 PSIRE=0.5D0*ROOT*RLN
25410 PSIIM=-0.5D0*ROOT*PARU(1)
25412 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25414 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
25417 IF(EPSP.LE.1D0) THEN
25418 ROOT=SQRT(1D0-EPSP)
25419 IF(EPSP.GT.1D-4) THEN
25420 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25422 RLN=LOG(4D0/EPSP-2D0)
25424 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
25425 PHIIMP=0.5D0*PARU(1)*RLN
25426 PSIREP=0.5D0*ROOT*RLN
25427 PSIIMP=-0.5D0*ROOT*PARU(1)
25429 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
25431 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
25434 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
25435 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
25436 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
25437 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
25438 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
25439 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
25440 IF(J.LE.3*MSTP(1)) THEN
25441 C...Fermion loops: loop integral different for A0; charges.
25442 IF(IHIGG.EQ.3) FXYRE=0D0
25443 IF(IHIGG.EQ.3) FXYIM=0D0
25444 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25446 EJH=PARU(151+10*IHIGG)
25447 ELSEIF(J.LE.2*MSTP(1)) THEN
25449 EJH=PARU(152+10*IHIGG)
25452 EJH=PARU(153+10*IHIGG)
25454 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
25455 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
25456 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
25457 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25458 C...W loops: loop integral and charges.
25459 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
25460 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
25461 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
25462 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25463 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
25464 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
25467 C...Charged H loops: loop integral and charges.
25468 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
25469 & PARU(158+10*IHIGG+2*(IHIGG/3))
25470 ETAREJ=FACHHH*FXYRE
25471 ETAIMJ=FACHHH*FXYIM
25476 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
25477 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
25480 ELSEIF(I.LE.17) THEN
25481 C...h0 -> Z0 + Z0, W+ + W-
25482 PM1=PMAS(IABS(KFDP(IDC,1)),1)
25483 PG1=PMAS(IABS(KFDP(IDC,1)),2)
25484 IF(MINT(62).GE.1) THEN
25485 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
25486 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
25487 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
25488 MOFSV(IHIGG,I-15)=0
25489 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
25493 MOFSV(IHIGG,I-15)=1
25494 RMAS=SQRT(MAX(0D0,SH))
25495 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
25497 WIDWSV(IHIGG,I-15)=WIDW
25498 WID2SV(IHIGG,I-15)=WID2
25501 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
25502 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
25506 WIDW=WIDWSV(IHIGG,I-15)
25507 WID2=WID2SV(IHIGG,I-15)
25510 WDTP(I)=FAC*WIDW/(2D0*(18-I))
25511 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
25512 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25513 & PARU(138+I+10*IHIGG)**2
25514 WID2=WID2*WIDS(7+I,1)
25516 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
25517 C...H0 -> Z0 + h0, A0-> Z0 + h0
25518 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
25519 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25520 IF(IHIGG.EQ.2) THEN
25521 WDTP(I)=WDTP(I)*PARU(179)**2
25522 ELSEIF(IHIGG.EQ.3) THEN
25523 WDTP(I)=WDTP(I)*PARU(186)**2
25525 WID2=WIDS(23,2)*WIDS(25,2)
25527 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
25528 C...H0 -> h0 + h0, A0-> h0 + h0
25529 WDTP(I)=FAC*0.25D0*
25530 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25531 IF(IHIGG.EQ.2) THEN
25532 WDTP(I)=WDTP(I)*PARU(176)**2
25533 ELSEIF(IHIGG.EQ.3) THEN
25534 WDTP(I)=WDTP(I)*PARU(169)**2
25537 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
25538 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
25539 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
25540 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25541 & *PARU(195+IHIGG)**2
25543 WID2=WIDS(24,2)*WIDS(37,3)
25544 ELSEIF(I.EQ.21) THEN
25545 WID2=WIDS(24,3)*WIDS(37,2)
25548 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
25550 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
25551 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25552 WID2=WIDS(36,2)*WIDS(23,2)
25554 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
25556 WDTP(I)=FAC*0.5D0*PARU(180)**2*
25557 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25558 WID2=WIDS(25,2)*WIDS(36,2)
25560 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
25562 WDTP(I)=FAC*0.25D0*PARU(177)**2*
25563 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25568 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25571 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25572 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25573 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25578 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25580 IF(KFC2.EQ.KFC1) THEN
25584 IF(KFDP(IDC,1).LT.0) KSGN1=3
25586 IF(KFDP(IDC,2).LT.0) KSGN2=3
25587 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25590 WDTP(I)=FUDGE*WDTP(I)
25591 WDTP(0)=WDTP(0)+WDTP(I)
25592 IF(MDME(IDC,1).GT.0) THEN
25593 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25594 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25595 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25596 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25600 ELSEIF(KFLA.EQ.32) THEN
25603 XWC=1D0/(16D0*XW*XW1)
25604 FAC=(AEM*XWC/3D0)*SHR
25607 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25615 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25616 KFAI=IABS(MINT(15))
25617 EI=KCHG(KFAI,1)/3D0
25618 AI=SIGN(1D0,EI+0.1D0)
25621 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
25622 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
25623 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
25624 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
25625 VPI=PARU(119+2*KFAIC)
25626 API=PARU(120+2*KFAIC)
25627 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
25628 VPI=PARJ(178+2*KFAIC)
25629 API=PARJ(179+2*KFAIC)
25631 VPI=PARJ(186+2*KFAIC)
25632 API=PARJ(187+2*KFAIC)
25636 SQMZP=PMAS(32,1)**2
25638 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25639 & MSTP(44).EQ.7) VINT(111)=1D0
25640 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
25641 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25642 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
25643 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
25644 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25645 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25646 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
25647 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
25648 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
25649 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25650 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
25652 DO 290 I=1,MDCY(KC,3)
25654 IF(MDME(IDC,1).LT.0) GOTO 290
25655 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25656 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25657 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
25661 C...Z'0 -> q + qbar
25663 AF=SIGN(1D0,EF+0.1D0)
25666 VPF=PARU(123-2*MOD(I,2))
25667 APF=PARU(124-2*MOD(I,2))
25668 ELSEIF(I.LE.4) THEN
25669 VPF=PARJ(182-2*MOD(I,2))
25670 APF=PARJ(183-2*MOD(I,2))
25672 VPF=PARJ(190-2*MOD(I,2))
25673 APF=PARJ(191-2*MOD(I,2))
25676 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
25677 & PYHFTH(SH,SH*RM1,1D0)
25678 IF(I.EQ.6) WID2=WIDS(6,1)
25679 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25680 ELSEIF(I.LE.16) THEN
25681 C...Z'0 -> l+ + l-, nu + nubar
25683 AF=SIGN(1D0,EF+0.1D0)
25686 VPF=PARU(127-2*MOD(I,2))
25687 APF=PARU(128-2*MOD(I,2))
25688 ELSEIF(I.LE.12) THEN
25689 VPF=PARJ(186-2*MOD(I,2))
25690 APF=PARJ(187-2*MOD(I,2))
25692 VPF=PARJ(194-2*MOD(I,2))
25693 APF=PARJ(195-2*MOD(I,2))
25696 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25698 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25699 IF(ICASE.EQ.1) THEN
25700 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25701 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
25702 & APF**2*(1D0-4D0*RM1))*BE34
25703 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25704 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25705 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
25706 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
25707 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
25708 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
25709 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
25710 ELSEIF(MINT(61).EQ.2) THEN
25711 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25712 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25713 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
25714 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25715 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
25717 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
25720 ELSEIF(I.EQ.17) THEN
25722 WDTPZP=PARU(129)**2*XW1**2*
25723 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25724 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25725 IF(ICASE.EQ.1) THEN
25728 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25729 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25730 ELSEIF(MINT(61).EQ.2) THEN
25739 ELSEIF(I.EQ.18) THEN
25741 CZC=2D0*(1D0-2D0*XW)
25742 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25743 IF(ICASE.EQ.1) THEN
25744 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
25745 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
25746 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25747 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
25748 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
25749 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
25750 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
25751 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
25752 ELSEIF(MINT(61).EQ.2) THEN
25754 FGZF=0.25D0*PARU(142)*CZC*BE34C
25755 FGZPF=0.25D0*PARU(143)*CZC*BE34C
25756 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
25757 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
25758 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
25761 ELSEIF(I.EQ.19) THEN
25762 C...Z'0 -> Z0 + gamma.
25763 ELSEIF(I.EQ.20) THEN
25765 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25766 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
25767 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
25768 IF(ICASE.EQ.1) THEN
25771 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25772 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25773 ELSEIF(MINT(61).EQ.2) THEN
25781 WID2=WIDS(23,2)*WIDS(25,2)
25782 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
25783 C...Z' -> h0 + A0 or H0 + A0.
25784 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25792 IF(ICASE.EQ.1) THEN
25793 WDTPZ=CZAH**2*BE34C
25794 WDTP(I)=FAC*CZPAH**2*BE34C
25795 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25796 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
25797 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
25799 ELSEIF(MINT(61).EQ.2) THEN
25804 FZZPF=CZAH*CZPAH*BE34C
25805 FZPZPF=CZPAH**2*BE34C
25807 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
25808 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
25810 IF(ICASE.EQ.1) THEN
25811 VINT(117)=VINT(117)+FAC*WDTPZ
25812 WDTP(I)=FUDGE*WDTP(I)
25813 WDTP(0)=WDTP(0)+WDTP(I)
25815 IF(MDME(IDC,1).GT.0) THEN
25816 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25817 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25818 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25819 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25820 & WDTE(I,MDME(IDC,1))
25821 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25822 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25824 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25825 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25826 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
25827 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
25829 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
25831 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25832 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
25833 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
25835 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25836 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
25840 IF(MINT(61).GE.1) ICASE=3-ICASE
25841 IF(ICASE.EQ.2) GOTO 280
25843 ELSEIF(KFLA.EQ.34) THEN
25845 FAC=(AEM/(24D0*XW))*SHR
25846 DO 300 I=1,MDCY(KC,3)
25848 IF(MDME(IDC,1).LT.0) GOTO 300
25849 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25850 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25851 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
25855 C...W'+/- -> q + qbar'
25856 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
25857 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
25859 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25860 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25861 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25863 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25864 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25865 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25867 ELSEIF(I.LE.20) THEN
25868 C...W'+/- -> l+/- + nu
25869 FCOF=PARU(133)**2+PARU(134)**2
25871 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25873 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25876 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
25877 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25878 ELSEIF(I.EQ.21) THEN
25879 C...W'+/- -> W+/- + Z0
25880 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
25881 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25882 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25883 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
25884 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
25885 ELSEIF(I.EQ.23) THEN
25886 C...W'+/- -> W+/- + h0
25887 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25888 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
25889 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25890 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
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.EQ.37) THEN
25904 C IF(MSTP(49).EQ.0) THEN
25907 C SHFS=PMAS(37,1)**2
25909 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25910 DO 310 I=1,MDCY(KC,3)
25912 IF(MDME(IDC,1).LT.0) GOTO 310
25913 KFC1=PYCOMP(KFDP(IDC,1))
25914 KFC2=PYCOMP(KFDP(IDC,2))
25915 RM1=PMAS(KFC1,1)**2/SH
25916 RM2=PMAS(KFC2,1)**2/SH
25917 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
25920 C...H+/- -> q + qbar'
25921 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
25922 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25923 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
25924 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
25925 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25927 IF(I.EQ.3) WID2=WIDS(6,2)
25928 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
25930 IF(I.EQ.3) WID2=WIDS(6,3)
25931 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
25933 ELSEIF(I.LE.8) THEN
25934 C...H+/- -> l+/- + nu
25935 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
25936 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
25937 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25939 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
25941 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
25943 ELSEIF(I.EQ.9) THEN
25944 C...H+/- -> W+/- + h0.
25945 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
25946 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25947 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25948 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25952 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25955 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25956 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25957 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25962 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25965 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
25967 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
25968 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25970 WDTP(I)=FUDGE*WDTP(I)
25971 WDTP(0)=WDTP(0)+WDTP(I)
25972 IF(MDME(IDC,1).GT.0) THEN
25973 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25974 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25975 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25976 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25980 ELSEIF(KFLA.EQ.41) THEN
25982 FAC=(AEM/(12D0*XW))*SHR
25983 DO 320 I=1,MDCY(KC,3)
25985 IF(MDME(IDC,1).LT.0) GOTO 320
25986 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25987 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25988 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
25993 ELSEIF(I.LE.9) THEN
25997 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25998 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26000 IF(I.EQ.4) WID2=WIDS(6,3)
26001 IF(I.EQ.5) WID2=WIDS(7,3)
26002 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
26003 IF(I.EQ.9) WID2=WIDS(17,3)
26005 IF(I.EQ.4) WID2=WIDS(6,2)
26006 IF(I.EQ.5) WID2=WIDS(7,2)
26007 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
26008 IF(I.EQ.9) WID2=WIDS(17,2)
26010 WDTP(I)=FUDGE*WDTP(I)
26011 WDTP(0)=WDTP(0)+WDTP(I)
26012 IF(MDME(IDC,1).GT.0) THEN
26013 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26014 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26015 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26016 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26020 ELSEIF(KFLA.EQ.42) THEN
26021 C...LQ (leptoquark).
26022 FAC=(AEM/4D0)*PARU(151)*SHR
26023 DO 330 I=1,MDCY(KC,3)
26025 IF(MDME(IDC,1).LT.0) GOTO 330
26026 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26027 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26028 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
26029 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26031 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
26032 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
26033 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
26034 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
26035 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
26036 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
26037 WDTP(I)=FUDGE*WDTP(I)
26038 WDTP(0)=WDTP(0)+WDTP(I)
26039 IF(MDME(IDC,1).GT.0) THEN
26040 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26041 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26042 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26043 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26047 C...UED: kk state width decays : flav: 451 476
26048 ELSEIF(IUED(1).EQ.1.AND.
26049 & PYCOMP(ABS(KFLA)).GE.KKFLMI.AND.
26050 & PYCOMP(ABS(KFLA)).LE.KKFLMA) THEN
26052 C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
26053 RMFLAS=PMAS(KCLA,1)
26054 FACSH=SH/PMAS(KCLA,1)**2
26055 ALPHEM=PYALEM(RMFLAS**2)
26056 ALPHS=PYALPS(RMFLAS**2)
26058 C...uedcor parameters (alpha_s is calculated at mkk scale)
26059 C...alpha_em is calculated at z pole !
26063 DO 1070 I=1,MDCY(KCLA,3)
26064 IDC=I+MDCY(KCLA,2)-1
26066 IF(MDME(IDC,1).LT.0) GOTO 1070
26067 KFC1=PYCOMP(ABS(KFDP(IDC,1)))
26068 KFC2=PYCOMP(ABS(KFDP(IDC,2)))
26069 RM1=PMAS(KFC1,1)**2/SH
26070 RM2=PMAS(KFC2,1)**2/SH
26071 IF(SQRT(RM1)+SQRT(RM2).GT.1D0)
26075 C...N.B. RINV=RUED(1)
26081 KKCLA=KCLA-KKFLMI+1
26082 IF(ABS(KFC1).GE.KKFLMI)KKPART=KFC1
26083 IF(ABS(KFC2).GE.KKFLMI)KKPART=KFC2
26084 IF(KKCLA.LE.6) THEN
26085 C...q*_S -> q + gamma* (in first time sw21=0)
26086 FAC=0.25*ALPHEM*RMFLAS*0.5*CW21/CW2*KCHG(KCLA,1)**2/9.
26087 C...Eventually change the following by enabling a choice of open or closed.
26088 C...Only the gamma_kk channel is open.
26090 + WDTP(I)=FAC*FKAC2(RMFLAS,RMKK)*FKAC1(RMKK,RMFLAS)**2
26091 WDTP(I)=FACSH*WDTP(I)
26093 ELSEIF(KKCLA.GT.6.AND.KKCLA.LE.12)THEN
26094 C...q*_D -> q + Z*/W*
26095 FAC=0.25*ALPHEM*RMFLAS/(4.*SW2)
26096 GAMMAW=FAC*FKAC2(RMFLAS,RMWKK)*FKAC1(RMWKK,RMFLAS)**2
26106 WDTP(I)=FACSH*WDTP(I)
26107 C...q*_D -> q + gamma* is closed
26108 ELSEIF(KKCLA.GT.12.AND.KKCLA.LE.21)THEN
26109 C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
26110 FAC=ALPHEM/4.*RMFLAS/CW2/8.
26112 WDTP(I)=FAC*FKAC2(RMFLAS,RMGAKK)*
26113 + FKAC1(RMGAKK,RMFLAS)**2
26114 WDTP(I)=FACSH*WDTP(I)
26116 ELSEIF(KKCLA.EQ.22)THEN
26117 RMQST=PMAS(KKPART,1)
26118 WID2=WIDS(KKPART,2)
26119 C...g* -> q*_S/q*_D + q
26120 FAC=10.*ALPHS/12.*RMFLAS
26121 WDTP(I)=FAC*FKAC1(RMQST,RMFLAS)**2*FKAC2(RMQST,RMFLAS)
26122 WDTP(I)=FACSH*WDTP(I)
26123 ELSEIF(KKCLA.EQ.23)THEN
26124 C...gamma* decays to graviton + gamma : initial value is used
26126 WDTP(I)=RMFLAS*(RMFLAS/RUED(2))**(IUED(4)+2)
26128 ELSEIF(KKCLA.EQ.24)THEN
26129 C...Z* -> l*_S + l is closed
26130 C... Z* -> l*_D + l
26131 IF(I.LE.3)GOTO 1070
26132 c... After closing the channels for a Z* decaying into positively charged
26133 C... KK lepton singlets, close the channels for a Z* decaying into negatively
26134 C... charged KK lepton singlets + positively charged SM particles
26135 IF(I.GE.10.AND.I.LE.12)GOTO 1070
26136 FAC=3./2.*ALPHEM/24./SW2*RMZKK
26137 RMLST=PMAS(KKPART,1)
26138 WDTP(I)=FAC*FKAC1(RMLST,RMZKK)**2*FKAC2(RMLST,RMZKK)
26139 WDTP(I)=FACSH*WDTP(I)
26140 WID2=WIDS(KKPART,2)
26141 ELSEIF(KKCLA.EQ.25)THEN
26142 C...W* -> l*_D lbar
26143 FAC=3.*ALPHEM/12./SW2*RMWKK
26144 RMLST=PMAS(KKPART,1)
26145 WDTP(I)=FAC*FKAC1(RMLST,RMWKK)**2*FKAC2(RMLST,RMWKK)
26146 WDTP(I)=FACSH*WDTP(I)
26147 WID2=WIDS(KKPART,2)
26149 WDTP(0)=WDTP(0)+WDTP(I)
26150 IF(MDME(IDC,1).GT.0) THEN
26151 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26152 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26153 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26154 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26159 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
26160 C...Techni-pi0 and techni-pi0':
26161 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26162 DO 340 I=1,MDCY(KC,3)
26164 IF(MDME(IDC,1).LT.0) GOTO 340
26165 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26166 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26169 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
26173 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
26174 & /(8D0*PARU(1))*SH*SHR
26175 IF(KFLA.EQ.KTECHN+111) THEN
26182 C...pi_tc -> f + fbar.
26184 IKA=IABS(KFDP(IDC,1))
26185 IF(IKA.LT.10) FCOF=3D0*RADC
26188 IF(IKA.GE.4.AND.IKA.LE.6) THEN
26189 FCOF=FCOF*RTCM(1+IKA)**2
26190 HM1=PYMRUN(KFDP(IDC,1),SH)
26191 HM2=PYMRUN(KFDP(IDC,2),SH)
26192 ELSEIF(IKA.EQ.15) THEN
26193 FCOF=FCOF*RTCM(8)**2
26195 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26196 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26198 WDTP(I)=FUDGE*WDTP(I)
26199 WDTP(0)=WDTP(0)+WDTP(I)
26200 IF(MDME(IDC,1).GT.0) THEN
26201 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26202 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26203 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26204 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26208 ELSEIF(KFLA.EQ.KTECHN+211) THEN
26210 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26211 DO 350 I=1,MDCY(KC,3)
26213 IF(MDME(IDC,1).LT.0) GOTO 350
26214 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26215 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26217 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26221 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
26223 C...pi_tc -> f + f'.
26225 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
26226 C...pi_tc+ -> W b b~
26227 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
26229 XMT2=PMAS(6,1)**2/SH
26230 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
26231 KFC3=PYCOMP(KFDP(IDC,3))
26232 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
26234 T0 = (1D0-CHECK**2)*
26235 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
26236 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
26237 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
26238 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
26239 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
26240 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
26249 IKA=IABS(KFDP(IDC,1))
26250 IF(IKA.LT.10) FCOF=3D0*RADC
26253 IF(I.GE.1.AND.I.LE.5) THEN
26255 FCOF=FCOF*RTCM(5)**2
26256 ELSEIF(I.LE.4) THEN
26257 FCOF=FCOF*RTCM(6)**2
26258 ELSEIF(I.EQ.5) THEN
26259 FCOF=FCOF*RTCM(7)**2
26261 HM1=PYMRUN(KFDP(IDC,1),SH)
26262 HM2=PYMRUN(KFDP(IDC,2),SH)
26263 ELSEIF(I.EQ.8) THEN
26264 FCOF=FCOF*RTCM(8)**2
26266 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26267 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
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.KTECHN+331) THEN
26281 FAC=(SH/PARP(46)**2)*SHR
26282 DO 360 I=1,MDCY(KC,3)
26284 IF(MDME(IDC,1).LT.0) GOTO 360
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 360
26290 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
26291 IF(I.EQ.2) WID2=WIDS(6,1)
26293 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
26295 WDTP(I)=FUDGE*WDTP(I)
26296 WDTP(0)=WDTP(0)+WDTP(I)
26297 IF(MDME(IDC,1).GT.0) THEN
26298 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26299 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26300 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26301 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26305 ELSEIF(KFLA.EQ.KTECHN+113) THEN
26307 ALPRHT=2.16D0*(3D0/ITCM(1))
26308 FAC=(ALPRHT/12D0)*SHR
26309 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26313 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26315 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26316 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26317 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26318 DO 370 I=1,MDCY(KC,3)
26320 IF(MDME(IDC,1).LT.0) GOTO 370
26321 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26322 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26323 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
26326 C...rho_tc0 -> W+ + W-.
26327 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26328 WDTP(I)=FAC*RTCM(3)**4*
26329 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26330 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26331 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26332 & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
26334 ELSEIF(I.EQ.2) THEN
26335 C...rho_tc0 -> W+ + pi_tc-.
26336 C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
26337 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26338 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26339 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26340 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
26341 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26342 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26343 ELSEIF(I.EQ.3) THEN
26344 C...rho_tc0 -> pi_tc+ + W-.
26345 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26346 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26347 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26348 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
26349 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26350 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
26351 ELSEIF(I.EQ.4) THEN
26352 C...rho_tc0 -> pi_tc+ + pi_tc-.
26353 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
26354 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26355 WID2=WIDS(PYCOMP(KTECHN+211),1)
26356 ELSEIF(I.EQ.5) THEN
26357 C...rho_tc0 -> gamma + pi_tc0
26358 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26359 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26361 WID2=WIDS(PYCOMP(KTECHN+111),2)
26362 ELSEIF(I.EQ.6) THEN
26363 C...rho_tc0 -> gamma + pi_tc0'
26364 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26365 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
26366 WID2=WIDS(PYCOMP(KTECHN+221),2)
26367 ELSEIF(I.EQ.7) THEN
26368 C...rho_tc0 -> Z0 + pi_tc0
26369 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26370 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26372 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
26373 ELSEIF(I.EQ.8) THEN
26374 C...rho_tc0 -> Z0 + pi_tc0'
26375 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26376 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
26378 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26379 ELSEIF(I.EQ.9) THEN
26380 C...rho_tc0 -> gamma + Z0
26381 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26382 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26384 ELSEIF(I.EQ.10) THEN
26385 C...rho_tc0 -> Z0 + Z0
26386 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26387 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
26391 C...rho_tc0 -> f + fbar.
26396 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26400 IF(IA.GE.17) WID2=WIDS(IA,1)
26403 AI=SIGN(1D0,EI+0.1D0)
26407 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26408 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26409 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26410 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
26412 WDTP(I)=FUDGE*WDTP(I)
26413 WDTP(0)=WDTP(0)+WDTP(I)
26414 IF(MDME(IDC,1).GT.0) THEN
26415 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26416 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26417 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26418 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26422 ELSEIF(KFLA.EQ.KTECHN+213) THEN
26424 ALPRHT=2.16D0*(3D0/ITCM(1))
26425 FAC=(ALPRHT/12D0)*SHR
26429 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
26431 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
26432 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26433 DO 380 I=1,MDCY(KC,3)
26435 IF(MDME(IDC,1).LT.0) GOTO 380
26436 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26437 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26438 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
26440 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26441 c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26444 C...rho_tc+ -> W+ + Z0.
26446 WDTP(I)=FAC*RTCM(3)**4*
26447 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26448 VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
26449 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
26451 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
26454 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
26456 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26459 WID2=WIDS(24,2)*WIDS(23,2)
26461 WID2=WIDS(24,3)*WIDS(23,2)
26463 ELSEIF(I.EQ.2) THEN
26464 C...rho_tc+ -> W+ + pi_tc0.
26465 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26466 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26467 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26468 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26469 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26471 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
26473 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
26475 ELSEIF(I.EQ.3) THEN
26476 C...rho_tc+ -> pi_tc+ + Z0.
26477 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26478 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26479 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26480 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
26481 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
26482 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26483 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26486 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
26488 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
26490 ELSEIF(I.EQ.4) THEN
26491 C...rho_tc+ -> pi_tc+ + pi_tc0.
26492 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
26493 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26495 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
26497 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
26499 ELSEIF(I.EQ.5) THEN
26500 C...rho_tc+ -> pi_tc+ + gamma
26501 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26502 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26505 WID2=WIDS(PYCOMP(KTECHN+211),2)
26507 WID2=WIDS(PYCOMP(KTECHN+211),3)
26509 ELSEIF(I.EQ.6) THEN
26510 C...rho_tc+ -> W+ + pi_tc0'
26511 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26512 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
26514 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
26516 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
26518 ELSEIF(I.EQ.7) THEN
26519 C...rho_tc+ -> W+ + gamma
26520 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26521 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26528 C...rho_tc+ -> f + fbar'.
26532 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
26534 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
26535 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
26536 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
26538 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
26539 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
26540 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
26545 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26547 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26550 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26551 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26553 WDTP(I)=FUDGE*WDTP(I)
26554 WDTP(0)=WDTP(0)+WDTP(I)
26555 IF(MDME(IDC,1).GT.0) THEN
26556 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26557 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26558 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26559 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26563 ELSEIF(KFLA.EQ.KTECHN+223) THEN
26565 ALPRHT=2.16D0*(3D0/ITCM(1))
26566 FAC=(ALPRHT/12D0)*SHR
26567 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
26570 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26572 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26573 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26574 DO 390 I=1,MDCY(KC,3)
26576 IF(MDME(IDC,1).LT.0) GOTO 390
26577 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26578 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26579 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
26582 C...omega_tc0 -> gamma + pi_tc0.
26583 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
26584 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
26585 WID2=WIDS(PYCOMP(KTECHN+111),2)
26586 ELSEIF(I.EQ.2) THEN
26587 C...omega_tc0 -> Z0 + pi_tc0
26588 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26589 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
26591 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
26592 ELSEIF(I.EQ.3) THEN
26593 C...omega_tc0 -> gamma + pi_tc0'
26594 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26595 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
26597 WID2=WIDS(PYCOMP(KTECHN+221),2)
26598 ELSEIF(I.EQ.4) THEN
26599 C...omega_tc0 -> Z0 + pi_tc0'
26600 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26601 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
26603 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26604 ELSEIF(I.EQ.5) THEN
26605 C...omega_tc0 -> W+ + pi_tc-
26606 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26607 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
26608 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
26609 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26610 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26611 ELSEIF(I.EQ.6) THEN
26612 C...omega_tc0 -> pi_tc+ + W-
26613 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26614 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
26615 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
26616 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26617 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
26618 ELSEIF(I.EQ.7) THEN
26619 C...omega_tc0 -> W+ + W-.
26620 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26621 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
26622 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26623 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26624 & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
26626 ELSEIF(I.EQ.8) THEN
26627 C...omega_tc0 -> pi_tc+ + pi_tc-.
26628 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
26629 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26630 WID2=WIDS(PYCOMP(KTECHN+211),1)
26631 C...omega_tc0 -> gamma + Z0
26632 ELSEIF(I.EQ.9) THEN
26633 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26634 & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26636 C...omega_tc0 -> Z0 + Z0
26637 ELSEIF(I.EQ.10) THEN
26638 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26639 & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
26640 & /24D0/RTCM(12)**2*SHR**3
26643 C...omega_tc0 -> f + fbar.
26648 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26652 IF(IA.GE.17) WID2=WIDS(IA,1)
26655 AI=SIGN(1D0,EI+0.1D0)
26657 VALI=-0.5D0*(VI+AI)
26658 VARI=-0.5D0*(VI-AI)
26659 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26660 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26661 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26662 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
26664 WDTP(I)=FUDGE*WDTP(I)
26665 WDTP(0)=WDTP(0)+WDTP(I)
26666 IF(MDME(IDC,1).GT.0) THEN
26667 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26668 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26669 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26670 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26674 C.....V8 -> quark anti-quark
26675 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
26678 IF(ITCM(2).EQ.0) THEN
26680 ELSEIF(ITCM(2).EQ.1) THEN
26683 DO 400 I=1,MDCY(KC,3)
26685 IF(MDME(IDC,1).LT.0) GOTO 400
26686 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26688 IF(RM1.GT.0.25D0) GOTO 400
26690 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
26695 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
26696 IF(I.EQ.6) WID2=WIDS(6,1)
26697 WDTP(I)=FUDGE*WDTP(I)
26698 WDTP(0)=WDTP(0)+WDTP(I)
26699 IF(MDME(IDC,1).GT.0) THEN
26700 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26701 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26702 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26703 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26707 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
26708 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
26710 DO 410 I=1,MDCY(KC,3)
26712 IF(MDME(IDC,1).LT.0) GOTO 410
26713 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26714 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26715 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
26719 IF(KFLA.EQ.KTECHN+100111) THEN
26724 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
26725 & /(2D0*PARU(1))*SH*SHR*CLEBG
26728 C...pi_tc -> f + fbar.
26729 IF(I.EQ.6) WID2=WIDS(6,1)
26731 IKA=IABS(KFDP(IDC,1))
26732 IF(IKA.LT.10) FCOF=3D0*RADC
26733 HM1=PYMRUN(KFDP(IDC,1),SH)
26734 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
26735 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26737 WDTP(I)=FUDGE*WDTP(I)
26738 WDTP(0)=WDTP(0)+WDTP(I)
26739 IF(MDME(IDC,1).GT.0) THEN
26740 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26741 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26742 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26743 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26747 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
26749 ALPRHT=2.16D0*(3D0/ITCM(1))
26751 SIN2T=2D0*TANT3/(TANT3**2+1D0)
26752 SINT3=TANT3/SQRT(TANT3**2+1D0)
26755 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
26756 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
26757 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
26758 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
26759 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
26761 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
26763 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
26765 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
26767 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
26768 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
26769 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
26770 IF(ITCM(2).EQ.0) THEN
26775 DO 420 I=1,MDCY(KC,3)
26776 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
26777 & KFLA.EQ.KTECHN+300113)) GOTO 420
26779 IF(MDME(IDC,1).LT.0) GOTO 420
26780 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26781 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26782 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
26785 IF(I.EQ.6) WID2=WIDS(6,1)
26787 IF(KFLA.EQ.KTECHN+200113) THEN
26790 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
26793 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
26798 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
26799 FMIX=1D0/TANT3/SIN2T
26803 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
26804 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
26805 ELSEIF(I.EQ.7) THEN
26806 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
26807 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
26808 PSH=SHR*(1D0-RM1)/2D0
26809 WDTP(I)=AS/9D0*PSH**3/RM82
26811 WDTP(I)=2D0*WDTP(I)*CSXPP**2
26812 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
26814 WDTP(I)=5D0*WDTP(I)
26815 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
26818 WDTP(I)=FUDGE*WDTP(I)
26819 WDTP(0)=WDTP(0)+WDTP(I)
26820 IF(MDME(IDC,1).GT.0) THEN
26821 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26822 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26823 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26824 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26828 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
26829 C...d* excited quark.
26830 FAC=(SH/RTCM(41)**2)*SHR
26831 DO 430 I=1,MDCY(KC,3)
26833 IF(MDME(IDC,1).LT.0) GOTO 430
26834 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26835 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26836 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
26840 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26842 ELSEIF(I.EQ.2) THEN
26843 C...d* -> gamma + d.
26844 QF=-RTCM(43)/2D0+RTCM(44)/6D0
26845 WDTP(I)=FAC*AEM*QF**2/4D0
26847 ELSEIF(I.EQ.3) THEN
26849 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26850 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26851 & (1D0-RM1)**2*(2D0+RM1)
26853 ELSEIF(I.EQ.4) THEN
26855 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26856 & (1D0-RM1)**2*(2D0+RM1)
26857 IF(KFLR.GT.0) WID2=WIDS(24,3)
26858 IF(KFLR.LT.0) WID2=WIDS(24,2)
26860 WDTP(I)=FUDGE*WDTP(I)
26861 WDTP(0)=WDTP(0)+WDTP(I)
26862 IF(MDME(IDC,1).GT.0) THEN
26863 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26864 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26865 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26866 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26870 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
26871 C...u* excited quark.
26872 FAC=(SH/RTCM(41)**2)*SHR
26873 DO 440 I=1,MDCY(KC,3)
26875 IF(MDME(IDC,1).LT.0) GOTO 440
26876 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26877 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26878 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
26882 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26884 ELSEIF(I.EQ.2) THEN
26885 C...u* -> gamma + u.
26886 QF=RTCM(43)/2D0+RTCM(44)/6D0
26887 WDTP(I)=FAC*AEM*QF**2/4D0
26889 ELSEIF(I.EQ.3) THEN
26891 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26892 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26893 & (1D0-RM1)**2*(2D0+RM1)
26895 ELSEIF(I.EQ.4) THEN
26897 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26898 & (1D0-RM1)**2*(2D0+RM1)
26899 IF(KFLR.GT.0) WID2=WIDS(24,2)
26900 IF(KFLR.LT.0) WID2=WIDS(24,3)
26902 WDTP(I)=FUDGE*WDTP(I)
26903 WDTP(0)=WDTP(0)+WDTP(I)
26904 IF(MDME(IDC,1).GT.0) THEN
26905 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26906 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26907 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26908 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26912 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
26913 C...e* excited lepton.
26914 FAC=(SH/RTCM(41)**2)*SHR
26915 DO 450 I=1,MDCY(KC,3)
26917 IF(MDME(IDC,1).LT.0) GOTO 450
26918 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26919 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26920 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
26923 C...e* -> gamma + e.
26924 QF=-RTCM(43)/2D0-RTCM(44)/2D0
26925 WDTP(I)=FAC*AEM*QF**2/4D0
26927 ELSEIF(I.EQ.2) THEN
26929 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26930 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26931 & (1D0-RM1)**2*(2D0+RM1)
26933 ELSEIF(I.EQ.3) THEN
26935 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26936 & (1D0-RM1)**2*(2D0+RM1)
26937 IF(KFLR.GT.0) WID2=WIDS(24,3)
26938 IF(KFLR.LT.0) WID2=WIDS(24,2)
26940 WDTP(I)=FUDGE*WDTP(I)
26941 WDTP(0)=WDTP(0)+WDTP(I)
26942 IF(MDME(IDC,1).GT.0) THEN
26943 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26944 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26945 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26946 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26950 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
26951 C...nu*_e excited neutrino.
26952 FAC=(SH/RTCM(41)**2)*SHR
26953 DO 460 I=1,MDCY(KC,3)
26955 IF(MDME(IDC,1).LT.0) GOTO 460
26956 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26957 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26958 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
26961 C...nu*_e -> Z0 + nu*_e.
26962 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26963 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26964 & (1D0-RM1)**2*(2D0+RM1)
26966 ELSEIF(I.EQ.2) THEN
26967 C...nu*_e -> W+ + e.
26968 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26969 & (1D0-RM1)**2*(2D0+RM1)
26970 IF(KFLR.GT.0) WID2=WIDS(24,2)
26971 IF(KFLR.LT.0) WID2=WIDS(24,3)
26973 WDTP(I)=FUDGE*WDTP(I)
26974 WDTP(0)=WDTP(0)+WDTP(I)
26975 IF(MDME(IDC,1).GT.0) THEN
26976 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26977 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26978 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26979 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26983 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
26984 C...G* (graviton resonance):
26985 FAC=(PARP(50)**2/PARU(1))*SHR
26986 DO 470 I=1,MDCY(KC,3)
26988 IF(MDME(IDC,1).LT.0) GOTO 470
26989 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26990 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26991 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
26996 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
26997 & PYHFTH(SH,SH*RM1,1D0)
26998 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
26999 & (1D0+8D0*RM1/3D0)/320D0
27000 IF(I.EQ.6) WID2=WIDS(6,1)
27001 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
27002 ELSEIF(I.LE.16) THEN
27003 C...G* -> l+ + l-, nu + nubar
27005 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27006 & (1D0+8D0*RM1/3D0)/320D0
27007 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
27008 ELSEIF(I.EQ.17) THEN
27011 ELSEIF(I.EQ.18) THEN
27012 C...G* -> gamma + gamma.
27014 ELSEIF(I.EQ.19) THEN
27016 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27017 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
27019 ELSEIF(I.EQ.20) THEN
27021 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27022 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
27025 WDTP(I)=FUDGE*WDTP(I)
27026 WDTP(0)=WDTP(0)+WDTP(I)
27027 IF(MDME(IDC,1).GT.0) THEN
27028 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27029 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27030 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27031 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27035 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
27036 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
27037 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
27038 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
27039 DO 480 I=1,MDCY(KC,3)
27041 IF(MDME(IDC,1).LT.0) GOTO 480
27042 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
27043 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
27044 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
27045 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
27048 C...nu_lR -> l- qbar q'
27049 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27050 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27051 ELSEIF(I.LE.18) THEN
27052 C...nu_lR -> l+ q qbar'
27053 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
27054 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
27056 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
27058 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
27060 X=(PM1+PM2+PM3)/SHR
27061 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
27063 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
27064 WDTP(I)=FAC*FCOF*FX*FY
27065 WDTP(I)=FUDGE*WDTP(I)
27066 WDTP(0)=WDTP(0)+WDTP(I)
27067 IF(MDME(IDC,1).GT.0) THEN
27068 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27069 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27070 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27071 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27075 ELSEIF(KFLA.EQ.9900023) THEN
27077 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
27078 DO 490 I=1,MDCY(KC,3)
27080 IF(MDME(IDC,1).LT.0) GOTO 490
27081 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27082 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27083 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
27087 C...Z_R0 -> q + qbar
27089 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
27090 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
27092 IF(I.EQ.6) WID2=WIDS(6,1)
27093 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
27094 C...Z_R0 -> l+ + l-
27098 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
27099 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
27104 ELSEIF(I.LE.15) THEN
27105 C...Z0 -> nu_R + nu_R, assumed Majorana.
27109 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
27112 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
27113 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
27114 WDTP(I)=FUDGE*WDTP(I)
27115 WDTP(0)=WDTP(0)+WDTP(I)
27116 IF(MDME(IDC,1).GT.0) THEN
27117 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27118 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27119 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27120 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27124 ELSEIF(KFLA.EQ.9900024) THEN
27126 FAC=(AEM/(24D0*XW))*SHR
27127 DO 500 I=1,MDCY(KC,3)
27129 IF(MDME(IDC,1).LT.0) GOTO 500
27130 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27131 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27132 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
27135 C...W_R+/- -> q + qbar'
27136 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27138 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27140 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
27142 ELSEIF(I.LE.12) THEN
27143 C...W_R+/- -> l+/- + nu_R
27146 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27147 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27148 WDTP(I)=FUDGE*WDTP(I)
27149 WDTP(0)=WDTP(0)+WDTP(I)
27150 IF(MDME(IDC,1).GT.0) THEN
27151 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27152 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27153 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27154 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27158 ELSEIF(KFLA.EQ.9900041) THEN
27160 FAC=(1D0/(8D0*PARU(1)))*SHR
27161 DO 510 I=1,MDCY(KC,3)
27163 IF(MDME(IDC,1).LT.0) GOTO 510
27164 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27165 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27166 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
27169 C...H_L++/-- -> l+/- + l'+/-
27170 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27171 & (IABS(KFDP(IDC,2))-9)/2)**2
27172 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27173 ELSEIF(I.EQ.7) THEN
27174 C...H_L++/-- -> W_L+/- + W_L+/-
27175 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
27176 & (3D0*RM1+0.25D0/RM1-1D0)
27177 WID2=WIDS(24,4+(1-KFLS)/2)
27180 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27181 WDTP(I)=FUDGE*WDTP(I)
27182 WDTP(0)=WDTP(0)+WDTP(I)
27183 IF(MDME(IDC,1).GT.0) THEN
27184 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27185 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27186 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27187 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27191 ELSEIF(KFLA.EQ.9900042) THEN
27193 FAC=(1D0/(8D0*PARU(1)))*SHR
27194 DO 520 I=1,MDCY(KC,3)
27196 IF(MDME(IDC,1).LT.0) GOTO 520
27197 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27198 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27199 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
27202 C...H_R++/-- -> l+/- + l'+/-
27203 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27204 & (IABS(KFDP(IDC,2))-9)/2)**2
27205 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27206 ELSEIF(I.EQ.7) THEN
27207 C...H_R++/-- -> W_R+/- + W_R+/-
27208 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
27209 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
27212 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27213 WDTP(I)=FUDGE*WDTP(I)
27214 WDTP(0)=WDTP(0)+WDTP(I)
27215 IF(MDME(IDC,1).GT.0) THEN
27216 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27217 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27218 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27219 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27223 ELSEIF(KFLA.EQ.KTECHN+115) THEN
27225 C...Need to update to alpha_rho
27226 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27227 FAC=(ALPRHT/12D0)*SHR
27228 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
27232 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
27234 XWRHT=1D0/(4D0*XW*(1D0-XW))
27235 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
27236 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
27237 DO 530 I=1,MDCY(KC,3)
27239 IF(MDME(IDC,1).LT.0) GOTO 530
27240 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27241 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27242 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
27244 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27247 FACPA=PCM**2+1.5D0*RM1
27250 C...a2_tc0 -> W+ + W-
27252 AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
27253 C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
27255 C...a2_tc0 -> W+ + pi_tc- + c.c.
27256 ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
27257 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27259 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27261 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
27263 ELSEIF(I.EQ.4) THEN
27264 C...a2_tc0 -> Z0 + pi_tc0'
27265 VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
27266 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27268 WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
27269 ELSEIF(I.GE.5.AND.I.LE.10) THEN
27270 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27271 FACPA=PCM**2*(1D0+RM1+RM2)
27275 C...a_T^0 -> gamma rho_T^0
27276 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27277 WID2=WIDS(PYCOMP(KTECHN+113),2)
27278 ELSEIF(I.EQ.6) THEN
27279 C...a_T^0 -> gamma omega_T
27280 VA2=1D0/RTCM(50)**4
27281 WID2=WIDS(PYCOMP(KTECHN+223),2)
27282 ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
27283 C...a_T^0 -> W^+- rho_T^-+
27284 AA2=.25D0/XW/RTCM(51)**4
27286 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
27288 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
27290 ELSEIF(I.EQ.9) THEN
27291 C...a_T^0 -> Z^0 rho_T^0
27292 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27293 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
27294 ELSEIF(I.EQ.10) THEN
27295 C...a_T^0 -> Z^0 omega_T
27296 VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
27297 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
27299 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27301 C...a2_tc0 -> f + fbar.
27306 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27310 IF(IA.GE.17) WID2=WIDS(IA,1)
27313 AI=SIGN(1D0,EI+0.1D0)
27317 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27318 & ((VALI*BWZR)**2+(VALI*BWZI)**2+
27319 & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27320 & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
27322 WDTP(I)=FUDGE*WDTP(I)
27323 WDTP(0)=WDTP(0)+WDTP(I)
27324 IF(MDME(IDC,1).GT.0) THEN
27325 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27326 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27327 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27328 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27332 ELSEIF(KFLA.EQ.KTECHN+215) THEN
27334 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27335 FAC=(ALPRHT/12D0)*SHR
27339 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
27341 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
27342 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
27343 DO 540 I=1,MDCY(KC,3)
27345 IF(MDME(IDC,1).LT.0) GOTO 540
27346 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27347 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27348 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
27350 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27359 C...a2_tc+ -> gamma + W+.
27361 AA2=RTCM(3)**2/RTCM(49)**2
27362 WID2=WIDS(24,ICHANN)
27363 C...a2_tc+ -> gamma + pi_tc+.
27364 ELSEIF(I.EQ.2) THEN
27365 AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
27366 WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
27367 C...a2_tc+ -> W+ + Z
27368 ELSEIF(I.EQ.3) THEN
27369 AA2=RTCM(3)**2*(1D0/4D0/XW1 +
27370 & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
27371 WID2=WIDS(24,ICHANN)*WIDS(23,2)
27372 C...a2_tc+ -> W+ + pi_tc0.
27373 ELSEIF(I.EQ.4) THEN
27374 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27375 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
27376 C...a2_tc+ -> W+ + pi_tc'0.
27377 ELSEIF(I.EQ.5) THEN
27378 VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
27379 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
27380 C...a2_tc+ -> Z0 + pi_tc+.
27381 ELSEIF(I.EQ.6) THEN
27382 AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
27384 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
27386 WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27388 ELSEIF(I.LE.10) THEN
27389 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27390 FACPA=PCM**2*(1D0+RM1+RM2)
27393 C...a2_tc+ -> gamma + rho_tc+
27395 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27396 WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
27397 C...a2_tc+ -> W+ + rho_T^0
27398 ELSEIF(I.EQ.8) THEN
27399 AA2=1D0/(4D0*XW)/RTCM(51)**4
27400 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
27401 C...a2_tc+ -> W+ + omega_T
27402 ELSEIF(I.EQ.9) THEN
27403 VA2=.25D0/XW/RTCM(50)**4
27404 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
27405 C...a2_tc+ -> Z^0 + rho_T^+
27406 ELSEIF(I.EQ.10) THEN
27407 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27408 AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
27409 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
27411 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27413 C...a2_tc+ -> f + fbar'.
27417 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
27419 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
27420 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
27421 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
27423 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
27424 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
27425 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
27430 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
27432 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
27435 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27436 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27438 WDTP(I)=FUDGE*WDTP(I)
27439 WDTP(0)=WDTP(0)+WDTP(I)
27440 IF(MDME(IDC,1).GT.0) THEN
27441 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27442 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27443 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27444 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27455 C***********************************************************************
27458 C...Calculates partial width and differential cross-section maxima
27459 C...of channels/processes not allowed on mass-shell, and selects
27460 C...masses in such channels/processes.
27462 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
27464 C...Double precision and integer declarations.
27465 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27466 IMPLICIT INTEGER(I-N)
27467 INTEGER PYK,PYCHGE,PYCOMP
27469 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27470 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27471 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
27472 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27473 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27474 COMMON/PYINT1/MINT(400),VINT(400)
27475 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27476 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
27477 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
27480 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
27481 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
27482 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
27485 C...Find if particles equal, maximum mass, matrix elements, etc.
27491 IF(KFD(1).EQ.KFD(2)) MEQL=1
27493 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
27494 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
27500 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
27503 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
27504 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
27505 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
27506 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
27507 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
27508 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
27511 C...Find where Breit-Wigners are required, else select discrete masses.
27513 KFCA=PYCOMP(KFD(I))
27515 PMD(I)=PMAS(KFCA,1)
27516 PGD(I)=PMAS(KFCA,2)
27521 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
27524 RMG(I)=(PMG(I)/PMMX)**2
27530 C...Find allowed mass range and Breit-Wigner parameters.
27532 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
27534 PMU(I)=PMMX-PARP(42)
27535 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
27536 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27537 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
27539 IF(MLM.EQ.2) ILM=3-I
27540 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
27541 IF(MBW(3-I).EQ.0) THEN
27542 PMU(I)=PMMX-PMD(3-I)
27544 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
27546 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
27547 & MIN(PMU(I),CKIN(NOFF+2*ILM))
27548 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
27549 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
27550 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27551 IF(MBW(I).EQ.1) THEN
27552 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27553 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27554 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
27557 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
27559 IF(MLM.EQ.2) ILM=3-I
27560 PML(I)=MAX(CKIN(48+I),PARP(42))
27561 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
27562 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
27563 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
27564 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
27565 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27566 IF(MBW(I).EQ.1) THEN
27567 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27568 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27569 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
27574 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
27576 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
27581 C...Calculation of partial width of resonance.
27582 IF(MOFSH.EQ.1) THEN
27584 C..If only one integration, pick that to be the inner.
27585 IF(MBW(1).EQ.0) THEN
27591 ELSEIF(MBW(2).EQ.0) THEN
27595 C...Start outer loop of integration.
27596 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27597 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
27598 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
27604 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27605 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
27606 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
27610 C...Start inner loop of integration.
27612 PMU1=MIN(PMU(1),PMMX-PM2)
27613 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
27614 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
27615 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
27616 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
27624 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
27625 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
27628 C...Evaluate function value - inner loop.
27629 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27630 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
27631 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
27632 & RM2**2+10D0*RM1*RM2)
27633 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
27636 C...Go to next position in inner loop.
27642 ELSEIF(NPT1.LE.8) THEN
27644 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
27646 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
27647 INX1(NPT1)=INX1(ISH1)
27650 ELSEIF(NPT1.LT.100) THEN
27653 IF(ISH1.GT.NPT1) ISH1=2
27654 IF(ISH1.EQ.ISN1) GOTO 160
27655 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
27656 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
27658 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
27659 INX1(NPT1)=INX1(ISH1)
27664 C...Calculate integral over inner loop.
27667 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
27668 & (XPT1(INX1(IPT1))-XPT1(IPT1))
27670 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
27671 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27672 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
27675 C...Go to next position in outer loop.
27681 ELSEIF(NPT2.LE.8) THEN
27683 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
27685 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
27686 INX2(NPT2)=INX2(ISH2)
27689 ELSEIF(NPT2.LT.100) THEN
27692 IF(ISH2.GT.NPT2) ISH2=2
27693 IF(ISH2.EQ.ISN2) GOTO 200
27694 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
27695 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
27697 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
27698 INX2(NPT2)=INX2(ISH2)
27703 C...Calculate integral over outer loop.
27706 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
27707 & (XPT2(INX2(IPT2))-XPT2(IPT2))
27709 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
27710 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
27715 C...Save result; second integration for user-selected mass range.
27716 IF(LOOP.EQ.1) WIDW=FSUM2
27718 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
27719 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
27726 C...Select two decay product masses of a resonance.
27727 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
27729 IF(MBW(I).EQ.0) GOTO 230
27730 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
27732 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
27733 RMG(I)=(PMG(I)/PMMX)**2
27735 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
27736 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
27738 C...Weight with matrix element (if none known, use beta factor).
27739 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
27741 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
27742 ELSEIF(MMED.EQ.2) THEN
27743 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
27744 & RMG(2)**2+10D0*RMG(1)*RMG(2))
27745 ELSEIF(MMED.EQ.3) THEN
27746 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
27750 IF(WTBE.LT.PYR(0)) GOTO 220
27754 C...Find suitable set of masses for initialization of 2 -> 2 processes.
27755 ELSEIF(MOFSH.EQ.3) THEN
27756 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
27757 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
27759 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
27761 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
27765 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
27766 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
27767 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
27772 C...Evaluate importance of excluded tails of Breit-Wigners.
27773 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
27774 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
27778 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
27782 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
27783 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
27785 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
27786 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
27787 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
27788 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27790 C...Pick one particle to be the lighter (if improves efficiency).
27791 ELSEIF(MOFSH.EQ.4) THEN
27792 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
27793 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
27794 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
27796 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
27798 IF(MBW(I).EQ.0) GOTO 270
27800 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
27802 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
27804 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27805 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
27806 IF(RBR.LT.0.8D0) THEN
27807 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
27808 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
27809 ELSEIF(RBR.LT.0.9D0) THEN
27810 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
27811 ELSEIF(RBR.LT.1.5D0) THEN
27812 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
27814 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
27815 & (PMV**2-PML(I)**2))))
27818 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
27819 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
27820 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
27821 NGEN(0,1)=NGEN(0,1)+1
27822 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
27832 C...Give weight for selected mass distribution.
27835 IF(MBW(I).EQ.0) GOTO 280
27837 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
27839 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
27840 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
27841 & (PMD(I)*PGD(I))**2)/PARU(1)
27845 FI0=(ATV-ATL(I))/PARU(1)
27846 FI1=PMV**2-PML(I)**2
27847 FI2=2D0*LOG(PMV/PML(I))
27848 FI3=1D0/PML(I)**2-1D0/PMV**2
27849 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27850 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
27851 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
27854 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
27856 VINT(80)=VINT(80)*FI0
27858 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27864 C***********************************************************************
27867 C...Handles the possibility of colour reconnection in W+W- events,
27868 C...Based on the main scenarios of the Sjostrand and Khoze study:
27869 C...I, II, II', intermediate and instantaneous; plus one model
27870 C...along the lines of the Gustafson and Hakkinen: GH.
27871 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
27872 C...is as if first resonance is W+ and second W-.
27874 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
27876 C...Double precision and integer declarations.
27877 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27878 IMPLICIT INTEGER(I-N)
27879 INTEGER PYK,PYCHGE,PYCOMP
27880 C...Parameter value; number of points in MC integration.
27881 PARAMETER (NPT=100)
27883 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27884 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27885 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27886 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27887 COMMON/PYINT1/MINT(400),VINT(400)
27888 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27890 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
27891 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
27892 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
27893 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
27894 &TMC(20),IJOIN(100)
27896 C...Functions to give four-product and to do determinants.
27897 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)
27898 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
27899 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
27900 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
27902 C...Only allow fraction of recoupling for GH, intermediate and
27904 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27905 IF(PYR(0).GT.PARP(120)) RETURN
27909 C...Common part for scenarios I, II, II', and GH.
27910 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
27911 &MSTP(115).EQ.5) THEN
27913 C...Read out frequently-used parameters.
27917 IF(ISUB.EQ.22) PMW=PMAS(23,1)
27919 IF(ISUB.EQ.22) PGW=PMAS(23,2)
27926 C...Find range of decay products of the W's.
27927 C...Background: the W's are stored in IW1 and IW2.
27928 C...Their direct decay products in NSD1+1 through NSD1+4.
27929 C...Products after shower (if any) in NSD1+5 through NAFT1
27930 C...for first W and in NAFT1+1 through N for the second.
27931 IF(NAFT1.GT.NSD1+4) THEN
27938 IF(N.GT.NAFT1) THEN
27946 C...Rearrange parton shower products along strings.
27948 CALL PYPREP(NSD1+1)
27949 IF(MINT(51).NE.0) RETURN
27951 C...Find partons pointing back to W+ and W-; store them with quark
27952 C...end of string first.
27958 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
27959 IF(IABS(K(I,2)).GE.22) GOTO 120
27960 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
27961 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
27971 IF(K(I,1).EQ.1) ISGP=0
27972 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
27973 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
27983 IF(K(I,1).EQ.1) ISGM=0
27987 C...Boost to W+W- rest frame (not strictly needed).
27989 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
27991 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27992 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27993 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27995 C...Select decay vertices of W+ and W-.
27996 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
27997 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
27998 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
27999 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
28002 XP(J)=TP*P(IW1,J)/P(IW1,4)
28003 XM(J)=TM*P(IW2,J)/P(IW2,4)
28006 C...Begin scenario I specifics.
28007 IF(MSTP(115).EQ.1) THEN
28009 C...Reconstruct velocity and direction of W+ string pieces.
28011 IF(K(INP(IIP),2).LT.0) GOTO 170
28014 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28015 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28019 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
28020 DIRP(IIP,J)=V1(J)-V2(J)
28022 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
28024 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
28026 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
28030 C...Reconstruct velocity and direction of W- string pieces.
28032 IF(K(INM(IIM),2).LT.0) GOTO 200
28035 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28036 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28040 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
28041 DIRM(IIM,J)=V1(J)-V2(J)
28043 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
28045 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
28047 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
28051 C...Loop over number of space-time points.
28056 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
28057 R=SQRT(-LOG(PYR(0)))
28059 X=BLOWR*RHAD*R*COS(PHI)
28060 Y=BLOWR*RHAD*R*SIN(PHI)
28061 R=SQRT(-LOG(PYR(0)))
28063 Z=BLOWR*RHAD*R*COS(PHI)
28064 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
28066 C...Reject impossible points. Weight for sample distribution.
28067 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
28068 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
28069 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
28071 C...Loop over W+ string pieces and find one with largest weight.
28079 IF(K(INP(IIP),2).LT.0) GOTO 220
28080 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
28081 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
28083 XB(J)=XD(J)+BEDG*BETP(IIP,J)
28085 XB(4)=BETP(IIP,4)*(XD(4)-BED)
28086 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28087 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
28088 & DIRP(IIP,3)*XB(3))**2
28089 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28091 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
28092 IF(WTP.GT.WTMAXP) THEN
28098 C...Loop over W- string pieces and find one with largest weight.
28106 IF(K(INM(IIM),2).LT.0) GOTO 240
28107 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
28108 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
28110 XB(J)=XD(J)+BEDG*BETM(IIM,J)
28112 XB(4)=BETM(IIM,4)*(XD(4)-BED)
28113 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28114 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
28115 & DIRM(IIM,3)*XB(3))**2
28116 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28118 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
28119 IF(WTM.GT.WTMAXM) THEN
28125 C...Result of integration.
28127 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
28128 WT=WTMAXP*WTMAXM/WTSMP
28136 RES=BLOWR**3*BLOWT*SUM/NPT
28138 C...Decide whether to reconnect and, if so, where.
28140 PREC=1D0-EXP(-FACT*RES)
28141 IF(PREC.GT.PYR(0)) THEN
28146 IF(RSUM.LE.0D0) GOTO 270
28152 C...Begin scenario II and II' specifics.
28153 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
28155 C...Loop through all string pieces, one from W+ and one from W-.
28159 IF(K(INP(IIP),2).LT.0) GOTO 340
28163 IF(K(INM(IIM),2).LT.0) GOTO 330
28167 C...Find endpoint velocity vectors.
28169 V1P(J)=P(I1P,J)/P(I1P,4)
28170 V2P(J)=P(I2P,J)/P(I2P,4)
28171 V1M(J)=P(I1M,J)/P(I1M,4)
28172 V2M(J)=P(I2M,J)/P(I2M,4)
28175 C...Define q matrix and find t.
28177 Q(1,J)=V2P(J)-V1P(J)
28178 Q(2,J)=-(V2M(J)-V1M(J))
28179 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
28180 Q(4,J)=V1P(J)-V1M(J)
28182 T=-DETER(1,2,3)/DETER(1,2,4)
28184 C...Find alpha and beta; i.e. coordinates of crossing point.
28187 S13=Q(3,1)+Q(4,1)*T
28190 S23=Q(3,2)+Q(4,2)*T
28191 DEN=S11*S22-S12*S21
28192 ALP=(S12*S23-S22*S13)/DEN
28193 BET=(S21*S13-S11*S23)/DEN
28195 C...Check if solution acceptable.
28197 IF(T.LT.GTMAX) IANSW=0
28198 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
28199 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
28201 C...Find point of crossing and check that not inconsistent.
28203 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
28204 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
28206 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
28207 & (XPP(3)-XMM(3))**2
28208 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
28209 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
28210 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
28212 C...Find string eigentimes at crossing.
28213 IF(IANSW.EQ.1) THEN
28214 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
28215 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
28216 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
28217 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
28223 C...Order crossings by time. End loop over crossings.
28224 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
28226 DO 310 I1=NCROSS,1,-1
28227 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
28247 C...Loop over crossings; find first (if any) acceptable one.
28249 IF(NCROSS.GE.1) THEN
28251 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
28252 IF(PNFRAG.GT.PYR(0)) THEN
28253 C...Scenario II: only compare with fragmentation time.
28254 IF(MSTP(115).EQ.2) THEN
28259 C...Scenario II': also require that string length decreases.
28267 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28268 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28269 IF(ELNEW.LT.ELOLD) THEN
28281 C...Begin scenario GH specifics.
28282 ELSEIF(MSTP(115).EQ.5) THEN
28284 C...Loop through all string pieces, one from W+ and one from W-.
28288 IF(K(INP(IIP),2).LT.0) GOTO 380
28292 IF(K(INM(IIM),2).LT.0) GOTO 370
28296 C...Look for largest decrease of (exponent of) Lambda measure.
28297 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28298 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28299 ELDIF=ELNEW/MAX(1D-10,ELOLD)
28300 IF(ELDIF.LT.ELMIN) THEN
28312 C...Common for scenarios I, II, II' and GH: reconnect strings.
28316 DO 390 IS=1,NNP+NNM
28320 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
28322 ELSEIF(IS.LE.IIP+NNM) THEN
28323 I=INM(IS-IIP-NNM+IIM)
28328 IF(K(I,2).LT.0) THEN
28329 CALL PYJOIN(NJOIN,IJOIN)
28334 C...Restore original event record if no reconnection.
28336 DO 400 I=NSD1+1,NOLD
28337 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
28338 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28339 K(I,5)=MOD(K(I,5),MSTU(5)**2)
28348 C...Boost back system.
28349 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
28350 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
28351 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
28352 & BEWW(1),BEWW(2),BEWW(3))
28354 C...Common part for intermediate and instantaneous scenarios.
28355 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
28358 C...Remove old shower products and reset showering ones.
28360 DO 420 I=NSD1+1,NSD1+4
28362 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28363 K(I,5)=MOD(K(I,5),MSTU(5)**2)
28366 C...Identify quark-antiquark pairs.
28370 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
28373 C...Reconnect strings.
28376 CALL PYJOIN(2,IJOIN)
28379 CALL PYJOIN(2,IJOIN)
28381 C...Do new parton showers in intermediate scenario.
28382 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
28385 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
28386 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
28389 C...Do new parton showers in instantaneous scenario.
28390 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
28391 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
28392 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
28393 PPM=SQRT(MAX(0D0,PPM2))
28394 CALL PYSHOW(IQ1,IQ4,PPM)
28395 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
28396 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
28397 PPM=SQRT(MAX(0D0,PPM2))
28398 CALL PYSHOW(IQ3,IQ2,PPM)
28405 C***********************************************************************
28408 C...Checks generated variables against pre-set kinematical limits;
28409 C...also calculates limits on variables used in generation.
28411 SUBROUTINE PYKLIM(ILIM)
28413 C...Double precision and integer declarations.
28414 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28415 IMPLICIT INTEGER(I-N)
28416 INTEGER PYK,PYCHGE,PYCOMP
28418 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28419 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28420 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28421 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28422 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28423 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28424 COMMON/PYINT1/MINT(400),VINT(400)
28425 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28426 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
28429 C...Common kinematical expressions.
28433 IF(ISUB.EQ.96) GOTO 100
28437 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
28438 CKIN09=MAX(CKIN(9),CKIN(13))
28439 CKIN10=MIN(CKIN(10),CKIN(14))
28440 CKIN11=MAX(CKIN(11),CKIN(15))
28441 CKIN12=MIN(CKIN(12),CKIN(16))
28443 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
28444 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
28445 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
28446 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
28451 RM3=SQM3/(TAU*VINT(2))
28452 RM4=SQM4/(TAU*VINT(2))
28453 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
28456 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
28457 &PTHMIN=MAX(CKIN(3),CKIN(5))
28460 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
28461 C...pre-set kinematical limits.
28466 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
28467 X1=SQRT(TAUE)*EXP(YST)
28468 X2=SQRT(TAUE)*EXP(-YST)
28470 IF(MINT(47).NE.1) THEN
28471 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
28472 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
28473 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
28474 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
28476 IF(MINT(45).NE.1) THEN
28477 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
28479 IF(MINT(46).NE.1) THEN
28480 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
28482 IF(MINT(45).EQ.2) THEN
28483 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
28485 IF(MINT(46).EQ.2) THEN
28486 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
28488 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
28489 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
28490 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
28491 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
28492 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
28493 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
28494 Y3=YST+0.5D0*LOG(EXPY3)
28495 Y4=YST+0.5D0*LOG(EXPY4)
28500 STH=SQRT(MAX(0D0,1D0-CTH**2))
28501 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
28502 & CTH)**2-4D0*RM3))
28503 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
28504 & CTH)**2-4D0*RM4))
28505 IF(STH.GE.1D-10) THEN
28506 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
28508 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
28510 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
28511 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
28512 ETALAR=MAX(ETA3,ETA4)
28513 ETASMA=MIN(ETA3,ETA4)
28515 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
28516 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
28517 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
28518 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
28520 RPTS=4D0*VINT(71)**2/SH
28521 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
28522 RM34=MAX(1D-20,2D0*RM3*RM4)
28523 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28524 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28525 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
28526 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
28527 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
28528 IF(PTH.LT.PTHMIN) MINT(51)=1
28529 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
28530 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
28531 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
28532 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
28533 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
28534 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
28535 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
28536 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
28537 IF(THA.LT.CKIN(35)) MINT(51)=1
28538 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
28539 IF(UHA.LT.CKIN(37)) MINT(51)=1
28540 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
28542 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28543 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
28544 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
28547 C...Additional cuts on W2 (approximately) in DIS.
28548 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
28550 IF(IABS(MINT(12)).LT.20) XBJ=X1
28552 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
28553 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
28554 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
28557 ELSEIF(ILIM.EQ.1) THEN
28558 C...Calculate limits on tau
28559 C...0) due to definition
28562 C...1) due to limits on subsystem mass
28563 TAUMN1=CKIN(1)**2/VINT(2)
28565 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
28566 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
28567 TM3=SQRT(SQM3+PTHMIN**2)
28568 TM4=SQRT(SQM4+PTHMIN**2)
28570 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
28571 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
28573 C...3) due to limits on pT-hat and cos(theta-hat)
28574 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
28575 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
28577 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
28578 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
28579 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
28581 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
28582 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
28583 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
28584 C...4) due to limits on x1 and x2
28585 TAUMN4=CKIN(21)*CKIN(23)
28586 TAUMX4=CKIN(22)*CKIN(24)
28587 C...5) due to limits on xF
28589 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
28590 C...6) due to limits on that and uhat
28591 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
28593 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
28594 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
28596 C...Net effect of all separate limits.
28597 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
28598 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
28599 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28602 ELSEIF(MINT(47).EQ.5) THEN
28603 VINT(31)=MIN(VINT(31),1D0-2D-10)
28604 ELSEIF(MINT(47).GE.6) THEN
28605 VINT(31)=MIN(VINT(31),1D0-1D-10)
28607 IF(VINT(31).LE.VINT(11)) MINT(51)=1
28609 ELSEIF(ILIM.EQ.2) THEN
28610 C...Calculate limits on y*
28612 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28614 C...0) due to kinematics
28617 C...1) due to explicit limits
28620 C...2) due to limits on x1
28621 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
28622 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
28623 C...3) due to limits on x2
28624 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
28625 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
28626 C...4) due to limits on xF
28627 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
28628 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
28629 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
28630 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
28631 C...5) due to simultaneous limits on y-large and y-small
28632 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
28633 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
28634 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
28635 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
28636 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
28637 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
28638 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
28640 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
28641 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
28642 RZMX=BE34*MIN(CKIN(28),CTHLIM)
28643 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
28644 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
28645 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
28646 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
28647 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
28648 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
28650 C...Net effect of all separate limits.
28651 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
28652 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
28653 IF(MINT(47).EQ.1) THEN
28656 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28657 VINT(12)=(1D0-1D-9)*YSTMX0
28658 VINT(32)=(1D0+1D-9)*YSTMX0
28659 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28660 VINT(12)=-(1D0+1D-9)*YSTMX0
28661 VINT(32)=-(1D0-1D-9)*YSTMX0
28662 ELSEIF(MINT(47).EQ.5) THEN
28663 YSTEE=LOG((1D0-1D-10)/TAURT)
28664 VINT(12)=MAX(VINT(12),-YSTEE)
28665 VINT(32)=MIN(VINT(32),YSTEE)
28667 IF(VINT(32).LE.VINT(12)) MINT(51)=1
28669 ELSEIF(ILIM.EQ.3) THEN
28670 C...Calculate limits on cos(theta-hat)
28672 C...0) due to definition
28677 C...1) due to explicit limits
28678 CTNMN1=MIN(0D0,CKIN(27))
28679 CTNMX1=MIN(0D0,CKIN(28))
28680 CTPMN1=MAX(0D0,CKIN(27))
28681 CTPMX1=MAX(0D0,CKIN(28))
28682 C...2) due to limits on pT-hat
28683 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
28687 IF(CKIN(4).GE.0D0) THEN
28688 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
28689 & (BE34**2*TAU*VINT(2))))
28692 C...3) due to limits on y-large and y-small
28693 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
28694 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
28695 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
28696 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
28697 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
28698 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
28699 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
28700 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
28701 C...4) due to limits on that
28707 IF(CKIN(35).GT.0D0) THEN
28708 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
28709 IF(CTLIM.GT.0D0) THEN
28716 IF(CKIN(36).GT.0D0) THEN
28717 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
28718 IF(CTLIM.LT.0D0) THEN
28725 C...5) due to limits on uhat
28730 IF(CKIN(37).GT.0D0) THEN
28731 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
28732 IF(CTLIM.LT.0D0) THEN
28739 IF(CKIN(38).GT.0D0) THEN
28740 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
28741 IF(CTLIM.GT.0D0) THEN
28749 C...Net effect of all separate limits.
28750 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
28751 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
28752 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
28753 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
28754 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
28756 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
28757 IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
28759 ELSEIF(ILIM.EQ.4) THEN
28760 C...Calculate limits on tau'
28761 C...0) due to kinematics
28763 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
28764 PQRAT=(VINT(201)+VINT(206))/VINT(1)
28765 TAPMN0=(SQRT(TAU)+PQRAT)**2
28768 C...1) due to explicit limits
28769 TAPMN1=CKIN(31)**2/VINT(2)
28771 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
28773 C...Net effect of all separate limits.
28774 VINT(16)=MAX(TAPMN0,TAPMN1)
28775 VINT(36)=MIN(TAPMX0,TAPMX1)
28776 IF(MINT(47).EQ.1) THEN
28779 ELSEIF(MINT(47).EQ.5) THEN
28780 VINT(36)=MIN(VINT(36),1D0-2D-10)
28781 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
28782 VINT(36)=MIN(VINT(36),1D0-1D-10)
28784 IF(VINT(36).LE.VINT(16)) MINT(51)=1
28789 C...Special case for low-pT and multiple interactions:
28790 C...effective kinematical limits for tau, y*, cos(theta-hat).
28791 100 IF(ILIM.EQ.0) THEN
28792 ELSEIF(ILIM.EQ.1) THEN
28793 IF(MSTP(82).LE.1) THEN
28794 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
28797 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
28800 ELSEIF(ILIM.EQ.2) THEN
28801 VINT(12)=0.5D0*LOG(VINT(21))
28803 ELSEIF(ILIM.EQ.3) THEN
28804 IF(MSTP(82).LE.1) THEN
28805 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
28806 & (VINT(21)*VINT(2))
28808 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
28809 & (VINT(21)*VINT(2))
28811 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
28820 C*********************************************************************
28823 C...Maps a uniform distribution into a distribution of a kinematical
28824 C...variable according to one of the possibilities allowed. It is
28825 C...assumed that kinematical limits have been set by a PYKLIM call.
28827 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
28829 C...Double precision and integer declarations.
28830 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28831 IMPLICIT INTEGER(I-N)
28832 INTEGER PYK,PYCHGE,PYCOMP
28834 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28835 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28836 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28837 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28838 COMMON/PYINT1/MINT(400),VINT(400)
28839 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28840 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
28842 C...Convert VVAR to tau variable.
28848 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
28851 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
28854 ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
28858 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28860 ELSEIF(MVAR.EQ.1) THEN
28861 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
28862 ELSEIF(MVAR.EQ.2) THEN
28863 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
28864 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
28865 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
28866 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
28867 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
28868 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
28869 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
28870 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
28871 ELSEIF(MINT(47).EQ.5) THEN
28872 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
28873 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
28874 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28876 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
28877 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
28878 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28880 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
28882 C...Convert VVAR to y* variable.
28883 ELSEIF(IVAR.EQ.2) THEN
28887 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28888 IF(MINT(47).EQ.1) THEN
28890 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28891 YST=-0.5D0*LOG(TAUE)
28892 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28893 YST=0.5D0*LOG(TAUE)
28894 ELSEIF(MVAR.EQ.1) THEN
28895 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
28896 ELSEIF(MVAR.EQ.2) THEN
28897 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
28898 ELSEIF(MVAR.EQ.3) THEN
28899 AUPP=ATAN(EXP(YSTMAX))
28900 ALOW=ATAN(EXP(YSTMIN))
28901 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
28902 ELSEIF(MVAR.EQ.4) THEN
28903 YST0=-0.5D0*LOG(TAUE)
28904 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
28905 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28906 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
28908 YST0=-0.5D0*LOG(TAUE)
28909 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28910 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
28911 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
28913 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
28915 C...Convert VVAR to cos(theta-hat) variable.
28916 ELSEIF(IVAR.EQ.3) THEN
28917 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
28919 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28920 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28928 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28929 VCTN=VVAR*(ANEG+APOS)/ANEG
28930 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
28932 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28933 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
28935 ELSEIF(MVAR.EQ.2) THEN
28936 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28937 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28938 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28939 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28940 ANEG=LOG(RMNMIN/RMNMAX)
28941 APOS=LOG(RMPMIN/RMPMAX)
28942 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28943 VCTN=VVAR*(ANEG+APOS)/ANEG
28944 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
28946 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28947 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
28949 ELSEIF(MVAR.EQ.3) THEN
28950 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28951 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28952 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28953 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28954 ANEG=LOG(RMNMAX/RMNMIN)
28955 APOS=LOG(RMPMAX/RMPMIN)
28956 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28957 VCTN=VVAR*(ANEG+APOS)/ANEG
28958 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
28960 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28961 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
28963 ELSEIF(MVAR.EQ.4) THEN
28964 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28965 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28966 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28967 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28968 ANEG=1D0/RMNMAX-1D0/RMNMIN
28969 APOS=1D0/RMPMAX-1D0/RMPMIN
28970 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28971 VCTN=VVAR*(ANEG+APOS)/ANEG
28972 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
28974 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28975 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
28977 ELSEIF(MVAR.EQ.5) THEN
28978 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28979 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28980 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28981 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28982 ANEG=1D0/RMNMIN-1D0/RMNMAX
28983 APOS=1D0/RMPMIN-1D0/RMPMAX
28984 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28985 VCTN=VVAR*(ANEG+APOS)/ANEG
28986 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
28988 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28989 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
28992 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
28993 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
28996 C...Convert VVAR to tau' variable.
28997 ELSEIF(IVAR.EQ.4) THEN
29001 IF(MINT(47).EQ.1) THEN
29003 ELSEIF(MVAR.EQ.1) THEN
29004 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
29005 ELSEIF(MVAR.EQ.2) THEN
29006 AUPP=(1D0-TAU/TAUPMX)**4
29007 ALOW=(1D0-TAU/TAUPMN)**4
29008 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
29009 ELSEIF(MINT(47).EQ.5) THEN
29010 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
29011 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
29012 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29014 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
29015 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
29016 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29018 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
29020 C...Selection of extra variables needed in 2 -> 3 process:
29021 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
29022 C...Since no options are available, the functions of PYKLIM
29023 C...and PYKMAP are joint for these choices.
29024 ELSEIF(IVAR.EQ.5) THEN
29026 C...Read out total energy and particle masses.
29029 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
29030 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
29032 SHP=VINT(26)*VINT(2)
29036 PM3=SQRT(VINT(21))*VINT(1)
29037 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
29044 C...Specify coefficients of pT choice; upper and lower limits.
29045 IF(MPTPK.EQ.1) THEN
29053 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
29055 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
29057 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
29059 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
29062 C...Select transverse momenta according to
29063 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
29066 IF(HMX.LT.1.0001D0*HMN) THEN
29072 IF(RPT.LT.HWT1) THEN
29073 PTS1=PTSMN1+PYR(0)*HDE
29074 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29075 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
29077 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
29079 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
29080 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
29083 IF(HMX.LT.1.0001D0*HMN) THEN
29089 IF(RPT.LT.HWT1) THEN
29090 PTS2=PTSMN2+PYR(0)*HDE
29091 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29092 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
29094 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
29096 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
29097 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
29099 C...Select azimuthal angles and check pT choice.
29100 PHI1=PARU(2)*PYR(0)
29101 PHI2=PARU(2)*PYR(0)
29103 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
29104 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
29105 & CKIN(56)**2)) THEN
29110 C...Calculate transverse masses and check phase space not closed.
29117 PM12=(PMT1+PMT2)**2
29118 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
29123 C...Select rapidity for particle 3 and check phase space not closed.
29124 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
29125 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
29126 IF(Y3MAX.LT.1D-6) THEN
29130 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
29134 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
29137 PMS12=PE12**2-PZ12**2
29138 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
29139 IF(SQL12.LT.1D-6*SHP) THEN
29143 PMM1=PMS12+PMS1-PMS2
29144 PMM2=PMS12+PMS2-PMS1
29145 TFAC=-SHPR/(2D0*PMS12)
29146 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
29147 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
29148 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
29149 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
29151 C...Construct relative mirror weights and make choice.
29152 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
29156 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
29157 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
29159 WTP=WTPU/(WTPU+WTNU)
29160 WTN=WTNU/(WTPU+WTNU)
29162 IF(WTN.GT.PYR(0)) EPS=-1D0
29164 C...Store result of variable choice and associated weights.
29174 IF(EPS.GT.0D0) THEN
29183 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
29184 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
29185 VINT(219)=0.5D0*(PMS12-PTS3)
29192 C***********************************************************************
29195 C...Differential matrix elements for all included subprocesses
29196 C...Note that what is coded is (disregarding the COMFAC factor)
29197 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
29198 C...when d(sigma-hat) is given in the zero-width limit, the delta
29199 C...function in tau is replaced by a (modified) Breit-Wigner:
29200 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
29201 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
29202 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
29203 C...i.e., dimensionless quantities
29204 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
29205 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
29206 C...(2pi)^4 delta^4(P - sum p_i)
29207 C...COMFAC contains the factor pi/s (or equivalent) and
29208 C...the conversion factor from GeV^-2 to mb
29210 SUBROUTINE PYSIGH(NCHN,SIGS)
29212 C...Double precision and integer declarations
29213 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29214 IMPLICIT INTEGER(I-N)
29215 INTEGER PYK,PYCHGE,PYCOMP
29216 C...Parameter statement to help give large particle numbers.
29217 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29218 &KEXCIT=4000000,KDIMEN=5000000)
29220 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
29221 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29222 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29223 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29224 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29225 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29226 COMMON/PYINT1/MINT(400),VINT(400)
29227 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29228 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29229 COMMON/PYINT4/MWID(500),WIDS(500,5)
29230 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
29231 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29232 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29233 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29234 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
29235 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
29236 COMMON/PYPUED/IUED(0:99),RUED(0:99)
29237 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29238 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29239 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29240 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29241 COMMON/PYTCCO/COEFX(194:380,2)
29242 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
29243 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
29244 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/
29245 C...Local arrays and complex variables
29246 DIMENSION XPQ(-25:25)
29248 C...Map of processes onto which routine to call
29249 C...in order to evaluate cross section:
29250 C...0 = not implemented;
29251 C...1 = standard QCD (including photons);
29252 C...2 = heavy flavours;
29254 C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
29256 C...6 = Technicolor;
29257 C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29258 C...8 = Universal Extra Dimensions
29259 DIMENSION MAPPR(500)
29260 DATA (MAPPR(I),I=1,180)/
29261 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
29262 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
29263 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
29264 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
29265 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29266 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
29267 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
29268 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
29269 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29270 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
29271 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
29272 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
29273 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
29274 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29275 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
29276 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
29277 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
29278 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
29279 DATA (MAPPR(I),I=181,500)/
29280 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
29281 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
29283 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29284 & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
29286 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
29287 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
29288 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
29289 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
29290 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
29291 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
29293 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29294 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29296 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29297 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29300 C...Reset number of channels and cross-section
29304 C...Read process to consider.
29309 C...Read kinematical variables and limits
29327 C...Derive kinematical quantities
29329 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
29330 X(1)=SQRT(TAUE)*EXP(YST)
29331 X(2)=SQRT(TAUE)*EXP(-YST)
29332 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
29333 IF(X(1).GT.1D0-1D-7) RETURN
29334 ELSEIF(MINT(45).EQ.3) THEN
29335 X(1)=MIN(1D0-1.1D-10,X(1))
29337 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
29338 IF(X(2).GT.1D0-1D-7) RETURN
29339 ELSEIF(MINT(46).EQ.3) THEN
29340 X(2)=MIN(1D0-1.1D-10,X(2))
29342 SH=MAX(1D0,TAU*VINT(2))
29347 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
29348 RPTS=4D0*VINT(71)**2/SH
29349 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
29350 RM34=MAX(1D-20,2D0*RM3*RM4)
29352 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
29353 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
29354 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
29355 IF(ISTSB.EQ.0) THEN
29357 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
29358 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
29360 C...Kinematics with incoming masses tricky: now depends on how
29361 C...subprocess has been set up w.r.t. order of incoming partons.
29363 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
29365 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
29366 IF(ISUB.EQ.35) THEN
29370 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
29371 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
29372 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
29374 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
29376 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
29383 C...Choice of Q2 scale for hard process (e.g. alpha_s).
29384 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
29386 ELSEIF(ISTSB.EQ.8) THEN
29387 IF(MINT(107).EQ.4) Q2=VINT(307)
29388 IF(MINT(108).EQ.4) Q2=VINT(308)
29389 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
29391 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
29393 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
29394 IF(MSTP(32).EQ.1) THEN
29395 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
29396 ELSEIF(MSTP(32).EQ.2) THEN
29397 Q2=SQPTH+0.5D0*(SQM3+SQM4)
29398 ELSEIF(MSTP(32).EQ.3) THEN
29400 ELSEIF(MSTP(32).EQ.4) THEN
29402 ELSEIF(MSTP(32).EQ.5) THEN
29404 ELSEIF(MSTP(32).EQ.6) THEN
29406 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
29408 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
29409 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
29410 & (SQPTH+0.5D0*(SQM3+SQM4))
29411 ELSEIF(MSTP(32).EQ.7) THEN
29412 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
29413 ELSEIF(MSTP(32).EQ.8) THEN
29414 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
29415 ELSEIF(MSTP(32).EQ.9) THEN
29416 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
29417 ELSEIF(MSTP(32).EQ.10) THEN
29420 ELSEIF(MSTP(32).EQ.11) THEN
29421 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
29422 ELSEIF(MSTP(32).EQ.12) THEN
29425 ELSEIF(MSTP(32).EQ.13) THEN
29428 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
29429 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
29430 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
29433 C...Choice of Q2 scale for parton densities.
29436 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
29437 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
29440 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29442 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
29443 & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
29444 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
29445 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
29446 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
29447 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
29448 IF(MSTP(39).EQ.2) Q2SF=
29449 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
29450 IF(MSTP(39).EQ.3) Q2SF=SH
29451 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
29452 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
29454 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
29455 IF(MSTP(39).EQ.7) Q2SF=
29456 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
29457 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
29461 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
29465 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
29466 IF(MSTP(69).GE.2) Q2SF=VINT(2)
29468 C...Identify to which class(es) subprocess belongs
29472 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
29473 & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
29474 & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
29475 & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
29476 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
29477 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
29478 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
29479 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
29480 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
29481 IF (ISTSB.EQ.9) ISQCD=1
29482 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
29483 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
29484 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
29485 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
29486 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
29487 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
29488 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
29489 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
29490 C...WBF is special case of ISJETS
29491 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
29492 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
29493 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
29494 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
29495 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
29496 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
29497 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
29498 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
29499 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
29500 C...Some processes with photons also belong here.
29501 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
29502 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
29503 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
29504 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
29505 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
29506 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
29508 C...Choice of Q2 scale for parton-shower activity.
29509 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
29510 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
29512 IF(MINT(43).EQ.3) XBJ=X(1)
29513 IF(MSTP(22).EQ.1) THEN
29515 ELSEIF(MSTP(22).EQ.2) THEN
29516 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
29517 ELSEIF(MSTP(22).EQ.3) THEN
29518 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
29520 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
29523 C...For multiple interactions, start from scale defined above
29524 C...For all other QCD or "+jets"-type events, start shower from pThard.
29525 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
29526 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
29527 C...Max shower scale = s for ME corrected processes.
29528 C...(pT-ordering: max pT2 is s/4)
29530 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
29531 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
29532 C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
29533 C...(pT-ordering: max pT2 is s/4)
29535 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
29537 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
29539 C...Elastic and diffractive events not associated with scales so set 0.
29540 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
29545 C...Store derived kinematical quantities
29552 IF(ISTSB.NE.8) VINT(48)=SQPTH
29553 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
29554 VINT(50)=TAUP*VINT(2)
29555 VINT(49)=SQRT(MAX(0D0,VINT(50)))
29559 VINT(53)=SQRT(Q2SF)
29561 VINT(55)=SQRT(Q2PS)
29563 C...Set starting scale for multiple interactions
29564 IF (ISUBSV.EQ.95) THEN
29566 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
29567 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
29568 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
29569 & ISUBSV.NE.96)) THEN
29570 C...All accessible phase space allowed.
29571 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
29573 C...Scale of hard process sets limit.
29574 C...2 -> 1. Limit is tau = x1*x2.
29575 C...2 -> 2. Limit is XT2 for hard process + FS masses.
29576 C...2 -> n > 2. Limit is tau' = tau of outer process.
29578 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
29580 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
29581 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
29583 VINT(62)=0.25D0*XT2GMX*VINT(2)
29584 VINT(61)=SQRT(MAX(0D0,VINT(62)))
29586 C...Calculate parton distributions
29587 IF(ISTSB.LE.0) GOTO 160
29588 IF(MINT(47).GE.2) THEN
29589 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
29591 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
29592 IF(ISUB.EQ.99) THEN
29593 IF(MINT(140+I).EQ.0) THEN
29594 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
29596 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
29601 MINT(105)=MINT(102+I)
29602 MINT(109)=MINT(106+I)
29603 VINT(120)=VINT(2+I)
29605 C.... Store side in MINT(124)
29608 IF(MSTP(57).LE.1) THEN
29609 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
29611 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
29613 C...Safety margin against heavy flavour very close to threshold,
29614 C...e.g. caused by mismatch in c and b masses.
29615 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
29619 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
29624 XSFX(I,KFL)=XPQ(KFL)
29629 C...Calculate alpha_em, alpha_strong and K-factor
29632 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
29633 &1D0-(PMAS(24,1)/PMAS(23,1))**2
29635 XWC=1D0/(16D0*XW*XW1)
29637 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
29638 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
29641 IF(MSTP(33).EQ.1) THEN
29643 ELSEIF(MSTP(33).EQ.2) THEN
29645 FACA=PARP(32)/PARP(31)
29646 ELSEIF(MSTP(33).EQ.3) THEN
29648 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
29649 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
29656 C...Set flags for allowed reacting partons/leptons
29661 IF(MINT(44+I).EQ.1) THEN
29662 KFAC(I,MINT(10+I))=1
29663 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
29664 KFAC(I,MINT(10+I))=1
29670 KFAC(I,J)=KFIN(I,J)
29671 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
29672 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
29677 C...Lower and upper limit for fermion flavour loops
29683 IF(KFAC(1,-J).EQ.1) MMIN1=-J
29684 IF(KFAC(1,J).EQ.1) MMAX1=J
29685 IF(KFAC(2,-J).EQ.1) MMIN2=-J
29686 IF(KFAC(2,J).EQ.1) MMAX2=J
29688 MMINA=MIN(MMIN1,MMIN2)
29689 MMAXA=MAX(MMAX1,MMAX2)
29691 C...Common resonance mass and width combinations
29694 GMMZ=PMAS(23,1)*PMAS(23,2)
29695 GMMW=PMAS(24,1)*PMAS(24,2)
29697 C...Polarization factors...implemented so far for W+W-(25)
29698 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
29699 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
29700 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
29701 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
29703 C...Phase space integral in tau
29704 COMFAC=PARU(1)*PARU(5)/VINT(2)
29705 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
29706 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
29707 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
29708 ATAU1=LOG(TAUMAX/TAUMIN)
29709 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
29710 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
29711 IF(MINT(72).GE.1) THEN
29714 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
29716 IF(ATAUD.GT.1D-10) H1=H1+
29717 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
29718 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
29720 IF(ATAUD.GT.1D-10) H1=H1+
29721 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
29723 IF(MINT(72).GE.2) THEN
29726 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
29728 IF(ATAUD.GT.1D-10) H1=H1+
29729 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
29730 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
29732 IF(ATAUD.GT.1D-10) H1=H1+
29733 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
29735 IF(MINT(72).EQ.3) THEN
29738 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
29740 IF(ATAUD.GT.1D-10) H1=H1+
29741 & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
29742 ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
29744 IF(ATAUD.GT.1D-10) H1=H1+
29745 & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
29747 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
29748 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
29749 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
29750 & MAX(2D-10,1D0-TAU)
29751 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
29752 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
29753 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
29754 & MAX(1D-10,1D0-TAU)
29756 COMFAC=COMFAC*ATAU1/(TAU*H1)
29759 C...Phase space integral in y*
29760 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
29762 AYST0=YSTMAX-YSTMIN
29763 IF(AYST0.LT.1D-10) THEN
29766 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29768 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29769 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29770 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29771 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29772 IF(MINT(45).EQ.3) THEN
29773 YST0=-0.5D0*LOG(TAUE)
29774 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
29775 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
29776 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
29777 & MAX(1D-10,1D0-EXP(YST-YST0))
29779 IF(MINT(46).EQ.3) THEN
29780 YST0=-0.5D0*LOG(TAUE)
29781 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
29782 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
29783 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
29784 & MAX(1D-10,1D0-EXP(-YST-YST0))
29786 COMFAC=COMFAC*AYST0/H2
29790 C...2 -> 1 processes: reduction in angular part of phase space integral
29791 C...for case of decaying resonance
29792 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
29793 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
29794 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
29795 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
29796 & KFPR(ISUB,1).EQ.39) THEN
29797 COMFAC=COMFAC*0.5D0*ACTH0
29799 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
29800 & CTPMAX**3-CTPMIN**3)
29804 C...2 -> 2 processes: angular part of phase space integral
29805 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
29806 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
29807 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
29808 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
29809 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
29810 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
29811 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
29812 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
29813 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
29814 H3=COEF(ISUBSV,13)+
29815 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
29816 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
29817 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
29818 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
29819 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
29821 C...2 -> 2 processes: take into account final state Breit-Wigners
29822 COMFAC=COMFAC*VINT(80)
29825 C...2 -> 3, 4 processes: phace space integral in tau'
29826 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29827 ATAUP1=LOG(TAUPMX/TAUPMN)
29828 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
29829 H4=COEF(ISUBSV,18)+
29830 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
29831 IF(MINT(47).EQ.5) THEN
29832 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
29833 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
29834 ELSEIF(MINT(47).GE.6) THEN
29835 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
29836 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
29838 COMFAC=COMFAC*ATAUP1/H4
29841 C...2 -> 3, 4 processes: effective W/Z parton distributions
29842 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
29843 IF(1D0-TAU/TAUP.GT.1D-4) THEN
29844 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
29846 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
29851 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
29852 IF(ISTSB.EQ.5) THEN
29853 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
29854 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
29857 C...Phase space integral for low-pT and multiple interactions
29858 IF(ISTSB.EQ.9) THEN
29859 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
29860 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
29861 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
29862 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
29863 COMFAC=COMFAC*ATAU1/H1
29864 AYST0=YSTMAX-YSTMIN
29865 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29866 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29867 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29868 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29869 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29870 COMFAC=COMFAC*AYST0/H2
29871 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
29872 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
29873 C...introduced to make cross-section finite for xT2 -> 0
29874 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
29878 C...Real gamma + gamma: include factor 2 when different nature
29879 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
29880 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
29882 C...Extra factors to include the effects of
29883 C...longitudinal resolved photons (but not direct or DIS ones).
29885 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
29886 & MINT(106+ISDE).LE.3) THEN
29889 IF(MSTP(16).EQ.0) THEN
29890 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
29891 & XY=VINT(304+ISDE)
29893 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
29894 & XY=VINT(308+ISDE)
29896 Q2GA=VINT(306+ISDE)
29897 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
29898 & Q2GA.GT.0D0) THEN
29900 IF(MSTP(17).EQ.1) THEN
29901 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
29902 ELSEIF(MSTP(17).EQ.2) THEN
29903 REDUCE=4D0*Q2GA/(Q2+Q2GA)
29904 ELSEIF(MSTP(17).EQ.3) THEN
29905 PMVIRT=PMAS(PYCOMP(113),1)
29906 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29907 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
29908 PMVIRT=PMAS(PYCOMP(113),1)
29909 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29910 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
29911 PMVIRT=PMAS(PYCOMP(113),1)
29912 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29913 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
29914 PMVSMN=4D0*PARP(15)**2
29915 PMVSMX=4D0*VINT(154)**2
29916 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29917 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
29918 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
29919 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
29920 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
29921 PMVIRT=PMAS(PYCOMP(113),1)
29922 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29923 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
29924 PMVIRT=PMAS(PYCOMP(113),1)
29925 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29926 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
29927 PMVSMN=4D0*PARP(15)**2
29928 PMVSMX=4D0*VINT(154)**2
29929 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29930 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
29931 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
29934 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
29935 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
29936 & (1D0-2D0*BEAMAS**2/Q2GA))
29937 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
29942 COMFAC=COMFAC*VINT(314+ISDE)
29945 C...Evaluate cross sections - done in separate routines by kind
29946 C...of physics, to keep PYSIGH of sensible size.
29948 C...Standard QCD (including photons).
29949 CALL PYSGQC(NCHN,SIGS)
29950 ELSEIF(MAP.EQ.2) THEN
29951 C...Heavy flavours.
29952 CALL PYSGHF(NCHN,SIGS)
29953 ELSEIF(MAP.EQ.3) THEN
29955 CALL PYSGWZ(NCHN,SIGS)
29956 ELSEIF(MAP.EQ.4) THEN
29957 C...Higgs (2 doublets; including longitudinal W/Z scattering).
29958 CALL PYSGHG(NCHN,SIGS)
29959 ELSEIF(MAP.EQ.5) THEN
29961 CALL PYSGSU(NCHN,SIGS)
29962 ELSEIF(MAP.EQ.6) THEN
29964 CALL PYSGTC(NCHN,SIGS)
29965 ELSEIF(MAP.EQ.7) THEN
29966 C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29967 CALL PYSGEX(NCHN,SIGS)
29968 ELSEIF(MAP.EQ.8) THEN
29969 C... Universal Extra Dimensions
29970 CALL PYXUED(NCHN,SIGS)
29973 C...Multiply with parton distributions
29974 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
29976 IF(MINT(45).GE.2) THEN
29978 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
29980 IF(MINT(46).GE.2) THEN
29982 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
29984 SIGS=SIGS+SIGH(ICHN)
29991 C*********************************************************************
29994 C...Subprocess cross sections for QCD processes,
29995 C...including photons.
29996 C...Auxiliary to PYSIGH.
29998 SUBROUTINE PYSGQC(NCHN,SIGS)
30000 C...Double precision and integer declarations
30001 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30002 IMPLICIT INTEGER(I-N)
30003 INTEGER PYK,PYCHGE,PYCOMP
30004 C...Parameter statement to help give large particle numbers.
30005 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30006 &KEXCIT=4000000,KDIMEN=5000000)
30008 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30009 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30010 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
30011 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30012 COMMON/PYINT1/MINT(400),VINT(400)
30013 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30014 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30015 COMMON/PYINT4/MWID(500),WIDS(500,5)
30016 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
30017 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30018 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30019 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30020 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30021 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
30022 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
30024 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30026 C...Differential cross section expressions.
30028 IF(ISUB.LE.20) THEN
30029 IF(ISUB.EQ.10) THEN
30030 C...f + f' -> f + f' (gamma/Z/W exchange)
30031 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
30032 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
30033 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
30034 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
30035 DO 110 I=MMIN1,MMAX1
30036 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
30038 DO 100 J=MMIN2,MMAX2
30039 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
30041 C...Electroweak couplings
30042 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
30043 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
30045 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
30046 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
30049 C...gamma/Z exchange, only gamma exchange, or only Z exchange
30050 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
30051 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
30052 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
30053 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
30054 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
30055 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30056 ELSEIF(MSTP(21).EQ.2) THEN
30057 FACNCF=FACGGF*EI**2*EJ**2
30059 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
30060 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30062 C...Extrafactor 2 for only one incoming neutrino spin state.
30063 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
30064 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
30072 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
30073 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
30074 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
30075 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
30076 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
30086 ELSEIF(ISUB.EQ.11) THEN
30087 C...f + f' -> f + f' (g exchange)
30088 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30089 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30090 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30091 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
30092 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
30093 DO 130 I=MMIN1,MMAX1
30095 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
30096 DO 120 J=MMIN2,MMAX2
30098 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
30104 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30106 SIGH(NCHN)=0.5D0*SIGH(NCHN)
30111 SIGH(NCHN)=0.5D0*FACQQ2
30116 ELSEIF(ISUB.EQ.12) THEN
30117 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
30118 CALL PYWIDT(21,SH,WDTP,WDTE)
30119 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30120 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
30121 DO 140 I=MMINA,MMAXA
30122 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30123 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
30131 ELSEIF(ISUB.EQ.13) THEN
30132 C...f + fbar -> g + g (q + qbar -> g + g only)
30133 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30135 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30137 DO 150 I=MMINA,MMAXA
30138 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30139 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
30144 SIGH(NCHN)=0.5D0*FACGG1
30149 SIGH(NCHN)=0.5D0*FACGG2
30152 ELSEIF(ISUB.EQ.14) THEN
30153 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
30154 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
30155 DO 160 I=MMINA,MMAXA
30156 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30157 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
30158 EI=KCHG(IABS(I),1)/3D0
30163 SIGH(NCHN)=FACGG*EI**2
30166 ELSEIF(ISUB.EQ.18) THEN
30167 C...f + fbar -> gamma + gamma
30168 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
30169 DO 170 I=MMINA,MMAXA
30170 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
30171 EI=KCHG(IABS(I),1)/3D0
30173 IF(IABS(I).LE.10) FCOI=FACA/3D0
30178 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
30182 ELSEIF(ISUB.LE.40) THEN
30183 IF(ISUB.EQ.28) THEN
30184 C...f + g -> f + g (q + g -> q + g only)
30185 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30187 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30189 DO 190 I=MMINA,MMAXA
30190 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
30192 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
30193 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
30196 ISIG(NCHN,3-ISDE)=21
30201 ISIG(NCHN,3-ISDE)=21
30207 ELSEIF(ISUB.EQ.29) THEN
30208 C...f + g -> f + gamma (q + g -> q + gamma only)
30209 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
30210 DO 210 I=MMINA,MMAXA
30211 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
30212 EI=KCHG(IABS(I),1)/3D0
30215 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
30216 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
30219 ISIG(NCHN,3-ISDE)=21
30225 ELSEIF(ISUB.EQ.33) THEN
30226 C...f + gamma -> f + g (q + gamma -> q + g only)
30227 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
30228 DO 230 I=MMINA,MMAXA
30229 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
30230 EI=KCHG(IABS(I),1)/3D0
30233 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
30234 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
30237 ISIG(NCHN,3-ISDE)=22
30243 ELSEIF(ISUB.EQ.34) THEN
30244 C...f + gamma -> f + gamma
30245 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
30246 DO 250 I=MMINA,MMAXA
30247 IF(I.EQ.0) GOTO 250
30248 EI=KCHG(IABS(I),1)/3D0
30251 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
30252 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
30255 ISIG(NCHN,3-ISDE)=22
30262 ELSEIF(ISUB.LE.80) THEN
30263 IF(ISUB.EQ.53) THEN
30264 C...g + g -> f + fbar (g + g -> q + qbar only)
30265 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
30267 C...Begin by d, u, s flavours.
30269 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30270 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30271 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30272 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30273 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30274 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30275 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30276 & UH2/SH2)*FLAVWT*FACA
30277 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30278 & TH2/SH2)*FLAVWT*FACA
30289 C...Next c and b flavours: modified that and uhat for fixed
30290 C...cos(theta-hat).
30292 SQMAVG=PMAS(IFL,1)**2
30293 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30294 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30295 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30296 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30297 THUHQ=THQ*UHQ-SQMAVG*SH
30298 IF(MSTP(34).EQ.0) THEN
30299 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30300 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30302 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30303 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30304 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30305 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30307 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30308 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30312 ISIG(NCHN,3)=1+2*(IFL-3)
30317 ISIG(NCHN,3)=2+2*(IFL-3)
30323 ELSEIF(ISUB.EQ.54) THEN
30324 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
30325 CALL PYWIDT(21,SH,WDTP,WDTE)
30327 DO 280 I=1,MIN(8,MDCY(21,3))
30329 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30332 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
30333 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30340 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30348 ELSEIF(ISUB.EQ.58) THEN
30349 C...gamma + gamma -> f + fbar
30350 CALL PYWIDT(22,SH,WDTP,WDTE)
30352 DO 290 I=1,MIN(12,MDCY(22,3))
30353 IF(I.LE.8) EF= KCHG(I,1)/3D0
30354 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30355 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30358 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
30359 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30367 ELSEIF(ISUB.EQ.68) THEN
30369 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
30370 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
30372 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
30374 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
30380 SIGH(NCHN)=0.5D0*FACGG1
30385 SIGH(NCHN)=0.5D0*FACGG2
30390 SIGH(NCHN)=0.5D0*FACGG3
30393 ELSEIF(ISUB.EQ.80) THEN
30394 C...q + gamma -> q' + pi+/-
30395 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
30396 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
30397 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
30398 DELSH=UH*SQRT(ASSH*Q2FPSH)
30399 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
30400 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
30401 DELUH=SH*SQRT(ASUH*Q2FPUH)
30402 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
30403 IF(I.EQ.0) GOTO 320
30404 EI=KCHG(IABS(I),1)/3D0
30405 EJ=SIGN(1D0-ABS(EI),EI)
30407 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
30408 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
30411 ISIG(NCHN,3-ISDE)=22
30413 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
30418 ELSEIF(ISUB.LE.100) THEN
30419 IF(ISUB.EQ.91) THEN
30420 C...Elastic scattering
30421 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
30423 ELSEIF(ISUB.EQ.92) THEN
30424 C...Single diffractive scattering (first side, i.e. XB)
30425 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
30427 ELSEIF(ISUB.EQ.93) THEN
30428 C...Single diffractive scattering (second side, i.e. AX)
30429 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
30431 ELSEIF(ISUB.EQ.94) THEN
30432 C...Double diffractive scattering
30433 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
30435 ELSEIF(ISUB.EQ.95) THEN
30436 C...Low-pT scattering
30437 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
30439 ELSEIF(ISUB.EQ.96) THEN
30440 C...Multiple interactions: sum of QCD processes
30441 CALL PYWIDT(21,SH,WDTP,WDTE)
30443 C...q + q' -> q + q'
30444 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30445 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30446 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30447 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
30448 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
30449 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
30451 IF(I.EQ.0) GOTO 340
30453 IF(J.EQ.0) GOTO 330
30459 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30461 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
30466 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
30471 C...q + qbar -> q' + qbar' or g + g
30472 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30473 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
30474 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30476 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30479 IF(I.EQ.0) GOTO 350
30489 SIGH(NCHN)=0.5D0*FACGG1
30494 SIGH(NCHN)=0.5D0*FACGG2
30498 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30500 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30503 IF(I.EQ.0) GOTO 370
30507 ISIG(NCHN,3-ISDE)=21
30512 ISIG(NCHN,3-ISDE)=21
30518 C...g + g -> q + qbar (only d, u, s)
30521 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30522 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30523 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30524 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30525 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30526 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30527 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30528 & UH2/SH2)*FLAVWT*FACA
30529 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30530 & TH2/SH2)*FLAVWT*FACA
30542 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
30545 SQMAVG=PMAS(IFL,1)**2
30546 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30547 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30548 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30549 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30550 THUHQ=THQ*UHQ-SQMAVG*SH
30551 IF(MSTP(34).EQ.0) THEN
30552 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30553 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30555 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30556 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30557 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30558 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30560 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30561 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30565 ISIG(NCHN,3)=531+2*(IFL-3)
30570 ISIG(NCHN,3)=532+2*(IFL-3)
30576 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
30577 & 2D0*TH/SH+TH2/SH2)*FACA
30578 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
30579 & 2D0*SH/UH+SH2/UH2)*FACA
30580 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
30581 & 2D0*UH/TH+UH2/TH2)
30586 SIGH(NCHN)=0.5D0*FACGG1
30591 SIGH(NCHN)=0.5D0*FACGG2
30596 SIGH(NCHN)=0.5D0*FACGG3
30598 ELSEIF(ISUB.EQ.99) THEN
30599 C...f + gamma* -> f.
30600 IF(MINT(107).EQ.4) THEN
30609 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
30610 PM2RHO=PMAS(PYCOMP(113),1)**2
30611 IF(MSTP(19).EQ.0) THEN
30613 ELSEIF(MSTP(19).EQ.1) THEN
30614 COMFAC=COMFAC/(Q2GA+PM2RHO)
30615 ELSEIF(MSTP(19).EQ.2) THEN
30616 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
30618 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
30620 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
30621 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
30622 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
30623 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
30625 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
30627 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
30629 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
30630 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
30632 DO 390 I=MMINA,MMAXA
30633 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
30634 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
30635 EI=KCHG(IABS(I),1)/3D0
30638 ISIG(NCHN,3-ISDE)=22
30640 SIGH(NCHN)=COMFAC*EI**2
30645 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
30646 C...g + g -> gamma + gamma or g + g -> g + gamma
30661 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
30663 EI=KCHG(IABS(I),1)/3D0
30665 IF(ISUB.EQ.115) EIWT=EI
30670 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
30671 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
30674 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
30675 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
30676 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
30677 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
30683 CALL PYWAUX(1,EPSS,W1SR,W1SI)
30684 CALL PYWAUX(1,EPST,W1TR,W1TI)
30685 CALL PYWAUX(1,EPSU,W1UR,W1UI)
30686 CALL PYWAUX(2,EPSS,W2SR,W2SI)
30687 CALL PYWAUX(2,EPST,W2TR,W2TI)
30688 CALL PYWAUX(2,EPSU,W2UR,W2UI)
30689 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
30690 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
30691 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
30692 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
30693 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
30694 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
30695 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
30696 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
30697 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
30698 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
30699 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
30700 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
30701 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
30702 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
30703 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
30704 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
30705 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
30706 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
30707 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
30708 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
30709 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
30710 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
30711 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
30712 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
30713 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
30714 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
30715 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
30716 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
30717 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
30718 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
30719 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
30720 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
30721 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
30722 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
30723 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
30724 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
30725 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
30726 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
30727 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
30728 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
30729 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
30730 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
30731 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
30732 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
30733 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
30734 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
30735 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
30736 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
30737 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
30738 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
30739 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
30740 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
30741 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
30742 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
30743 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
30744 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
30746 A0STUR=A0STUR+EIWT*B0STUR
30747 A0STUI=A0STUI+EIWT*B0STUI
30748 A0TSUR=A0TSUR+EIWT*B0TSUR
30749 A0TSUI=A0TSUI+EIWT*B0TSUI
30750 A0UTSR=A0UTSR+EIWT*B0UTSR
30751 A0UTSI=A0UTSI+EIWT*B0UTSI
30752 A1STUR=A1STUR+EIWT*B1STUR
30753 A1STUI=A1STUI+EIWT*B1STUI
30754 A2STUR=A2STUR+EIWT*B2STUR
30755 A2STUI=A2STUI+EIWT*B2STUI
30757 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
30758 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
30759 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
30760 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
30761 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
30766 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
30767 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
30770 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
30771 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
30773 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30775 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30777 IF(ISUB.EQ.131) THEN
30778 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
30779 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
30781 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
30783 DO 430 I=MMINA,MMAXA
30784 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
30785 EI=KCHG(IABS(I),1)/3D0
30788 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
30789 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
30792 ISIG(NCHN,3-ISDE)=22
30798 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
30799 C...f + gamma*_(T,L) -> f + gamma
30801 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30803 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30805 IF(ISUB.EQ.133) THEN
30806 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
30807 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
30809 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
30811 DO 450 I=MMINA,MMAXA
30812 IF(I.EQ.0) GOTO 450
30813 EI=KCHG(IABS(I),1)/3D0
30816 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
30817 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
30820 ISIG(NCHN,3-ISDE)=22
30826 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
30827 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
30829 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30831 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30833 CALL PYWIDT(21,SH,WDTP,WDTE)
30835 DO 460 I=1,MIN(8,MDCY(21,3))
30837 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30840 IF(ISUB.EQ.135) THEN
30841 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
30842 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
30844 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
30846 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30853 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30861 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
30862 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
30864 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
30866 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
30867 CALL PYWIDT(22,SH,WDTP,WDTE)
30869 DO 470 I=1,MIN(12,MDCY(22,3))
30870 IF(I.LE.8) EF= KCHG(I,1)/3D0
30871 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30872 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30875 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
30876 IF(ISUB.EQ.137) THEN
30877 FPARAM=-SH*(TH+UH)/DLAMB2
30878 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
30879 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
30880 & 2D0*PH1*PH2*FPARAM**2)
30881 ELSEIF(ISUB.EQ.138) THEN
30882 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30883 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
30884 & 2D0*PH1**2*(TH-UH)**2)
30885 ELSEIF(ISUB.EQ.139) THEN
30886 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30887 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
30888 & 2D0*PH2**2*(TH-UH)**2)
30890 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
30891 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
30893 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30907 C*********************************************************************
30910 C...Subprocess cross sections for heavy flavour production,
30911 C...open and closed.
30912 C...Auxiliary to PYSIGH.
30914 SUBROUTINE PYSGHF(NCHN,SIGS)
30916 C...Double precision and integer declarations
30917 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30918 IMPLICIT INTEGER(I-N)
30919 INTEGER PYK,PYCHGE,PYCOMP
30920 C...Parameter statement to help give large particle numbers.
30921 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30922 &KEXCIT=4000000,KDIMEN=5000000)
30924 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30925 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30926 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30927 COMMON/PYINT1/MINT(400),VINT(400)
30928 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30929 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30930 COMMON/PYINT4/MWID(500),WIDS(500,5)
30931 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30932 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30933 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30934 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30935 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
30938 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30940 C...Determine where are charmonium/bottomonium wave function parameters.
30942 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
30944 C...Convert bottomonium process into equivalent charmonium ones.
30945 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
30947 C...Differential cross section expressions.
30949 IF(ISUB.LE.100) THEN
30950 IF(ISUB.EQ.81) THEN
30951 C...q + qbar -> Q + Qbar
30952 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30953 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30954 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30955 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
30957 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
30959 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30960 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30962 DO 100 I=MMINA,MMAXA
30963 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30964 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
30972 ELSEIF(ISUB.EQ.82) THEN
30973 C...g + g -> Q + Qbar
30974 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30975 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30976 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30977 THUHQ=THQ*UHQ-SQMAVG*SH
30978 IF(MSTP(34).EQ.0) THEN
30979 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30980 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30982 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30983 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30984 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30985 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30987 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
30988 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
30989 IF(MSTP(35).GE.1) THEN
30990 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
30991 FACQQ1=FACQQ1*FATRE
30992 FACQQ2=FACQQ2*FATRE
30995 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30996 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30999 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
31012 ELSEIF(ISUB.EQ.83) THEN
31013 C...f + q -> f' + Q
31014 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
31015 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
31016 DO 130 I=MMIN1,MMAX1
31017 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
31018 DO 120 J=MMIN2,MMAX2
31019 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
31020 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
31021 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
31022 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
31028 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31029 & (IABS(I)+1)/2)*VINT(180+J)
31030 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
31031 & (MINT(55)+1)/2)*VINT(180+J)
31034 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31035 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31038 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31039 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31042 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31043 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31045 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
31051 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31052 & (IABS(J)+1)/2)*VINT(180+I)
31053 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
31054 & (MINT(55)+1)/2)*VINT(180+I)
31057 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31058 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31061 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31062 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31065 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31066 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31071 ELSEIF(ISUB.EQ.84) THEN
31072 C...g + gamma -> Q + Qbar
31073 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31074 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31075 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31076 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
31077 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
31079 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
31081 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31082 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31084 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31091 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31099 ELSEIF(ISUB.EQ.85) THEN
31100 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
31101 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31102 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31103 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31104 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
31105 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
31106 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
31107 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
31108 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
31109 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
31110 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
31112 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
31113 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
31114 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
31116 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31124 ELSEIF(ISUB.EQ.86) THEN
31125 C...g + g -> J/Psi + g
31126 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
31127 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31128 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31129 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31137 ELSEIF(ISUB.EQ.87) THEN
31138 C...g + g -> chi_0c + g
31139 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31140 QGTW=(SH*TH*UH)/SH**3
31142 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31143 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31144 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
31145 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
31146 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
31147 & (QGTW*(QGTW-RGTW*PGTW)**4)
31148 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31156 ELSEIF(ISUB.EQ.88) THEN
31157 C...g + g -> chi_1c + g
31158 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31159 QGTW=(SH*TH*UH)/SH**3
31161 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31162 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
31163 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
31164 & (QGTW-RGTW*PGTW)**4
31165 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31173 ELSEIF(ISUB.EQ.89) THEN
31174 C...g + g -> chi_2c + g
31175 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31176 QGTW=(SH*TH*UH)/SH**3
31178 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31179 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31180 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
31181 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
31182 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
31183 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31184 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31193 ELSEIF(ISUB.LE.200) THEN
31194 IF(ISUB.EQ.104) THEN
31195 C...g + g -> chi_c0.
31197 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
31198 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31199 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31200 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31208 ELSEIF(ISUB.EQ.105) THEN
31209 C...g + g -> chi_c2.
31211 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
31212 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31213 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31214 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31222 ELSEIF(ISUB.EQ.106) THEN
31223 C...g + g -> J/Psi + gamma.
31224 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31225 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
31226 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31227 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31228 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31236 ELSEIF(ISUB.EQ.107) THEN
31237 C...g + gamma -> J/Psi + g.
31238 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31239 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
31240 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31241 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31242 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31249 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31257 ELSEIF(ISUB.EQ.108) THEN
31258 C...gamma + gamma -> J/Psi + gamma.
31259 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31260 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
31261 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31262 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31263 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31273 C...Additional code by Stefan Wolf
31276 C...Common code for quarkonium production.
31283 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
31284 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
31286 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
31287 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
31291 IF(MSTP(145).EQ.1) THEN
31292 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
31293 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
31294 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
31295 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
31296 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31297 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31298 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31299 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31300 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
31301 & ISUB.GE.437) THEN
31302 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
31303 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
31304 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31305 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31306 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31307 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31311 SMQQ2=SQMQQ*VINT(2)
31312 C...Polarisation frames
31313 IF(MSTP(146).EQ.1) THEN
31315 POLH1=SQRT(AQ2-SMQQ2)
31316 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31319 AX=AQ*BQ/(POLH1*POLH2)
31321 ELSEIF(MSTP(146).EQ.2) THEN
31322 C...Gottfried Jackson frame
31324 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31327 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
31328 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
31329 ELSEIF(MSTP(146).EQ.3) THEN
31332 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31335 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
31336 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
31337 ELSEIF(MSTP(146).EQ.4) THEN
31338 C...Collins Soper frame
31340 POLH2=SQRT(VINT(2)*POLH1)
31343 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
31344 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
31346 C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
31347 EL1K10=AZ*ATILK1+BZ*BTILK1
31348 EL1K20=AZ*ATILK2+BZ*BTILK2
31351 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
31352 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
31357 IF(ISUB.EQ.421) THEN
31358 C...g + g -> QQ~[3S11] + g
31359 IF(MSTP(145).EQ.0) THEN
31360 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31361 * & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
31362 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31363 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
31364 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31365 * & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
31367 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
31368 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
31372 IF(MSTP(147).EQ.0) THEN
31373 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31374 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31375 ELSEIF(MSTP(147).EQ.1) THEN
31376 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31377 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31378 ELSEIF(MSTP(147).EQ.3) THEN
31379 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31380 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31381 ELSEIF(MSTP(147).EQ.4) THEN
31382 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31383 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31384 ELSEIF(MSTP(147).EQ.5) THEN
31385 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31386 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31387 ELSEIF(MSTP(147).EQ.6) THEN
31388 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31389 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31391 FACQQG=COMFAC*FF*FACQQG
31393 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31398 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
31401 ELSEIF(ISUB.EQ.422) THEN
31402 C...g + g -> QQ~[3S18] + g
31403 IF(MSTP(145).EQ.0) THEN
31404 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
31405 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
31407 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
31409 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
31410 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
31411 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
31415 IF(MSTP(147).EQ.0) THEN
31416 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31417 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31418 ELSEIF(MSTP(147).EQ.1) THEN
31419 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31420 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31421 ELSEIF(MSTP(147).EQ.3) THEN
31422 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31423 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31424 ELSEIF(MSTP(147).EQ.4) THEN
31425 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31426 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31427 ELSEIF(MSTP(147).EQ.5) THEN
31428 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31429 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31430 ELSEIF(MSTP(147).EQ.6) THEN
31431 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31432 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31434 FACQQG=COMFAC*FF*FACQQG
31436 C...Split total contribution into different colour flows just like
31437 C...in g g -> g g (recalculate kinematics for massless partons).
31438 THP=-0.5D0*SH*(1D0-CTH)
31439 UHP=-0.5D0*SH*(1D0+CTH)
31440 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31441 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31442 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31443 FACGGS=FACGG1+FACGG2+FACGG3
31444 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31449 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31454 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31459 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
31462 ELSEIF(ISUB.EQ.423) THEN
31463 C...g + g -> QQ~[1S08] + g
31464 IF(MSTP(145).EQ.0) THEN
31465 * FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
31466 * & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
31467 * & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
31468 * & (SHTH2*THUH2*UHSH2)
31469 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
31470 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
31471 & TH2/(SHTH2*THUH2))*
31472 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
31474 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
31475 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
31476 & TH2/(SHTH2*THUH2))*
31477 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
31478 IF(MSTP(147).EQ.0) THEN
31480 ELSEIF(MSTP(147).EQ.1) THEN
31481 FACQQG=COMFAC*2D0*FA
31482 ELSEIF(MSTP(147).EQ.3) THEN
31484 ELSEIF(MSTP(147).EQ.4) THEN
31486 ELSEIF(MSTP(147).EQ.5) THEN
31488 ELSEIF(MSTP(147).EQ.6) THEN
31492 C...Split total contribution into different colour flows just like
31493 C...in g g -> g g (recalculate kinematics for massless partons).
31494 THP=-0.5D0*SH*(1D0-CTH)
31495 UHP=-0.5D0*SH*(1D0+CTH)
31496 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31497 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31498 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31499 FACGGS=FACGG1+FACGG2+FACGG3
31500 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31505 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31510 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31515 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
31518 ELSEIF(ISUB.EQ.424) THEN
31519 C...g + g -> QQ~[3PJ8] + g
31521 IF(MSTP(145).EQ.0) THEN
31522 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
31523 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
31524 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
31526 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
31527 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
31528 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
31530 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
31531 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
31532 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
31534 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
31535 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
31536 & +451D0*SH*TH**5+126D0*TH**6)
31537 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
31538 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
31539 & +171D0*SH*TH**5+42D0*TH**6)
31540 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
31541 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
31542 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
31543 & +99D0*SH*TH**3+35D0*TH**4)
31544 & +7D0*SQMQQ**8*SHTH*POLY)/
31545 & (SH*TH*UH*SQMQQR*SQMQQ*
31546 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
31548 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
31549 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
31550 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
31551 & -SQMQQ*SHTH2*POLY**2*
31552 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
31553 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
31554 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
31555 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
31556 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
31557 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
31558 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
31559 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
31560 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
31561 & +145D0*SH*TH**5+34D0*TH**6)
31562 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
31563 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
31565 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
31566 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
31567 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
31568 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
31569 & +3D0*SQMQQ**8*SHTH*POLY)
31570 BB=4D0*SHTH2*POLY**3
31571 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
31572 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
31573 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
31574 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
31575 & +84D0*SH*TH**9+20D0*TH**10)
31576 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
31577 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
31578 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
31580 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
31581 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
31582 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
31584 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
31585 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
31586 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
31587 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
31588 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
31590 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
31591 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
31592 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
31594 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
31595 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
31596 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
31597 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
31599 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
31600 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
31601 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
31602 & +394D0*SH*TH**9+84D0*TH**10)
31603 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
31604 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
31605 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
31606 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
31607 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
31608 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
31609 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
31610 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
31611 & +266D0*SH*TH**6+84D0*TH**7)
31612 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
31613 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
31615 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
31616 & +7D0*SH*TH**3+4*TH**4)
31617 & +SQMQQ**8*SH*(SH-TH)**2*TH
31618 DD=2D0*TH2*SHTH2*POLY**3
31619 & *(-SH2+2*SH*TH+2*TH2)
31620 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
31621 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
31622 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
31623 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
31624 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
31625 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
31626 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
31627 & -210D0*SH*TH**8-60D0*TH**9)
31628 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
31629 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
31630 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
31632 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
31633 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
31634 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
31635 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
31636 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
31637 & -30D0*SH*TH**6-24D0*TH**7)
31638 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
31639 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
31641 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
31642 IF(MSTP(147).EQ.0) THEN
31643 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31644 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31645 ELSEIF(MSTP(147).EQ.1) THEN
31646 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31647 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31648 ELSEIF(MSTP(147).EQ.3) THEN
31649 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31650 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31651 ELSEIF(MSTP(147).EQ.4) THEN
31652 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31653 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31654 ELSEIF(MSTP(147).EQ.5) THEN
31655 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31656 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31657 ELSEIF(MSTP(147).EQ.6) THEN
31658 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31659 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31661 FACQQG=COMFAC*FF*FACQQG
31663 C...Split total contribution into different colour flows just like
31664 C...in g g -> g g (recalculate kinematics for massless partons).
31665 THP=-0.5D0*SH*(1D0-CTH)
31666 UHP=-0.5D0*SH*(1D0+CTH)
31667 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31668 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31669 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31670 FACGGS=FACGG1+FACGG2+FACGG3
31671 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31676 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
31681 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
31686 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
31689 ELSEIF(ISUB.EQ.425) THEN
31690 C...q + g -> q + QQ~[3S18]
31691 IF(MSTP(145).EQ.0) THEN
31692 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
31693 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
31694 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
31696 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
31697 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
31702 IF(MSTP(147).EQ.0) THEN
31703 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31704 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31705 ELSEIF(MSTP(147).EQ.1) THEN
31706 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31707 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31708 ELSEIF(MSTP(147).EQ.3) THEN
31709 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31710 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31711 ELSEIF(MSTP(147).EQ.4) THEN
31712 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31713 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31714 ELSEIF(MSTP(147).EQ.5) THEN
31715 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31716 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31717 ELSEIF(MSTP(147).EQ.6) THEN
31718 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31719 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31721 FACQQG=COMFAC*FF*FACQQG
31723 C...Split total contribution into different colour flows just like
31724 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31725 C...(recalculate kinematics for massless partons).
31726 THP=-0.5D0*SH*(1D0-CTH)
31727 UHP=-0.5D0*SH*(1D0+CTH)
31728 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31729 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31730 FACQGS=FACQG1+FACQG2
31731 DO 2442 I=MMINA,MMAXA
31732 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
31734 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
31735 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
31738 ISIG(NCHN,3-ISDE)=21
31740 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
31743 ISIG(NCHN,3-ISDE)=21
31745 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
31749 ELSEIF(ISUB.EQ.426) THEN
31750 C...q + g -> q + QQ~[1S08]
31751 IF(MSTP(145).EQ.0) THEN
31752 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
31753 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
31755 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
31756 IF(MSTP(147).EQ.0) THEN
31758 ELSEIF(MSTP(147).EQ.1) THEN
31759 FACQQG=COMFAC*2D0*FA
31760 ELSEIF(MSTP(147).EQ.3) THEN
31762 ELSEIF(MSTP(147).EQ.4) THEN
31764 ELSEIF(MSTP(147).EQ.5) THEN
31766 ELSEIF(MSTP(147).EQ.6) THEN
31770 C...Split total contribution into different colour flows just like
31771 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31772 C...(recalculate kinematics for massless partons).
31773 THP=-0.5D0*SH*(1D0-CTH)
31774 UHP=-0.5D0*SH*(1D0+CTH)
31775 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31776 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31777 FACQGS=FACQG1+FACQG2
31778 DO 2444 I=MMINA,MMAXA
31779 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
31781 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
31782 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
31785 ISIG(NCHN,3-ISDE)=21
31787 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
31790 ISIG(NCHN,3-ISDE)=21
31792 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
31796 ELSEIF(ISUB.EQ.427) THEN
31797 C...q + g -> q + QQ~[3PJ8]
31798 IF(MSTP(145).EQ.0) THEN
31799 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
31800 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
31801 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
31802 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
31804 FF=10D0*PARU(1)*AS**3/
31805 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
31806 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
31807 BB=8D0*(SHTH2+TH*UH)
31808 CC=8D0*UHSH*(SHTH+THUH)
31809 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
31810 IF(MSTP(147).EQ.0) THEN
31811 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31812 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31813 ELSEIF(MSTP(147).EQ.1) THEN
31814 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31815 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31816 ELSEIF(MSTP(147).EQ.3) THEN
31817 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31818 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31819 ELSEIF(MSTP(147).EQ.4) THEN
31820 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31821 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31822 ELSEIF(MSTP(147).EQ.5) THEN
31823 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31824 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31825 ELSEIF(MSTP(147).EQ.6) THEN
31826 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31827 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31829 FACQQG=COMFAC*FF*FACQQG
31831 C...Split total contribution into different colour flows just like
31832 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31833 C...(recalculate kinematics for massless partons).
31834 THP=-0.5D0*SH*(1D0-CTH)
31835 UHP=-0.5D0*SH*(1D0+CTH)
31836 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31837 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31838 FACQGS=FACQG1+FACQG2
31839 DO 2446 I=MMINA,MMAXA
31840 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
31842 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
31843 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
31846 ISIG(NCHN,3-ISDE)=21
31848 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
31851 ISIG(NCHN,3-ISDE)=21
31853 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
31857 ELSEIF(ISUB.EQ.428) THEN
31858 C...q + q~ -> g + QQ~[3S18]
31859 IF(MSTP(145).EQ.0) THEN
31860 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
31861 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
31862 & (SQMQQ*SQMQQR*TH*UH*THUH2)
31864 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
31865 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
31870 IF(MSTP(147).EQ.0) THEN
31871 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31872 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31873 ELSEIF(MSTP(147).EQ.1) THEN
31874 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31875 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31876 ELSEIF(MSTP(147).EQ.3) THEN
31877 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31878 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31879 ELSEIF(MSTP(147).EQ.4) THEN
31880 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31881 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31882 ELSEIF(MSTP(147).EQ.5) THEN
31883 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31884 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31885 ELSEIF(MSTP(147).EQ.6) THEN
31886 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31887 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31889 FACQQG=COMFAC*FF*FACQQG
31891 C...Split total contribution into different colour flows just like
31892 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31893 C...(recalculate kinematics for massless partons).
31894 THP=-0.5D0*SH*(1D0-CTH)
31895 UHP=-0.5D0*SH*(1D0+CTH)
31896 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31897 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31898 FACGGS=FACGG1+FACGG2
31899 DO 2447 I=MMINA,MMAXA
31900 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31901 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
31906 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31911 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31914 ELSEIF(ISUB.EQ.429) THEN
31915 C...q + q~ -> g + QQ~[1S08]
31916 IF(MSTP(145).EQ.0) THEN
31917 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
31918 & (TH2+UH2)/(SQMQQR*SH*THUH2)
31920 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
31921 IF(MSTP(147).EQ.0) THEN
31923 ELSEIF(MSTP(147).EQ.1) THEN
31924 FACQQG=COMFAC*2D0*FA
31925 ELSEIF(MSTP(147).EQ.3) THEN
31927 ELSEIF(MSTP(147).EQ.4) THEN
31929 ELSEIF(MSTP(147).EQ.5) THEN
31931 ELSEIF(MSTP(147).EQ.6) THEN
31935 C...Split total contribution into different colour flows just like
31936 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31937 C...(recalculate kinematics for massless partons).
31938 THP=-0.5D0*SH*(1D0-CTH)
31939 UHP=-0.5D0*SH*(1D0+CTH)
31940 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31941 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31942 FACGGS=FACGG1+FACGG2
31943 DO 2448 I=MMINA,MMAXA
31944 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31945 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
31950 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31955 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31958 ELSEIF(ISUB.EQ.430) THEN
31959 C...q + q~ -> g + QQ~[3PJ8]
31960 IF(MSTP(145).EQ.0) THEN
31961 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
31962 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
31963 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
31964 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
31966 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
31967 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
31968 BB=8D0*(UHSH2+SH*TH)
31969 CC=8D0*(SHTH2+SH*UH)
31970 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
31971 IF(MSTP(147).EQ.0) THEN
31972 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31973 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31974 ELSEIF(MSTP(147).EQ.1) THEN
31975 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31976 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31977 ELSEIF(MSTP(147).EQ.3) THEN
31978 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31979 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31980 ELSEIF(MSTP(147).EQ.4) THEN
31981 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31982 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31983 ELSEIF(MSTP(147).EQ.5) THEN
31984 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31985 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31986 ELSEIF(MSTP(147).EQ.6) THEN
31987 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31988 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31990 FACQQG=COMFAC*FF*FACQQG
31992 C...Split total contribution into different colour flows just like
31993 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31994 C...(recalculate kinematics for massless partons).
31995 THP=-0.5D0*SH*(1D0-CTH)
31996 UHP=-0.5D0*SH*(1D0+CTH)
31997 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31998 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31999 FACGGS=FACGG1+FACGG2
32000 DO 2449 I=MMINA,MMAXA
32001 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32002 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
32007 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
32012 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
32015 ELSEIF(ISUB.EQ.431) THEN
32016 C...g + g -> QQ~[3P01] + g
32017 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32018 QGTW=(SH*TH*UH)/SH**3
32020 IF(MSTP(145).EQ.0) THEN
32021 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32022 & (9D0*RGTW**2*PGTW**4*
32023 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32024 & -6D0*RGTW*PGTW**3*QGTW*
32025 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32026 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32027 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32028 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32030 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
32031 & (9D0*RGTW**2*PGTW**4*
32032 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32033 & -6D0*RGTW*PGTW**3*QGTW*
32034 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32035 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32036 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32037 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32038 IF(MSTP(147).EQ.0) THEN
32040 ELSEIF(MSTP(147).EQ.1) THEN
32041 FACQQG=COMFAC*2D0*FC1
32042 ELSEIF(MSTP(147).EQ.3) THEN
32044 ELSEIF(MSTP(147).EQ.4) THEN
32046 ELSEIF(MSTP(147).EQ.5) THEN
32048 ELSEIF(MSTP(147).EQ.6) THEN
32052 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32057 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32060 ELSEIF(ISUB.EQ.432) THEN
32061 C...g + g -> QQ~[3P11] + g
32062 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32063 QGTW=(SH*TH*UH)/SH**3
32065 IF(MSTP(145).EQ.0) THEN
32066 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
32067 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
32068 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
32069 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
32071 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
32072 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
32073 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
32074 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
32075 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
32076 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32077 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32078 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
32079 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32080 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32081 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
32082 C4=-4D0*THUH*(TH-UH)**2*
32083 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
32084 & -SH2*TH*UH*(TH2+UH2))
32085 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
32086 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
32087 & +SH2*(5D0*THUH2-17D0*TH*UH)))
32088 IF(MSTP(147).EQ.0) THEN
32089 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32090 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32091 ELSEIF(MSTP(147).EQ.1) THEN
32092 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32093 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32094 ELSEIF(MSTP(147).EQ.3) THEN
32095 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32096 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32097 ELSEIF(MSTP(147).EQ.4) THEN
32098 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32099 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32100 ELSEIF(MSTP(147).EQ.5) THEN
32101 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32102 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32103 ELSEIF(MSTP(147).EQ.6) THEN
32104 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32105 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32107 FACQQG=COMFAC*FF*FACQQG
32109 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32114 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32117 ELSEIF(ISUB.EQ.433) THEN
32118 C...g + g -> QQ~[3P21] + g
32119 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32120 QGTW=(SH*TH*UH)/SH**3
32122 IF(MSTP(145).EQ.0) THEN
32123 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32124 & (12D0*RGTW**2*PGTW**4*
32125 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32126 & -3D0*RGTW*PGTW**3*QGTW*
32127 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
32128 & +2D0*PGTW**2*QGTW**2*
32129 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
32130 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
32131 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32133 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
32134 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
32135 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
32137 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
32138 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
32139 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
32140 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
32141 & +10D0*(SH2**2+TH2**2))
32142 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
32143 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
32144 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
32145 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
32146 & +4D0*SH*TH*UH2**4*SHTH2)
32147 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
32148 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
32149 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
32150 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
32151 & +10D0*(SH2**2+UH2**2))
32152 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
32153 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
32154 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
32155 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
32156 & +4D0*SH*UH*TH2**4*UHSH2)
32157 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
32158 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
32159 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
32160 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
32161 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
32162 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
32163 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
32164 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
32165 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
32166 & +3D0*(TH2**3+UH2**3)))
32167 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
32168 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
32169 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
32170 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
32171 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
32172 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
32173 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
32175 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
32177 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
32179 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
32180 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
32181 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
32182 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
32183 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
32184 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
32186 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
32188 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
32190 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
32191 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
32192 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
32193 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
32194 & +4D0*SH*TH2**2*UH2**2*THUH2
32195 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
32196 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
32197 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
32198 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
32199 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32200 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
32201 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
32202 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
32203 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
32204 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
32205 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
32206 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
32207 & +2D0*(TH2**3+UH2**3))
32208 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
32209 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
32210 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
32211 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32212 IF(MSTP(147).EQ.0) THEN
32213 FACQQG=1D0/3D0*(C1*3D0
32214 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32215 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32216 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32217 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32218 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32219 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32220 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32221 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32222 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32223 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32224 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32225 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32226 ELSEIF(MSTP(147).EQ.1) THEN
32228 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32229 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32230 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32231 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32232 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32233 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32234 & +EL1K10*EL2K20*EL1K11*EL2K11)
32235 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32236 & +EL1K10*EL2K20*EL1K21*EL2K21)
32237 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32238 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32239 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32240 & +EL1K20*EL2K20*EL1K11*EL2K11)
32241 ELSEIF(MSTP(147).EQ.2) THEN
32243 & -C2*EL1K11*EL2K11
32244 & -C3*EL1K21*EL2K21
32245 & -C4*EL1K11*EL2K21
32246 & +C5*(EL1K11*EL2K11)**2
32247 & +C6*(EL1K21*EL2K21)**2
32248 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32249 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32250 & +(C9+C0)*(EL1K11*EL2K21)**2)
32252 FACQQG=COMFAC*FF*FACQQG
32254 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32259 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32262 ELSEIF(ISUB.EQ.434) THEN
32263 C...q + g -> q + QQ~[3P01]
32264 IF(MSTP(145).EQ.0) THEN
32265 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
32266 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32268 FA=-PARU(1)*AS**3*(16D0/243D0)*
32269 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32270 IF(MSTP(147).EQ.0) THEN
32272 ELSEIF(MSTP(147).EQ.1) THEN
32273 FACQQG=COMFAC*2D0*FA
32274 ELSEIF(MSTP(147).EQ.3) THEN
32276 ELSEIF(MSTP(147).EQ.4) THEN
32278 ELSEIF(MSTP(147).EQ.5) THEN
32280 ELSEIF(MSTP(147).EQ.6) THEN
32284 DO 2452 I=MMINA,MMAXA
32285 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
32287 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
32288 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
32291 ISIG(NCHN,3-ISDE)=21
32293 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32297 ELSEIF(ISUB.EQ.435) THEN
32298 C...q + g -> q + QQ~[3P11]
32299 IF(MSTP(145).EQ.0) THEN
32300 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
32301 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
32303 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
32308 IF(MSTP(147).EQ.0) THEN
32309 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32310 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32311 ELSEIF(MSTP(147).EQ.1) THEN
32312 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32313 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32314 ELSEIF(MSTP(147).EQ.3) THEN
32315 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32316 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32317 ELSEIF(MSTP(147).EQ.4) THEN
32318 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32319 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32320 ELSEIF(MSTP(147).EQ.5) THEN
32321 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32322 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32323 ELSEIF(MSTP(147).EQ.6) THEN
32324 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32325 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32327 FACQQG=COMFAC*FF*FACQQG
32329 DO 2454 I=MMINA,MMAXA
32330 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
32332 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
32333 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
32336 ISIG(NCHN,3-ISDE)=21
32338 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32342 ELSEIF(ISUB.EQ.436) THEN
32343 C...q + g -> q + QQ~[3P21]
32344 IF(MSTP(145).EQ.0) THEN
32345 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
32346 & ((6D0*SQMQQ**2+TH2)*UHSH2
32347 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
32348 & (SQMQQR*TH*UHSH2**2)
32350 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
32352 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
32361 IF(MSTP(147).EQ.0) THEN
32362 FACQQG=1D0/3D0*(C1*3D0
32363 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32364 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32365 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32366 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32367 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32368 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32369 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32370 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32371 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32372 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32373 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32374 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32375 ELSEIF(MSTP(147).EQ.1) THEN
32377 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32378 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32379 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32380 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32381 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32382 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32383 & +EL1K10*EL2K20*EL1K11*EL2K11)
32384 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32385 & +EL1K10*EL2K20*EL1K21*EL2K21)
32386 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32387 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32388 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32389 & +EL1K20*EL2K20*EL1K11*EL2K11)
32390 ELSEIF(MSTP(147).EQ.2) THEN
32392 & -C2*EL1K11*EL2K11
32393 & -C3*EL1K21*EL2K21
32394 & -C4*EL1K11*EL2K21
32395 & +C5*(EL1K11*EL2K11)**2
32396 & +C6*(EL1K21*EL2K21)**2
32397 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32398 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32399 & +(C9+C0)*(EL1K11*EL2K21)**2)
32401 FACQQG=COMFAC*FF*FACQQG
32403 DO 2456 I=MMINA,MMAXA
32404 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
32406 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
32407 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
32410 ISIG(NCHN,3-ISDE)=21
32412 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32416 ELSEIF(ISUB.EQ.437) THEN
32417 C...q + q~ -> g + QQ~[3P01]
32418 IF(MSTP(145).EQ.0) THEN
32419 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
32420 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
32422 FA=PARU(1)*AS**3*(128D0/729D0)*
32423 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
32424 IF(MSTP(147).EQ.0) THEN
32426 ELSEIF(MSTP(147).EQ.1) THEN
32427 FACQQG=COMFAC*2D0*FA
32428 ELSEIF(MSTP(147).EQ.3) THEN
32430 ELSEIF(MSTP(147).EQ.4) THEN
32432 ELSEIF(MSTP(147).EQ.5) THEN
32434 ELSEIF(MSTP(147).EQ.6) THEN
32438 DO 2457 I=MMINA,MMAXA
32439 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32440 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
32445 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32448 ELSEIF(ISUB.EQ.438) THEN
32449 C...q + q~ -> g + QQ~[3P11]
32450 IF(MSTP(145).EQ.0) THEN
32451 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
32452 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
32454 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
32459 IF(MSTP(147).EQ.0) THEN
32460 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32461 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32462 ELSEIF(MSTP(147).EQ.1) THEN
32463 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32464 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32465 ELSEIF(MSTP(147).EQ.3) THEN
32466 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32467 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32468 ELSEIF(MSTP(147).EQ.4) THEN
32469 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32470 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32471 ELSEIF(MSTP(147).EQ.5) THEN
32472 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32473 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32474 ELSEIF(MSTP(147).EQ.6) THEN
32475 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32476 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32478 FACQQG=COMFAC*FF*FACQQG
32480 DO 2458 I=MMINA,MMAXA
32481 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32482 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
32487 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32490 ELSEIF(ISUB.EQ.439) THEN
32491 C...q + q~ -> g + QQ~[3P21]
32492 IF(MSTP(145).EQ.0) THEN
32493 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
32494 & ((6D0*SQMQQ**2+SH2)*THUH2
32495 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
32496 & (SQMQQR*SH*THUH2**2)
32498 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
32500 C2=4D0*(SH2+UH2+2D0*SH*THUH)
32501 C3=4D0*(SH2+TH2+2D0*SH*THUH)
32502 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
32509 IF(MSTP(147).EQ.0) THEN
32510 FACQQG=1D0/3D0*(C1*3D0
32511 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32512 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32513 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32514 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32515 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32516 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32517 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32518 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32519 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32520 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32521 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32522 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32523 ELSEIF(MSTP(147).EQ.1) THEN
32525 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32526 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32527 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32528 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32529 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32530 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32531 & +EL1K10*EL2K20*EL1K11*EL2K11)
32532 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32533 & +EL1K10*EL2K20*EL1K21*EL2K21)
32534 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32535 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32536 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32537 & +EL1K20*EL2K20*EL1K11*EL2K11)
32538 ELSEIF(MSTP(147).EQ.2) THEN
32540 & -C2*EL1K11*EL2K11
32541 & -C3*EL1K21*EL2K21
32542 & -C4*EL1K11*EL2K21
32543 & +C5*(EL1K11*EL2K11)**2
32544 & +C6*(EL1K21*EL2K21)**2
32545 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32546 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32547 & +(C9+C0)*(EL1K11*EL2K21)**2)
32549 FACQQG=COMFAC*FF*FACQQG
32551 DO 2459 I=MMINA,MMAXA
32552 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32553 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
32558 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32568 C*********************************************************************
32571 C...Subprocess cross sections for W/Z processes,
32572 C...except that longitudinal WW scattering is in Higgs sector.
32573 C...Auxiliary to PYSIGH.
32575 SUBROUTINE PYSGWZ(NCHN,SIGS)
32577 C...Double precision and integer declarations
32578 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32579 IMPLICIT INTEGER(I-N)
32580 INTEGER PYK,PYCHGE,PYCOMP
32581 C...Parameter statement to help give large particle numbers.
32582 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32583 &KEXCIT=4000000,KDIMEN=5000000)
32585 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32586 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32587 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32588 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
32589 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32590 COMMON/PYINT1/MINT(400),VINT(400)
32591 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
32592 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
32593 COMMON/PYINT4/MWID(500),WIDS(500,5)
32594 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
32595 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
32596 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
32597 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
32598 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
32599 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
32600 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
32601 C...Local arrays and complex numbers
32602 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
32604 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
32606 C...Differential cross section expressions.
32608 IF(ISUB.LE.20) THEN
32610 C...f + fbar -> gamma*/Z0
32612 CALL PYWIDT(23,SH,WDTP,WDTE)
32614 FACZ=4D0*COMFAC*3D0
32617 DO 100 I=MMINA,MMAXA
32618 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
32619 EI=KCHG(IABS(I),1)/3D0
32623 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
32625 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
32630 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
32631 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
32632 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
32633 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
32636 ELSEIF(ISUB.EQ.2) THEN
32637 C...f + fbar' -> W+/-
32638 CALL PYWIDT(24,SH,WDTP,WDTE)
32640 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
32641 HP=AEM/(24D0*XW)*SH
32642 DO 120 I=MMIN1,MMAX1
32643 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
32645 DO 110 J=MMIN2,MMAX2
32646 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
32648 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
32649 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32651 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32653 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
32658 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
32659 SIGH(NCHN)=HI*FACBW*HF
32663 ELSEIF(ISUB.EQ.15) THEN
32664 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
32665 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32666 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32670 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32671 DO 130 I=1,MIN(16,MDCY(23,3))
32673 IF(MDME(IDC,1).LT.0) GOTO 130
32675 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32679 AF=SIGN(1D0,EF+0.1D0)
32681 ELSEIF(I.LE.16) THEN
32683 AF=SIGN(1D0,EF+0.1D0)
32686 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32687 IF(4D0*RM1.LT.1D0) THEN
32689 IF(I.LE.8) FCOF=3D0*RADC4
32690 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32692 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32693 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32694 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32695 & AF**2*(1D0-4D0*RM1))*BE34
32699 C...Propagators: as simulated in PYOFSH and as desired
32700 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32704 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32706 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32707 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32708 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32709 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32710 C...Loop over flavours; consider full gamma/Z structure
32711 DO 140 I=MMINA,MMAXA
32712 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32713 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
32714 EI=KCHG(IABS(I),1)/3D0
32721 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
32722 & (VI**2+AI**2)*HFZZ)/HBW4
32725 ELSEIF(ISUB.EQ.16) THEN
32726 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
32727 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32728 C...Propagators: as simulated in PYOFSH and as desired
32729 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32730 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32731 GMMWC=SQRT(SQM4)*WDTP(0)
32732 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32733 FACWG=FACWG*HBW4C/HBW4
32734 DO 160 I=MMIN1,MMAX1
32736 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
32737 DO 150 J=MMIN2,MMAX2
32739 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
32740 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
32741 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32742 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32743 FCKM=VCKM((IA+1)/2,(JA+1)/2)
32748 SIGH(NCHN)=FACWG*FCKM*WIDSC
32752 ELSEIF(ISUB.EQ.19) THEN
32753 C...f + fbar -> gamma + (gamma*/Z0)
32754 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32755 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32759 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32760 DO 170 I=1,MIN(16,MDCY(23,3))
32762 IF(MDME(IDC,1).LT.0) GOTO 170
32764 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32768 AF=SIGN(1D0,EF+0.1D0)
32770 ELSEIF(I.LE.16) THEN
32772 AF=SIGN(1D0,EF+0.1D0)
32775 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32776 IF(4D0*RM1.LT.1D0) THEN
32778 IF(I.LE.8) FCOF=3D0*RADC4
32779 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32781 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32782 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32783 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32784 & AF**2*(1D0-4D0*RM1))*BE34
32788 C...Propagators: as simulated in PYOFSH and as desired
32789 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32793 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32795 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32796 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32797 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32798 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32799 C...Loop over flavours; consider full gamma/Z structure
32800 DO 180 I=MMINA,MMAXA
32801 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
32802 EI=KCHG(IABS(I),1)/3D0
32806 IF(IABS(I).LE.10) FCOI=FACA/3D0
32811 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
32812 & (VI**2+AI**2)*HFZZ)/HBW4
32815 ELSEIF(ISUB.EQ.20) THEN
32816 C...f + fbar' -> gamma + W+/-
32817 FACGW=COMFAC*0.5D0*AEM**2/XW
32818 C...Propagators: as simulated in PYOFSH and as desired
32819 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32820 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32821 GMMWC=SQRT(SQM4)*WDTP(0)
32822 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32823 FACGW=FACGW*HBW4C/HBW4
32824 C...Anomalous couplings
32825 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32828 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
32829 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
32830 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
32831 & (4D0*SQMW))/(TH+UH)**2
32833 DO 200 I=MMIN1,MMAX1
32835 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
32836 DO 190 J=MMIN2,MMAX2
32838 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
32839 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
32840 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32842 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32843 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32845 FACWR=UH/(TH+UH)-1D0/3D0
32846 FCKM=VCKM((IA+1)/2,(JA+1)/2)
32853 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
32858 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
32863 ELSEIF(ISUB.LE.40) THEN
32864 IF(ISUB.EQ.22) THEN
32865 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
32866 C...Kinematics dependence
32867 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
32868 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
32869 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32875 RADC3=1D0+PYALPS(SQM3)/PARU(1)
32876 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32877 DO 230 I=1,MIN(16,MDCY(23,3))
32879 IF(MDME(IDC,1).LT.0) GOTO 230
32881 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
32882 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
32885 AF=SIGN(1D0,EF+0.1D0)
32887 ELSEIF(I.LE.16) THEN
32889 AF=SIGN(1D0,EF+0.1D0)
32892 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
32893 IF(4D0*RM1.LT.1D0) THEN
32895 IF(I.LE.8) FCOF=3D0*RADC3
32896 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32898 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32899 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32900 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32901 & AF**2*(1D0-4D0*RM1))*BE34
32904 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32905 IF(4D0*RM1.LT.1D0) THEN
32907 IF(I.LE.8) FCOF=3D0*RADC4
32908 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32910 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32911 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32912 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32913 & AF**2*(1D0-4D0*RM1))*BE34
32917 C...Propagators: as simulated in PYOFSH and as desired
32918 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32919 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32923 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32925 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32927 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
32928 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
32929 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
32934 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32936 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32938 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
32939 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
32940 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
32942 C...Loop over flavours; separate left- and right-handed couplings
32943 DO 270 I=MMINA,MMAXA
32944 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
32945 EI=KCHG(IABS(I),1)/3D0
32951 IF(IABS(I).LE.10) FCOI=FACA/3D0
32953 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
32954 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
32955 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
32956 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
32958 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
32959 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
32960 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
32961 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
32966 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
32969 ELSEIF(ISUB.EQ.23) THEN
32970 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
32971 FACZW=COMFAC*0.5D0*(AEM/XW)**2
32972 FACZW=FACZW*WIDS(23,2)
32973 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32974 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
32975 DO 290 I=MMIN1,MMAX1
32977 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
32978 DO 280 J=MMIN2,MMAX2
32980 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
32981 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
32982 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32984 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32986 AI=SIGN(1D0,EI+0.1D0)
32989 AJ=SIGN(1D0,EJ+0.1D0)
32991 IF(VI+AI.GT.0) THEN
33000 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33002 IF(IA.LE.10) FCOI=FACA/3D0
33007 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
33008 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
33009 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
33010 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
33011 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
33012 & WIDS(24,(5-KCHW)/2)
33013 C***Protect against slightly negative cross sections. (Reason yet to be
33014 C***sorted out. One possibility: addition of width to the W propagator.)
33015 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
33019 ELSEIF(ISUB.EQ.25) THEN
33020 C...f + fbar -> W+ + W-
33021 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
33023 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
33024 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33025 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33026 GMMW3=SQRT(SQM3)*WDTP(0)
33027 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33028 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33029 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33030 GMMW4=SQRT(SQM4)*WDTP(0)
33031 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
33032 C...Kinematical functions
33033 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33034 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
33035 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
33036 GT=THUH34+4D0*THUH/TH2
33037 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
33038 GU=THUH34+4D0*THUH/UH2
33039 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
33040 C...Common factors and couplings
33041 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
33042 FACWW=FACWW*WIDS(24,1)
33044 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
33045 CZZ=AEM**2/(32D0*XW**2)*HBWZC
33046 CNG=AEM**2/(4D0*XW)
33047 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
33048 CNN=AEM**2/(16D0*XW**2)
33049 C...Coulomb factor for W+W- pair
33050 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
33051 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
33052 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
33053 IF(COULE.LT.100D0*PMAS(24,2)) THEN
33054 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33055 & PMAS(24,2)**2)-COULE))
33057 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
33059 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
33060 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33061 & PMAS(24,2)**2)+COULE))
33063 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
33066 IF(MSTP(40).EQ.1) THEN
33067 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
33068 & MAX(1D-10,2D0*COULP*COULP1))
33069 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33070 ELSEIF(MSTP(40).EQ.2) THEN
33071 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
33072 COULCP=DCMPLX(0D0,DBLE(COULP))
33073 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
33074 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
33075 & (4D0*COULCP)*LOG(COULCD)
33076 COULCS=DCMPLX(0D0,0D0)
33079 COULXX=(ISTP-0.5)/NSTP
33080 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
33081 & (1D0+COULXX/COULCD))
33083 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
33085 FACCOU=ABS(COULCR)**2
33086 ELSEIF(MSTP(40).EQ.3) THEN
33087 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
33088 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
33089 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33091 ELSEIF(MSTP(40).EQ.4) THEN
33092 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
33098 C...Loop over allowed flavours
33099 DO 310 I=MMINA,MMAXA
33100 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
33101 EI=KCHG(IABS(I),1)/3D0
33102 AI=SIGN(1D0,EI+0.1D0)
33105 IF(IABS(I).LE.10) FCOI=FACA/3D0
33106 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
33108 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
33109 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
33111 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
33112 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
33115 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
33116 BET=SQRT(1D0-4D0*XMW02/SH)
33117 GAT=1D0/SQRT(1D0-BET**2)
33119 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
33120 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
33121 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
33122 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
33123 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
33124 & (1D0-2D0*BET*CTH+BET**2))
33125 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
33126 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
33127 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
33128 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
33129 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
33130 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
33131 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
33138 SIGH(NCHN)=FACWW*FCOI*DSIGWW
33141 ELSEIF(ISUB.EQ.30) THEN
33142 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
33143 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
33145 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33149 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33150 DO 320 I=1,MIN(16,MDCY(23,3))
33152 IF(MDME(IDC,1).LT.0) GOTO 320
33154 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33158 AF=SIGN(1D0,EF+0.1D0)
33160 ELSEIF(I.LE.16) THEN
33162 AF=SIGN(1D0,EF+0.1D0)
33165 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33166 IF(4D0*RM1.LT.1D0) THEN
33168 IF(I.LE.8) FCOF=3D0*RADC4
33169 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33171 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33172 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33173 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33174 & AF**2*(1D0-4D0*RM1))*BE34
33178 C...Propagators: as simulated in PYOFSH and as desired
33179 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33183 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33185 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33186 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33187 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33188 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33189 C...Loop over flavours; consider full gamma/Z structure
33190 DO 340 I=MMINA,MMAXA
33191 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
33192 EI=KCHG(IABS(I),1)/3D0
33195 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
33196 & (VI**2+AI**2)*HFZZ)/HBW4
33198 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
33199 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
33202 ISIG(NCHN,3-ISDE)=21
33208 ELSEIF(ISUB.EQ.31) THEN
33209 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
33210 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
33211 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
33212 C...Propagators: as simulated in PYOFSH and as desired
33213 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33214 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33215 GMMWC=SQRT(SQM4)*WDTP(0)
33216 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33217 FACWQ=FACWQ*HBW4C/HBW4
33218 DO 360 I=MMINA,MMAXA
33219 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
33221 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33222 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33224 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
33225 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
33228 ISIG(NCHN,3-ISDE)=21
33230 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33234 ELSEIF(ISUB.EQ.35) THEN
33235 C...f + gamma -> f + (gamma*/Z0)
33236 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
33237 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
33238 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
33239 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
33240 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
33241 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
33243 FZQN=SH2+UH2+2D0*SQM4*TH
33246 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
33247 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33251 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33252 DO 370 I=1,MIN(16,MDCY(23,3))
33254 IF(MDME(IDC,1).LT.0) GOTO 370
33256 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33260 AF=SIGN(1D0,EF+0.1D0)
33262 ELSEIF(I.LE.16) THEN
33264 AF=SIGN(1D0,EF+0.1D0)
33267 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33268 IF(4D0*RM1.LT.1D0) THEN
33270 IF(I.LE.8) FCOF=3D0*RADC4
33271 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33273 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33274 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33275 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33276 & AF**2*(1D0-4D0*RM1))*BE34
33280 C...Propagators: as simulated in PYOFSH and as desired
33281 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33285 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33287 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33288 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33289 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33290 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33291 C...Loop over flavours; consider full gamma/Z structure
33292 DO 390 I=MMINA,MMAXA
33293 IF(I.EQ.0) GOTO 390
33294 EI=KCHG(IABS(I),1)/3D0
33297 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
33298 & (VI**2+AI**2)*HFZZ)/HBW4
33299 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
33301 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
33302 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
33305 ISIG(NCHN,3-ISDE)=22
33307 SIGH(NCHN)=FACZQ*FZQN/FZQD
33311 ELSEIF(ISUB.EQ.36) THEN
33312 C...f + gamma -> f' + W+/-
33313 FWQ=COMFAC*AEM**2/(2D0*XW)*
33314 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
33315 C...Propagators: as simulated in PYOFSH and as desired
33316 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33317 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33318 GMMWC=SQRT(SQM4)*WDTP(0)
33319 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33321 DO 410 I=MMINA,MMAXA
33322 IF(I.EQ.0) GOTO 410
33324 EIA=ABS(KCHG(IABS(I),1)/3D0)
33325 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
33326 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33327 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33329 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
33330 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
33333 ISIG(NCHN,3-ISDE)=22
33335 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33340 ELSEIF(ISUB.LE.100) THEN
33341 IF(ISUB.EQ.69) THEN
33342 C...gamma + gamma -> W+ + W-
33343 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
33344 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
33345 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
33346 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
33347 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
33355 ELSEIF(ISUB.EQ.70) THEN
33356 C...gamma + W+/- -> Z0 + W+/-
33357 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
33358 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
33359 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
33360 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
33361 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
33362 DO 440 KCHW=1,-1,-2
33364 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
33367 ISIG(NCHN,3-ISDE)=24*KCHW
33369 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
33378 C*********************************************************************
33381 C...Subprocess cross sections for Higgs processes,
33382 C...except Higgs pairs in PYSGSU, but including WW scattering.
33383 C...Auxiliary to PYSIGH.
33385 SUBROUTINE PYSGHG(NCHN,SIGS)
33387 C...Double precision and integer declarations
33388 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33389 IMPLICIT INTEGER(I-N)
33390 INTEGER PYK,PYCHGE,PYCOMP
33391 C...Parameter statement to help give large particle numbers.
33392 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33393 &KEXCIT=4000000,KDIMEN=5000000)
33395 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33396 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33397 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
33398 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33399 COMMON/PYINT1/MINT(400),VINT(400)
33400 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33401 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33402 COMMON/PYINT4/MWID(500),WIDS(500,5)
33403 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
33404 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33405 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33406 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33407 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33408 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33409 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
33410 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
33411 C...Local arrays and complex variables
33412 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
33413 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
33414 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
33416 C...Convert H or A process into equivalent h one
33419 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
33420 KFHIGG=KFPR(ISUB,1)
33422 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
33423 &ISUB.LE.190)) THEN
33425 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
33427 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
33428 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
33429 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
33430 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
33431 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
33432 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
33433 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
33434 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
33435 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
33436 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
33437 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
33438 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
33440 SQMH=PMAS(KFHIGG,1)**2
33441 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
33443 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33444 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
33445 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
33446 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
33447 IF(MSTP(46).LE.4) THEN
33448 HDTLH=LOG(PMAS(25,1)/PARP(44))
33449 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
33450 HDTNR=-1D0/18D0+HDTLH/6D0
33452 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
33453 HDTLQ=LOG(PARP(45)/PARP(44))
33454 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
33455 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
33458 C...Calculate lowest and next-to-lowest order partial wave amplitudes
33459 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
33463 HDTLS=LOG(SH/PARP(44)**2)
33464 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
33465 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
33466 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
33467 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
33468 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
33469 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
33470 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
33471 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
33473 C...Unitarize partial wave amplitudes with Pade or K-matrix method
33474 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
33475 A00U=A00L/(1D0-A004/A00L)
33476 A20U=A20L/(1D0-A204/A20L)
33477 A11U=A11L/(1D0-A114/A11L)
33479 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
33480 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
33481 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
33485 C...Differential cross section expressions.
33487 IF(ISUB.LE.60) THEN
33489 C...f + fbar -> h0 (or H0, or A0)
33490 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33492 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33493 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33495 HP=AEM/(8D0*XW)*SH/SQMW*SH
33496 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33497 DO 100 I=MMINA,MMAXA
33498 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
33500 RMQ=PYMRUN(IA,SH)**2/SH
33502 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
33503 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33505 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33506 IF(IA.GT.10) IKFI=3
33507 HI=HI*PARU(150+10*IHIGG+IKFI)**2
33508 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33509 HI=HI/(1D0+RMSS(41))**2
33510 IF(IHIGG.NE.3) THEN
33511 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33512 & PARU(151+10*IHIGG))**2
33520 SIGH(NCHN)=HI*FACBW*HF
33523 ELSEIF(ISUB.EQ.5) THEN
33525 CALL PYWIDT(25,SH,WDTP,WDTE)
33527 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33528 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
33529 HP=AEM/(8D0*XW)*SH/SQMW*SH
33530 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33532 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
33533 DO 120 I=MMIN1,MMAX1
33534 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
33535 DO 110 J=MMIN2,MMAX2
33536 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
33537 EI=KCHG(IABS(I),1)/3D0
33540 EJ=KCHG(IABS(J),1)/3D0
33547 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
33551 ELSEIF(ISUB.EQ.8) THEN
33553 CALL PYWIDT(25,SH,WDTP,WDTE)
33555 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33556 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
33557 HP=AEM/(8D0*XW)*SH/SQMW*SH
33558 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33560 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
33561 DO 140 I=MMIN1,MMAX1
33562 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
33563 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33564 DO 130 J=MMIN2,MMAX2
33565 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
33566 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33567 IF(EI*EJ.GT.0D0) GOTO 130
33572 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
33576 ELSEIF(ISUB.EQ.24) THEN
33577 C...f + fbar -> Z0 + h0 (or H0, or A0)
33578 C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
33579 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
33580 CALL PYWIDT(23,SQM3,WDTP,WDTE)
33581 GMMZ3=SQRT(SQM3)*WDTP(0)
33582 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
33583 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33584 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33585 GMMH4=SQRT(SQM4)*WDTP(0)
33586 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
33587 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33588 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
33589 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
33590 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
33591 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
33592 & PARU(154+10*IHIGG)**2
33593 DO 150 I=MMINA,MMAXA
33594 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
33595 EI=KCHG(IABS(I),1)/3D0
33599 IF(IABS(I).LE.10) FCOI=FACA/3D0
33604 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
33607 ELSEIF(ISUB.EQ.26) THEN
33608 C...f + fbar' -> W+/- + h0 (or H0, or A0)
33609 C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
33610 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33611 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33612 GMMW3=SQRT(SQM3)*WDTP(0)
33613 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33614 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33615 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33616 GMMH4=SQRT(SQM4)*WDTP(0)
33617 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
33618 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33619 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
33620 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
33621 FACHW=FACHW*WIDS(KFHIGG,2)
33622 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
33623 & PARU(155+10*IHIGG)**2
33624 DO 170 I=MMIN1,MMAX1
33626 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
33627 DO 160 J=MMIN2,MMAX2
33629 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
33630 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
33631 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33633 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33635 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33637 IF(IA.LE.10) FCOI=FACA/3D0
33642 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
33646 ELSEIF(ISUB.EQ.32) THEN
33647 C...f + g -> f + h0 (q + g -> q + h0 only)
33648 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
33649 C...H propagator: as simulated in PYOFSH and as desired
33650 SQMHC=PMAS(25,1)**2
33651 GMMHC=PMAS(25,1)*PMAS(25,2)
33652 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
33653 CALL PYWIDT(25,SQM4,WDTP,WDTE)
33654 GMMHCC=SQRT(SQM4)*WDTP(0)
33655 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
33656 FHCQ=FHCQ*HBW4C/HBW4
33657 DO 190 I=MMINA,MMAXA
33659 IF(IA.NE.5) GOTO 190
33660 SQML=PYMRUN(IA,SH)**2
33662 FACHCQ=FHCQ*SQML/SQMW*
33663 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
33664 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
33665 & (SQM4-SQMQ-SH)/SH)
33667 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
33668 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
33671 ISIG(NCHN,3-ISDE)=21
33673 SIGH(NCHN)=FACHCQ*WIDS(25,2)
33678 ELSEIF(ISUB.LE.80) THEN
33679 IF(ISUB.EQ.71) THEN
33680 C...Z0 + Z0 -> Z0 + Z0
33681 IF(SH.LE.4.01D0*SQMZ) GOTO 220
33683 IF(MSTP(46).LE.2) THEN
33684 C...Exact scattering ME:s for on-mass-shell gauge bosons
33685 BE2=1D0-4D0*SQMZ/SH
33686 TH=-0.5D0*SH*BE2*(1D0-CTH)
33687 UH=-0.5D0*SH*BE2*(1D0+CTH)
33688 IF(MAX(TH,UH).GT.-1D0) GOTO 220
33689 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
33690 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33691 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33692 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
33693 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33694 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33695 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
33696 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33697 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33698 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
33699 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
33700 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33701 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
33702 & (ASHIM+ATHIM+AUHIM)**2)
33703 IF(MSTP(46).EQ.2) FACZZ=0D0
33706 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33707 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
33708 & ABS(A00U+2D0*A20U)**2
33710 FACZZ=FACZZ*WIDS(23,1)
33712 DO 210 I=MMIN1,MMAX1
33713 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
33714 EI=KCHG(IABS(I),1)/3D0
33718 DO 200 J=MMIN2,MMAX2
33719 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
33720 EJ=KCHG(IABS(J),1)/3D0
33728 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
33733 ELSEIF(ISUB.EQ.72) THEN
33734 C...Z0 + Z0 -> W+ + W-
33735 IF(SH.LE.4.01D0*SQMZ) GOTO 250
33737 IF(MSTP(46).LE.2) THEN
33738 C...Exact scattering ME:s for on-mass-shell gauge bosons
33739 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33741 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33742 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33743 IF(MAX(TH,UH).GT.-1D0) GOTO 250
33744 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33745 & (1D0-2D0*SQMZ/SH)
33746 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33747 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33748 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33749 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33750 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33751 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33752 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33754 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33755 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33756 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33757 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33758 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33760 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33762 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
33763 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
33764 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
33765 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33766 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33767 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
33768 & (ATWIM+AUWIM+A4IM)**2)
33771 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33772 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
33773 & ABS(A00U-A20U)**2
33775 FACWW=FACWW*WIDS(24,1)
33777 DO 240 I=MMIN1,MMAX1
33778 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
33779 EI=KCHG(IABS(I),1)/3D0
33783 DO 230 J=MMIN2,MMAX2
33784 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
33785 EJ=KCHG(IABS(J),1)/3D0
33793 SIGH(NCHN)=FACWW*AVI*AVJ
33798 ELSEIF(ISUB.EQ.73) THEN
33799 C...Z0 + W+/- -> Z0 + W+/-
33800 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
33802 IF(MSTP(46).LE.2) THEN
33803 C...Exact scattering ME:s for on-mass-shell gauge bosons
33804 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
33805 EP1=1D0-(SQMZ-SQMW)/SH
33806 EP2=1D0+(SQMZ-SQMW)/SH
33807 TH=-0.5D0*SH*BE2*(1D0-CTH)
33808 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
33809 IF(MAX(TH,UH).GT.-1D0) GOTO 280
33810 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
33811 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33812 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33813 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
33814 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
33815 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
33816 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
33818 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
33819 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
33820 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
33821 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
33822 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
33823 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
33824 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
33825 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
33826 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
33827 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
33828 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
33829 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
33831 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
33832 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
33834 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
33835 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
33836 IF(MSTP(46).LE.0) FACZW=0D0
33837 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
33838 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
33839 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
33840 & (ASWIM+AUWIM+A4IM)**2)
33843 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33844 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
33845 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
33847 FACZW=FACZW*WIDS(23,2)
33849 DO 270 I=MMIN1,MMAX1
33850 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
33851 EI=KCHG(IABS(I),1)/3D0
33855 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
33856 DO 260 J=MMIN2,MMAX2
33857 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
33858 EJ=KCHG(IABS(J),1)/3D0
33862 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
33867 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
33872 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
33877 ELSEIF(ISUB.EQ.75) THEN
33878 C...W+ + W- -> gamma + gamma
33880 ELSEIF(ISUB.EQ.76) THEN
33881 C...W+ + W- -> Z0 + Z0
33882 IF(SH.LE.4.01D0*SQMZ) GOTO 310
33884 IF(MSTP(46).LE.2) THEN
33885 C...Exact scattering ME:s for on-mass-shell gauge bosons
33886 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33888 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33889 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33890 IF(MAX(TH,UH).GT.-1D0) GOTO 310
33891 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33892 & (1D0-2D0*SQMZ/SH)
33893 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33894 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33895 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33896 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33897 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33898 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33899 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33901 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33902 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33903 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33904 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33905 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33907 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33909 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33911 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33912 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33913 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33914 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
33915 & (ATWIM+AUWIM+A4IM)**2)
33918 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33919 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33920 & ABS(A00U-A20U)**2
33922 FACZZ=FACZZ*WIDS(23,1)
33924 DO 300 I=MMIN1,MMAX1
33925 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
33926 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33927 DO 290 J=MMIN2,MMAX2
33928 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
33929 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33930 IF(EI*EJ.GT.0D0) GOTO 290
33935 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
33940 ELSEIF(ISUB.EQ.77) THEN
33941 C...W+/- + W+/- -> W+/- + W+/-
33942 IF(SH.LE.4.01D0*SQMW) GOTO 340
33944 IF(MSTP(46).LE.2) THEN
33945 C...Exact scattering ME:s for on-mass-shell gauge bosons
33946 BE2=1D0-4D0*SQMW/SH
33950 TH=-0.5D0*SH*BE2*(1D0-CTH)
33951 UH=-0.5D0*SH*BE2*(1D0+CTH)
33952 IF(MAX(TH,UH).GT.-1D0) GOTO 340
33954 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33955 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33957 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33958 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33960 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33961 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33962 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
33965 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
33967 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
33968 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
33969 ATGRE=0.5D0*XW*SH/TH*TGZANG
33971 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
33973 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
33974 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
33975 AUGRE=0.5D0*XW*SH/UH*UGZANG
33977 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
33979 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
33981 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
33983 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33985 IF(MSTP(46).LE.0) THEN
33990 ELSEIF(MSTP(46).EQ.1) THEN
33991 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33992 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33993 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33994 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33996 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33997 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33998 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33999 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
34001 AWWA2=AWWARE**2+AWWAIM**2
34002 AWWS2=AWWSRE**2+AWWSIM**2
34005 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34006 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
34007 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
34008 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
34011 DO 330 I=MMIN1,MMAX1
34012 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
34013 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34014 DO 320 J=MMIN2,MMAX2
34015 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
34016 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34017 IF(EI*EJ.LT.0D0) THEN
34019 IF(MSTP(45).EQ.1) GOTO 320
34020 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
34021 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
34024 IF(MSTP(45).EQ.2) GOTO 320
34025 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
34026 IF(MSTP(46).GE.3) FACWW=FWWS
34027 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
34028 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
34034 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
34035 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
34041 ELSEIF(ISUB.LE.120) THEN
34042 IF(ISUB.EQ.102) THEN
34043 C...g + g -> h0 (or H0, or A0)
34044 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34046 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34047 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34048 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34050 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34051 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34053 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34054 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34055 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34057 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34058 & '(PYSGHG:) did not find Higgs -> g g channel')
34061 HI=SHR*WDTP(13)/32D0
34063 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
34068 SIGH(NCHN)=HI*FACBW*HF
34071 ELSEIF(ISUB.EQ.103) THEN
34072 C...gamma + gamma -> h0 (or H0, or A0)
34073 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34075 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34076 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34077 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34079 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34080 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34082 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34083 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
34084 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
34086 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
34087 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
34090 HI=SHR*WDTP(14)*2D0
34092 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
34097 SIGH(NCHN)=HI*FACBW*HF
34100 ELSEIF(ISUB.EQ.110) THEN
34101 C...f + fbar -> gamma + h0
34102 THUH=MAX(TH*UH,SH*CKIN(3)**2)
34103 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
34104 FACHG=FACHG*WIDS(KFHIGG,2)
34105 C...Calculate loop contributions for intermediate gamma* and Z0
34106 CIGTOT=DCMPLX(0D0,0D0)
34107 CIZTOT=DCMPLX(0D0,0D0)
34110 IF(J.LE.2*MSTP(1)) THEN
34113 AJ=SIGN(1D0,EJ+0.1D0)
34115 BALP=SQM4/(2D0*PMAS(J,1))**2
34116 BBET=SH/(2D0*PMAS(J,1))**2
34117 ELSEIF(J.LE.3*MSTP(1)) THEN
34119 JL=2*(J-2*MSTP(1))-1
34120 EJ=KCHG(10+JL,1)/3D0
34121 AJ=SIGN(1D0,EJ+0.1D0)
34123 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
34124 BBET=SH/(2D0*PMAS(10+JL,1))**2
34126 BALP=SQM4/(2D0*PMAS(24,1))**2
34127 BBET=SH/(2D0*PMAS(24,1))**2
34129 BABI=1D0/(BALP-BBET)
34130 IF(BALP.LT.1D0) THEN
34131 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
34134 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
34135 & -DBLE(0.5D0*PARU(1)))
34138 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
34139 IF(BBET.LT.1D0) THEN
34140 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
34143 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
34144 & -DBLE(0.5D0*PARU(1)))
34147 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
34148 IF(J.LE.3*MSTP(1)) THEN
34149 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
34150 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
34151 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
34152 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
34155 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
34156 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
34157 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
34158 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
34159 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
34160 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
34164 CIGTOT=CIGTOT/DBLE(SH)
34165 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
34166 C...Loop over initial flavours
34167 DO 380 I=MMINA,MMAXA
34168 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
34169 EI=KCHG(IABS(I),1)/3D0
34173 IF(IABS(I).LE.10) FCOI=FACA/3D0
34178 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
34179 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
34182 ELSEIF(ISUB.EQ.111) THEN
34183 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
34184 IF(MSTP(38).NE.0) THEN
34185 C...Simple case: only do gg <-> h exactly.
34186 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34187 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34188 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34190 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34191 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34192 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34194 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34195 & '(PYSGHG:) did not find Higgs -> g g channel')
34196 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
34197 & (TH**2+UH**2)/(SH*SQM4)
34199 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
34200 & (TH**2+UH**2)/(SH*SQM4)
34202 C...Propagators: as simulated in PYOFSH and as desired
34203 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34204 GMMHC=SQRT(SQM4)*WDTP(0)
34205 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34206 & ((SQM4-SQMH)**2+GMMHC**2)
34207 FACGH=FACGH*HBW4C/HBW4
34209 C...Messy case: do full loop integrals
34212 DO 390 I=1,2*MSTP(1)
34216 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34217 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34218 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34219 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34220 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
34221 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
34222 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
34223 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
34225 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34226 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
34227 FACGH=FACGH*WIDS(25,2)
34229 DO 400 I=MMINA,MMAXA
34230 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34231 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34239 ELSEIF(ISUB.EQ.112) THEN
34240 C...f + g -> f + h0 (q + g -> q + h0 only)
34241 IF(MSTP(38).NE.0) THEN
34242 C...Simple case: only do gg <-> h exactly.
34243 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34244 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34245 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34247 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34248 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34249 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34251 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34252 & '(PYSGHG:) did not find Higgs -> g g channel')
34253 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
34254 & (SH**2+UH**2)/(-TH*SQM4)
34256 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
34257 & (SH**2+UH**2)/(-TH*SQM4)
34259 C...Propagators: as simulated in PYOFSH and as desired
34260 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34261 GMMHC=SQRT(SQM4)*WDTP(0)
34262 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34263 & ((SQM4-SQMH)**2+GMMHC**2)
34264 FACQH=FACQH*HBW4C/HBW4
34266 C...Messy case: do full loop integrals
34269 DO 410 I=1,2*MSTP(1)
34273 CALL PYWAUX(1,EPST,W1TR,W1TI)
34274 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34275 CALL PYWAUX(2,EPST,W2TR,W2TI)
34276 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34277 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
34278 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
34279 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
34280 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
34282 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34283 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
34284 FACQH=FACQH*WIDS(25,2)
34286 DO 430 I=MMINA,MMAXA
34287 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
34289 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
34290 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
34293 ISIG(NCHN,3-ISDE)=21
34299 ELSEIF(ISUB.EQ.113) THEN
34300 C...g + g -> g + h0
34301 IF(MSTP(38).NE.0) THEN
34302 C...Simple case: only do gg <-> h exactly.
34303 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34304 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34305 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34307 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34308 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34309 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34311 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34312 & '(PYSGHG:) did not find Higgs -> g g channel')
34313 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
34314 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34316 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
34317 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34319 C...Propagators: as simulated in PYOFSH and as desired
34320 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34321 GMMHC=SQRT(SQM4)*WDTP(0)
34322 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34323 & ((SQM4-SQMH)**2+GMMHC**2)
34324 FACGH=FACGH*HBW4C/HBW4
34326 C...Messy case: do full loop integrals
34335 DO 440 I=1,2*MSTP(1)
34341 IF(EPSH.LT.1D-6) GOTO 440
34342 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34343 CALL PYWAUX(1,EPST,W1TR,W1TI)
34344 CALL PYWAUX(1,EPSU,W1UR,W1UI)
34345 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34346 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34347 CALL PYWAUX(2,EPST,W2TR,W2TI)
34348 CALL PYWAUX(2,EPSU,W2UR,W2UI)
34349 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34350 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
34351 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
34352 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
34353 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
34354 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
34355 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
34356 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
34357 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
34358 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
34359 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
34360 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
34361 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
34362 W3STUR=YHSTUR-Y3STUR-Y3UTSR
34363 W3STUI=YHSTUI-Y3STUI-Y3UTSI
34364 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
34365 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
34366 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
34367 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
34368 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
34369 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
34370 W3USTR=YHUSTR-Y3USTR-Y3TSUR
34371 W3USTI=YHUSTI-Y3USTI-Y3TSUI
34372 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
34373 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
34374 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
34375 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
34376 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
34377 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
34378 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
34379 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
34380 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
34381 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
34382 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
34383 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
34384 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
34385 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
34386 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
34387 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
34388 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
34389 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
34390 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
34391 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
34392 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
34393 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
34394 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
34395 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
34396 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
34397 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
34398 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
34399 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
34400 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
34401 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
34402 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
34403 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
34404 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
34405 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
34406 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
34407 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
34408 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
34409 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
34410 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
34411 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
34412 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
34413 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
34414 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
34415 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
34416 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
34417 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
34418 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
34419 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
34420 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
34421 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
34422 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
34423 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
34424 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
34425 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
34426 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
34427 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
34428 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
34429 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
34430 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
34431 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
34432 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
34433 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
34434 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34435 & (W2SR-W2HR+W3STUR))
34436 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
34437 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34438 & (W2TR-W2HR+W3TUSR))
34439 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
34440 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34441 & (W2UR-W2HR+W3USTR))
34442 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
34443 A2STUR=A2STUR+B2STUR+B2SUTR
34444 A2STUI=A2STUI+B2STUI+B2SUTI
34445 A2USTR=A2USTR+B2USTR+B2UTSR
34446 A2USTI=A2USTI+B2USTI+B2UTSI
34447 A2TUSR=A2TUSR+B2TUSR+B2TSUR
34448 A2TUSI=A2TUSI+B2TUSI+B2TSUI
34449 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
34450 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
34452 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
34453 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
34454 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
34455 FACGH=FACGH*WIDS(25,2)
34457 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
34466 ELSEIF(ISUB.LE.170) THEN
34467 IF(ISUB.EQ.121) THEN
34468 C...g + g -> Q + Qbar + h0
34469 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
34472 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
34473 & (0.5D0*PMF/PMAS(24,1))**2
34475 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
34477 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34479 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34480 IF(IA.GT.10) IKFI=3
34481 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
34482 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34483 FACQQH=FACQQH/(1D0+RMSS(41))**2
34484 IF(IHIGG.NE.3) THEN
34485 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34486 & PARU(151+10*IHIGG))**2
34490 CALL PYQQBH(WTQQBH)
34491 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34493 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34494 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34495 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34501 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
34504 ELSEIF(ISUB.EQ.122) THEN
34505 C...q + qbar -> Q + Qbar + h0
34508 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
34509 & (0.5D0*PMF/PMAS(24,1))**2
34511 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
34513 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34515 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34516 IF(IA.GT.10) IKFI=3
34517 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
34518 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34519 FACQQH=FACQQH/(1D0+RMSS(41))**2
34520 IF(IHIGG.NE.3) THEN
34521 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34522 & PARU(151+10*IHIGG))**2
34526 CALL PYQQBH(WTQQBH)
34527 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34529 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34530 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34531 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34533 DO 470 I=MMINA,MMAXA
34534 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34535 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
34540 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
34543 ELSEIF(ISUB.EQ.123) THEN
34544 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
34546 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
34547 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
34548 & PARU(154+10*IHIGG)**2
34549 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
34550 & (VINT(216)-VINT(209)**2))**2
34551 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
34552 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
34553 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34555 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34556 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34557 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34559 DO 490 I=MMIN1,MMAX1
34560 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
34562 DO 480 J=MMIN2,MMAX2
34563 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
34565 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
34566 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
34568 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
34569 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
34571 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
34572 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
34577 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
34581 ELSEIF(ISUB.EQ.124) THEN
34582 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
34584 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
34585 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
34586 & PARU(155+10*IHIGG)**2
34587 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
34588 & (VINT(216)-VINT(209)**2))**2
34589 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
34590 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34592 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34593 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34594 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34596 DO 510 I=MMIN1,MMAX1
34597 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
34598 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34599 DO 500 J=MMIN2,MMAX2
34600 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
34601 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34602 IF(EI*EJ.GT.0D0) GOTO 500
34603 FACLR=VINT(180+I)*VINT(180+J)
34608 SIGH(NCHN)=FACLR*FACWW*FACBW
34612 ELSEIF(ISUB.EQ.143) THEN
34613 C...f + fbar' -> H+/-
34614 SQMHC=PMAS(37,1)**2
34615 CALL PYWIDT(37,SH,WDTP,WDTE)
34617 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
34618 HP=AEM/(8D0*XW)*SH/SQMW*SH
34619 DO 530 I=MMIN1,MMAX1
34620 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
34622 IM=(MOD(IA,10)+1)/2
34623 DO 520 J=MMIN2,MMAX2
34624 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
34626 JM=(MOD(JA,10)+1)/2
34627 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
34628 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34630 IF(MOD(IA,2).EQ.0) THEN
34637 RML=PYMRUN(IL,SH)**2/SH
34638 RMU=PYMRUN(IU,SH)**2/SH
34639 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
34640 IF(IA.LE.10) HI=HI*FACA/3D0
34641 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
34642 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
34647 SIGH(NCHN)=HI*FACBW*HF
34651 ELSEIF(ISUB.EQ.161) THEN
34652 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
34653 C...(choice of only b and t to avoid kinematics problems)
34654 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
34655 C...H propagator: as simulated in PYOFSH and as desired
34656 SQMHC=PMAS(37,1)**2
34657 GMMHC=PMAS(37,1)*PMAS(37,2)
34658 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
34659 CALL PYWIDT(37,SQM4,WDTP,WDTE)
34660 GMMHCC=SQRT(SQM4)*WDTP(0)
34661 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
34662 FHCQ=FHCQ*HBW4C/HBW4
34664 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
34665 DO 550 I=MMINA,MMAXA
34667 IF(IA.NE.5) GOTO 550
34668 SQML=PYMRUN(IA,Q2RM)**2
34670 SQMQ=PYMRUN(IUA,Q2RM)**2
34671 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
34672 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
34673 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
34674 & (SQMHC-SQMQ-SH)/SH)
34675 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
34677 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
34678 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
34681 ISIG(NCHN,3-ISDE)=21
34683 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
34684 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
34689 ELSEIF(ISUB.LE.402) THEN
34690 IF(ISUB.EQ.401) THEN
34691 C... g + g -> t + bbar + H-
34692 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
34695 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34697 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
34698 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34704 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
34705 c Since we don't know yet if H+ or H-, assume H+
34706 c when calculating suppression due to closed channels.
34707 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
34708 IF(ABS(WIDS(37,2)-WIDS(37,3))
34709 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
34710 & ABS(WIDS(6,2)-WIDS(6,3))
34711 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
34712 WRITE(*,*)'Error: Process 401 cannot handle different'
34713 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34714 WRITE(*,*)'Execution stopped.'
34719 ELSEIF(ISUB.EQ.402) THEN
34720 C... q + qbar -> t + bbar + H-
34723 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34725 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
34726 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34728 DO 570 I=MMINA,MMAXA
34729 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34730 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
34735 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
34736 c Since we don't know yet if H+ or H-, assume H+
34737 c when calculating suppression due to closed channels.
34738 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
34739 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
34741 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
34743 WRITE(*,*)'Error: Process 402 cannot handle different'
34744 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34745 WRITE(*,*)'Execution stopped.'
34755 C*********************************************************************
34758 C...Subprocess cross sections for SUSY processes,
34759 C...including Higgs pair production.
34760 C...Auxiliary to PYSIGH.
34762 SUBROUTINE PYSGSU(NCHN,SIGS)
34764 C...Double precision and integer declarations
34765 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34766 IMPLICIT INTEGER(I-N)
34767 INTEGER PYK,PYCHGE,PYCOMP
34768 C...Parameter statement to help give large particle numbers.
34769 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34770 &KEXCIT=4000000,KDIMEN=5000000)
34772 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34774 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34775 COMMON/PYINT1/MINT(400),VINT(400)
34776 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
34777 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
34778 COMMON/PYINT4/MWID(500),WIDS(500,5)
34779 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34780 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34781 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
34782 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
34783 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
34784 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
34785 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
34786 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
34787 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
34788 C...Local arrays and complex variables
34789 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
34790 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
34791 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
34792 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
34795 C...Z and W width, combinations of weak mixing angle
34799 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
34801 C...Convert almost equivalent SUSY processes into each other
34802 C...Extract differences in flavours and couplings
34804 C...Sleptons and sneutrinos
34805 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
34806 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34809 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
34810 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34813 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
34814 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34816 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
34817 IF(ISUB.EQ.210) THEN
34819 ELSEIF(ISUB.EQ.211) THEN
34821 ELSEIF(ISUB.EQ.212) THEN
34825 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
34826 IF(ISUB.EQ.213) THEN
34827 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34829 ELSEIF(ISUB.EQ.214) THEN
34836 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
34837 IF(ISUB.EQ.216) THEN
34840 ELSEIF(ISUB.EQ.217) THEN
34843 ELSEIF(ISUB.EQ.218) THEN
34846 ELSEIF(ISUB.EQ.219) THEN
34849 ELSEIF(ISUB.EQ.220) THEN
34852 ELSEIF(ISUB.EQ.221) THEN
34855 ELSEIF(ISUB.EQ.222) THEN
34858 ELSEIF(ISUB.EQ.223) THEN
34861 ELSEIF(ISUB.EQ.224) THEN
34864 ELSEIF(ISUB.EQ.225) THEN
34871 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
34872 IF(ISUB.EQ.226) THEN
34875 ELSEIF(ISUB.EQ.227) THEN
34878 ELSEIF(ISUB.EQ.228) THEN
34884 C...Neutralino + chargino
34885 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
34886 IF(ISUB.EQ.229) THEN
34889 ELSEIF(ISUB.EQ.230) THEN
34892 ELSEIF(ISUB.EQ.231) THEN
34895 ELSEIF(ISUB.EQ.232) THEN
34898 ELSEIF(ISUB.EQ.233) THEN
34901 ELSEIF(ISUB.EQ.234) THEN
34904 ELSEIF(ISUB.EQ.235) THEN
34907 ELSEIF(ISUB.EQ.236) THEN
34913 C...Gluino + neutralino
34914 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
34915 IF(ISUB.EQ.237) THEN
34917 ELSEIF(ISUB.EQ.238) THEN
34919 ELSEIF(ISUB.EQ.239) THEN
34921 ELSEIF(ISUB.EQ.240) THEN
34926 C...Gluino + chargino
34927 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
34928 IF(ISUB.EQ.241) THEN
34930 ELSEIF(ISUB.EQ.242) THEN
34935 C...Squark + neutralino
34936 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
34938 IF(MOD(ISUB,2).NE.0) ILR=1
34939 IF(ISUB.LE.247) THEN
34941 ELSEIF(ISUB.LE.249) THEN
34943 ELSEIF(ISUB.LE.251) THEN
34945 ELSEIF(ISUB.LE.253) THEN
34951 C...Squark + chargino
34952 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
34953 IF(ISUB.LE.255) THEN
34955 ELSEIF(ISUB.LE.257) THEN
34958 IF(MOD(ISUB,2).EQ.0) THEN
34966 C...Squark + gluino
34967 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
34972 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
34974 IF(ISUB.EQ.262) ILR=1
34976 ELSEIF(ISUB.EQ.265) THEN
34980 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
34982 IF(ISUB.LE.273) THEN
34983 IF(ISUB.EQ.273) ILR=1
34986 ELSEIF(ISUB.LE.276) THEN
34987 IF(ISUB.EQ.276) ILR=1
34990 ELSEIF(ISUB.LE.278) THEN
34991 IF(ISUB.EQ.278) ILR=1
34995 IF(ISUB.EQ.280) ILR=1
35000 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
35002 IF(ISUB.LE.283) THEN
35003 IF(ISUB.EQ.283) ILR=1
35006 ELSEIF(ISUB.LE.286) THEN
35007 IF(ISUB.EQ.286) ILR=1
35010 ELSEIF(ISUB.LE.288) THEN
35011 IF(ISUB.EQ.288) ILR=1
35014 ELSEIF(ISUB.LE.290) THEN
35015 IF(ISUB.EQ.290) ILR=1
35018 ELSEIF(ISUB.LE.293) THEN
35019 IF(ISUB.EQ.293) ILR=1
35022 ELSEIF(ISUB.EQ.296) THEN
35026 C...Squark + gluino
35027 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
35032 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
35033 IF(ISUB.EQ.297) THEN
35034 RKF=.5D0*PARU(195)**2
35035 ELSEIF(ISUB.EQ.298) THEN
35036 RKF=.5D0*(1D0-PARU(195)**2)
35040 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
35041 IF(ISUB.EQ.299) THEN
35044 ELSEIF(ISUB.EQ.300) THEN
35050 ELSEIF(ISUB.EQ.301) THEN
35056 C...Supersymmetric processes - all of type 2 -> 2 :
35057 C...correct final-state Breit-Wigners from fixed to running width.
35058 IF(MSTP(42).GT.0) THEN
35060 KFLW=KFPR(ISUBSV,I)
35062 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
35063 IF(I.EQ.1) SQMI=SQM3
35064 IF(I.EQ.2) SQMI=SQM4
35065 SQMS=PMAS(KCW,1)**2
35066 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
35067 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
35068 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
35069 GMMI=SQRT(SQMI)*WDTP(0)
35070 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
35071 COMFAC=COMFAC*(HBWI/HBWS)
35075 C...Differential cross section expressions.
35077 IF(ISUB.LE.210) THEN
35078 IF(ISUB.EQ.201) THEN
35079 C...f + fbar -> e_L + e_Lbar
35080 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35081 DO 130 I=MMIN1,MMAX1
35083 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
35085 TT3I=SIGN(1D0,EI+1D-6)/2D0
35089 C...Color factor for e+ e-
35090 IF(IA.GE.11) FCOL=3D0
35091 IF(ISUBSV.EQ.301) THEN
35094 ELSEIF(ILR.EQ.1) THEN
35095 A1=SFMIX(KFID,3)**2
35096 A2=SFMIX(KFID,4)**2
35097 ELSEIF(ILR.EQ.0) THEN
35098 A1=SFMIX(KFID,1)**2
35099 A2=SFMIX(KFID,2)**2
35101 XLQ=(TT3J-EJ*XW)*A1
35105 TAA=(EI*EJ)**2*(POLL+POLR)
35106 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
35107 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
35108 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
35109 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35113 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35119 DK=1D0/(TH-SMZ(II)**2)
35120 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35122 FREK=FAC2*TANW*EI*ZMIX(II,1)
35123 TNN1=TNN1+FLEK**2*DK
35124 TNN2=TNN2+FREK**2*DK
35126 DL=1D0/(TH-SMZ(JJ)**2)
35127 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35129 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35130 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35133 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
35134 & A2**2*TNN2**2*POLR)
35135 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
35136 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
35137 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
35138 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
35139 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35142 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
35145 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
35146 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
35147 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
35152 SIGH(NCHN)=FACQQ1+FACQQ2
35155 ELSEIF(ISUB.EQ.203) THEN
35156 C...f + fbar -> e_L + e_Rbar
35157 DO 160 I=MMIN1,MMAX1
35159 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
35160 EI=KCHG(IABS(I),1)/3D0
35161 TT3I=SIGN(1D0,EI)/2D0
35165 C...Color factor for e+ e-
35166 IF(IA.GE.11) FCOL=3D0
35167 A1=SFMIX(KFID,1)**2
35168 A2=SFMIX(KFID,2)**2
35173 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
35174 & /XW**2/XW1**2*A1*A2
35175 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35180 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35186 DK=1D0/(TH-SMZ(II)**2)
35187 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35189 FREK=FAC2*TANW*EI*ZMIX(II,1)
35190 TNN1=TNN1+FLEK**2*DK
35191 TNN2=TNN2+FREK**2*DK
35193 DL=1D0/(TH-SMZ(JJ)**2)
35194 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35196 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35197 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35200 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
35201 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
35202 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
35203 TZN=(UH*TH-SQM3*SQM4)*A1*A2
35204 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
35205 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35208 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
35209 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
35210 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
35216 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35217 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35222 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35223 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35226 ELSEIF(ISUB.EQ.210) THEN
35227 C...q + qbar' -> W*- > ~l_L + ~nu_L
35228 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
35229 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
35230 DO 180 I=MMIN1,MMAX1
35232 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
35233 DO 170 J=MMIN2,MMAX2
35235 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
35236 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
35238 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35239 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35241 IF(KCHSUM.LT.0) KCHW=3
35246 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
35247 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35248 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35250 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35251 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35253 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
35258 ELSEIF(ISUB.LE.220) THEN
35259 IF(ISUB.EQ.213) THEN
35260 C...f + fbar -> ~nu_L + ~nu_Lbar
35261 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
35262 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35263 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35265 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35268 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
35271 DO 190 I=MMIN1,MMAX1
35273 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
35276 C...Color factor for e+ e-
35277 IF(IA.GE.11) FCOL=3D0
35278 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
35282 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
35283 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
35286 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
35288 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
35294 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
35295 & *AEM**2*FCOL/3D0/XW**2
35298 ELSEIF(ISUB.EQ.216) THEN
35299 C...q + qbar -> ~chi0_1 + ~chi0_1
35300 IF(IZID1.EQ.IZID2) THEN
35301 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35303 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35304 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35306 FACXX=COMFAC*AEM**2/3D0/XW**2
35307 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
35310 WU2 = (UH-ZM12)*(UH-ZM22)
35311 WT2 = (TH-ZM12)*(TH-ZM22)
35312 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
35313 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35314 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35316 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
35317 IF(IZID2.NE.IZID1) THEN
35318 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35321 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
35322 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
35324 DO 210 I=MMINA,MMAXA
35325 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
35326 EI=KCHG(IABS(I),1)/3D0
35327 T3I=SIGN(1D0,EI+1D-6)/2D0
35328 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
35329 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
35330 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
35331 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
35332 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
35333 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
35334 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
35336 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
35337 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
35338 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
35340 IF(IABS(I).GE.11) FCOL=3D0
35341 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
35342 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
35343 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
35344 & QRL*DCONJG(QRR)*POLR)*WS2
35349 SIGH(NCHN)=FACXX*FACGG1*FCOL
35353 ELSEIF(ISUB.LE.230) THEN
35354 IF(ISUB.EQ.226) THEN
35355 C...f + fbar -> ~chi+_1 + ~chi-_1
35356 FACXX=COMFAC*AEM**2/3D0
35359 WU2 = (UH-ZM12)*(UH-ZM22)
35360 WT2 = (TH-ZM12)*(TH-ZM22)
35361 WS2 = SMW(IZID1)*SMW(IZID2)*SH
35362 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35363 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35365 IF(IZID1.EQ.IZID2) DIFF=1D0
35367 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
35368 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
35369 IF(IZID2.NE.IZID1) THEN
35370 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
35371 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
35374 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
35375 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
35376 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
35377 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
35378 DO 230 I=MMINA,MMAXA
35379 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
35380 EI=KCHG(IABS(I),1)/3D0
35381 T3I=SIGN(1D0,EI+1D-6)/2D0
35382 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
35383 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
35384 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
35385 IF(MOD(I,2).EQ.0) THEN
35386 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
35387 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
35388 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
35389 & DCMPLX(T3I/XW/(TH-XML2))
35391 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
35392 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
35393 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
35394 & DCMPLX(T3I/XW/(TH-XML2))
35397 IF(IABS(I).GE.11) FCOL=3D0
35398 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
35399 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
35400 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
35401 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
35406 IF(IZID1.EQ.IZID2) THEN
35407 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35409 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35410 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35415 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35416 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35420 ELSEIF(ISUB.EQ.229) THEN
35421 C...q + qbar' -> ~chi0_1 + ~chi+-_1
35422 FACXX=COMFAC*AEM**2/6D0/XW**2
35425 WU2 = (UH-ZM12)*(UH-ZM22)
35426 WT2 = (TH-ZM12)*(TH-ZM22)
35427 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
35428 RT2I = 1D0/SQRT(2D0)
35429 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
35430 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
35432 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
35433 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
35436 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35438 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
35439 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
35440 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
35441 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
35443 DO 270 I=MMIN1,MMAX1
35445 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
35447 T3I=SIGN(1D0,EI+1D-6)/2D0
35448 DO 260 J=MMIN2,MMAX2
35450 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
35451 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
35453 T3J=SIGN(1D0,EJ+1D-6)/2D0
35455 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35456 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35458 IF(KCHSUM.LT.0) KCHW=3
35459 IF(MOD(IA,2).EQ.0) THEN
35460 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
35461 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
35462 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
35463 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
35464 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
35465 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
35468 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
35469 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
35470 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
35471 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
35472 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
35473 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
35476 ZINTR=DBLE(QLR*DCONJG(QLL))
35477 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
35483 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35484 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35489 ELSEIF(ISUB.LE.240) THEN
35490 IF(ISUB.EQ.237) THEN
35491 C...q + qbar -> gluino + ~chi0_1
35492 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35493 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35495 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
35498 DO 280 I=MMINA,MMAXA
35499 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
35500 EI=KCHG(IABS(I),1)/3D0
35502 XLQC = -TANW*EI*ZMIX(IZID,1)
35503 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
35504 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
35507 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
35508 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
35509 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
35510 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
35511 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
35512 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
35513 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
35514 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
35515 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
35516 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
35521 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
35525 ELSEIF(ISUB.LE.250) THEN
35526 IF(ISUB.EQ.241) THEN
35527 C...q + qbar' -> ~chi+-_1 + gluino
35528 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
35531 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
35532 FAC0=UMIX(IZID,1)**2
35533 FAC1=VMIX(IZID,1)**2
35534 DO 300 I=MMIN1,MMAX1
35536 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
35537 DO 290 J=MMIN2,MMAX2
35539 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
35540 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
35542 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35543 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35545 IF(KCHSUM.LT.0) KCHW=3
35546 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
35547 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
35548 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
35549 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
35550 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
35551 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
35552 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
35553 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
35554 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
35555 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
35556 & SH/(TH-XMU2)/(UH-XMD2))/2D0
35561 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
35562 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35563 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35567 ELSEIF(ISUB.EQ.243) THEN
35568 C...q + qbar -> gluino + gluino
35569 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35572 DO 310 I=MMINA,MMAXA
35573 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35574 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
35576 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
35577 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
35578 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
35579 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
35580 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
35581 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
35582 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
35583 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
35584 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
35585 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
35586 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
35587 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
35591 C...1/2 for identical particles
35592 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
35595 ELSEIF(ISUB.EQ.244) THEN
35596 C...g + g -> gluino + gluino
35597 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35600 FACQQ1=COMFAC*AS**2*9D0/4D0*(
35601 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
35602 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
35603 FACQQ2=COMFAC*AS**2*9D0/4D0*(
35604 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
35605 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
35606 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
35607 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
35608 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
35613 SIGH(NCHN)=FACQQ1/2D0
35618 SIGH(NCHN)=FACQQ2/2D0
35623 SIGH(NCHN)=FACQQ3/2D0
35626 ELSEIF(ISUB.EQ.246) THEN
35627 C...g + q_j -> ~chi0_1 + ~q_j
35628 FAC0=COMFAC*AS*AEM/6D0/XW
35631 FACZQ0=FAC0*( (ZM2-TH)/SH +
35632 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
35633 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
35634 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35635 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
35636 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
35637 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
35638 EI=KCHG(IABS(I),1)/3D0
35640 XRQZ = -TANW*EI*ZMIX(IZID,1)
35641 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
35642 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
35644 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
35646 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
35652 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
35653 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
35656 ISIG(NCHN,3-ISDE)=21
35658 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35659 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35664 ELSEIF(ISUB.LE.260) THEN
35665 IF(ISUB.EQ.254) THEN
35666 C...g + q_j -> ~chi1_1 + ~q_i
35667 FAC0=COMFAC*AS*AEM/12D0/XW
35672 FACZQ0=FAC0*( (ZM2-TH)/SH +
35673 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
35674 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
35675 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
35676 IF(MOD(KFNSQ1,2).EQ.0) THEN
35683 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
35684 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
35685 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
35687 IF(MOD(IA,2).EQ.0) THEN
35692 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
35696 IF(I.LT.0) KCHWQ=5-KCHW
35698 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
35699 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
35702 ISIG(NCHN,3-ISDE)=21
35704 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35705 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
35709 ELSEIF(ISUB.EQ.258) THEN
35710 C...g + q_j -> gluino + ~q_i
35717 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
35718 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
35719 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
35720 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
35721 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
35723 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
35724 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
35725 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
35727 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
35728 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
35729 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35730 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
35731 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
35732 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
35735 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35736 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35738 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
35739 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
35742 ISIG(NCHN,3-ISDE)=21
35744 SIGH(NCHN)=FACQG1*FACSEL
35747 ISIG(NCHN,3-ISDE)=21
35749 SIGH(NCHN)=FACQG2*FACSEL
35754 ELSEIF(ISUB.LE.270) THEN
35755 IF(ISUB.EQ.261) THEN
35756 C...q_i + q_ibar -> ~t_1 + ~t_1bar
35757 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
35758 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35759 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35761 DO 390 I=MMIN1,MMAX1
35763 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
35764 IF(IA.GE.11.AND.IA.LE.18) THEN
35766 EJ=KCHG(KFNSQ,1)/3D0
35767 T3I=SIGN(1D0,EI)/2D0
35768 T3J=SIGN(1D0,EJ)/2D0
35769 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
35770 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
35771 XLF=2D0*(T3I-EI*XW)
35773 TAA=0.5D0*(EI*EJ)**2
35774 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35775 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35776 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35777 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35778 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35784 SIGH(NCHN)=FACQQ1*FAC0
35787 ELSEIF(ISUB.EQ.263) THEN
35788 C...f + fbar -> ~t1 + ~t2bar
35789 DO 400 I=MMIN1,MMAX1
35791 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
35792 EI=KCHG(IABS(I),1)/3D0
35793 TT3I=SIGN(1D0,EI)/2D0
35797 C...Color factor for e+ e-
35798 IF(IA.GE.11) FCOL=3D0
35799 XLQ=2D0*(TT3J-EJ*XW)
35801 XLF=2D0*(TT3I-EI*XW)
35803 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
35804 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
35805 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35806 C...Factor of 2 for t1 t2bar + t2 t1bar
35807 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
35808 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
35813 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35814 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35819 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35820 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35823 ELSEIF(ISUB.EQ.264) THEN
35824 C...g + g -> ~t_1 + ~t_1bar
35827 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
35828 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35829 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
35830 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
35831 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
35845 ELSEIF(ISUB.LE.280) THEN
35846 IF(ISUB.EQ.271) THEN
35847 C...q + q' -> ~q + ~q' (~g exchange)
35848 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35857 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
35858 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
35861 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
35862 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
35863 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
35866 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35867 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35868 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
35869 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
35871 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
35874 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35875 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
35877 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
35878 IF(I*J.LT.0) GOTO 420
35883 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35884 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35887 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
35888 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35890 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
35891 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35892 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35899 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
35900 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35902 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
35903 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35904 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35910 ELSEIF(ISUB.EQ.274) THEN
35911 C...q + qbar' -> ~q + ~qbar'
35912 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35916 C...Mrenna...Normalization.and.1/XMT
35917 FACQQ1=COMFAC*AS**2*2D0/9D0*(
35918 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
35919 FACQQB=COMFAC*AS**2*4D0/9D0*(
35920 & (UH*TH-SQM3*SQM4)/SH2 )
35921 FACQQI=-COMFAC*AS**2*4D0/27D0*(
35922 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
35923 FACQQB=FACQQB+FACQQ1+FACQQI
35925 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
35928 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35929 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35930 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
35931 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
35933 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
35936 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35937 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
35939 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
35940 IF(I*J.GT.0) GOTO 440
35945 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35946 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
35947 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
35948 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35952 ELSEIF(ISUB.EQ.277) THEN
35953 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
35954 C...if i .eq. j covered in 274
35955 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
35956 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35958 DO 460 I=MMIN1,MMAX1
35960 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
35961 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
35962 IF(IA.EQ.KFNSQ) GOTO 460
35963 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
35965 EJ=KCHG(KFNSQ,1)/3D0
35967 T3I=SIGN(1D0,EI)/2D0
35969 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
35970 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
35972 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
35973 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
35975 XLF=2D0*(T3I-EI*XW)
35982 TAA=0.5D0*(EI*EJ)**2
35983 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35984 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35985 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35986 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35987 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35988 ELSEIF(IA.LE.6) THEN
35989 FAC0=AS**2*8D0/9D0/2D0
35995 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35998 ELSEIF(ISUB.EQ.279) THEN
35999 C...g + g -> ~q_j + ~q_jbar
36002 C...5=RKF because ~t ~tbar treated separately
36003 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
36004 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
36005 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
36006 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
36011 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36016 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36026 C*********************************************************************
36029 C...Subprocess cross sections for Technicolor processes.
36030 C...Auxiliary to PYSIGH.
36032 SUBROUTINE PYSGTC(NCHN,SIGS)
36034 C...Double precision and integer declarations
36035 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36036 IMPLICIT INTEGER(I-N)
36037 INTEGER PYK,PYCHGE,PYCOMP
36038 C...Parameter statement to help give large particle numbers.
36039 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36040 &KEXCIT=4000000,KDIMEN=5000000)
36042 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36043 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36044 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36045 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36046 COMMON/PYINT1/MINT(400),VINT(400)
36047 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36048 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36049 COMMON/PYINT4/MWID(500),WIDS(500,5)
36050 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36051 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36052 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36053 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36054 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36055 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36056 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36057 C...Local arrays and complex variables
36058 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36059 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
36060 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
36061 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
36062 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
36063 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
36064 COMPLEX*16 DVVS,DVVT,DVVU
36067 C...Combinations of weak mixing angle.
36069 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
36071 C...Convert almost equivalent technicolor processes into
36072 C...a few basic processes, and set distinguishing parameters.
36073 IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
36076 SN2W=2D0*SQRT(XW*XW1)
36079 CSXI=COS(ASIN(RTCM(3)))
36080 CSXIP=COS(ASIN(RTCM(4)))
36081 QUPD=2D0*RTCM(2)-1D0
36082 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
36093 C... rho_tc0, etc. -> W_L W_L, W_L W_T
36094 IF(ISUB.EQ.361) THEN
36098 AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36099 ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36100 VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
36101 C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
36102 AXGP = SQRT(2D0)*AXGP
36103 ARGP = SQRT(2D0)*ARGP
36104 VOGP = SQRT(2D0)*VOGP
36105 C... rho_tc0 -> W_L pi_tc-
36106 ELSEIF(ISUB.EQ.362) THEN
36110 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36112 ELSEIF(ISUB.EQ.363) THEN
36116 CAB2=(1D0-RTCM(3)**2)**2
36117 C... rho_tc0/omega_tc -> gamma pi_tc
36118 ELSEIF(ISUB.EQ.364) THEN
36125 VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36127 ELSEIF(ISUB.EQ.365) THEN
36131 VRGP=CSXIP/RTCM(12)
36133 VAGP=2D0*Q2UD*CSXIP
36134 VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
36136 ELSEIF(ISUB.EQ.366) THEN
36140 VOGP=CSXI*CT2W/RTCM(12)
36141 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36142 VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36143 VZGP=-QUPD*CSXI*CS2W/XW1
36145 ELSEIF(ISUB.EQ.367) THEN
36149 C...RTCM(48) is the M_V for the techni-a
36150 VXGP=-CSXIP/SN2W/RTCM(48)
36151 VRGP=CSXIP*CT2W/RTCM(12)
36152 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
36153 VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
36154 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
36156 ELSEIF(ISUB.EQ.368) THEN
36160 C...RTCM(49) is the M_A for the techni-a
36161 AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
36162 VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
36163 ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
36164 VAGP=QUPD*CSXI/(2D0*SQRT(XW))
36165 VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36166 C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
36167 ELSEIF(ISUB.EQ.370) THEN
36171 ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36172 AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36174 ELSEIF(ISUB.EQ.371) THEN
36178 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36180 ELSEIF(ISUB.EQ.372) THEN
36184 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36186 ELSEIF(ISUB.EQ.373) THEN
36190 CAB2=(1D0-RTCM(3)**2)**2
36192 ELSEIF(ISUB.EQ.374) THEN
36196 VRGP=QUPD*CSXI/RTCM(12)
36197 VWGP=QUPD*CSXI/(2D0*SQRT(XW))
36198 AXGP=-CSXI/RTCM(49)
36200 ELSEIF(ISUB.EQ.375) THEN
36204 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36205 ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
36206 VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36207 AXGP=-CSXI*CT2W/RTCM(49)
36209 ELSEIF(ISUB.EQ.376) THEN
36214 ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
36215 AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
36217 ELSEIF(ISUB.EQ.377) THEN
36221 VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
36222 VWGP=CSXIP/(2D0*XW)
36223 VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
36225 ELSEIF(ISUB.EQ.378) THEN
36229 VRGP=QUPD*RTCM(3)/RTCM(12)
36230 AXGP=-RTCM(3)/RTCM(49)
36232 ELSEIF(ISUB.EQ.379) THEN
36236 VOGP=RTCM(3)/RTCM(12)
36237 VRGP=QUPD*RTCM(3)/RTCM(12)
36238 ELSEIF(ISUB.EQ.380) THEN
36242 VOGP=RTCM(3)*CT2W/RTCM(12)
36243 VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
36247 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
36248 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
36249 IF(ITCM(5).LE.4) THEN
36267 ELSEIF(ITCM(5).EQ.5) THEN
36269 IF(ITCM(2).EQ.0) THEN
36274 ALPRHT=2.16D0*(3D0/ITCM(1))
36275 SIN2T=2D0*TANT3/(TANT3**2+1D0)
36276 SINT3=TANT3/SQRT(TANT3**2+1D0)
36277 XIG=SQRT(PYALPS(SH)/ALPRHT)
36278 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
36279 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
36280 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
36281 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
36282 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
36283 & SINT3**2)*2D0/SIN2T
36284 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
36285 & SINT3**2)*2D0/SIN2T
36287 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
36288 SM1112=X12*RTCM(28)**2*SIN2T
36289 SM1121=-X21*RTCM(28)**2*SIN2T
36292 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
36293 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
36296 ZTC(1,1)=DCMPLX(SH,0D0)
36297 CALL PYWIDT(3100021,SH,WDTP,WDTE)
36298 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
36299 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
36300 CALL PYWIDT(3100113,SH,WDTP,WDTE)
36301 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
36302 CALL PYWIDT(3400113,SH,WDTP,WDTE)
36303 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
36304 CALL PYWIDT(3200113,SH,WDTP,WDTE)
36305 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
36306 CALL PYWIDT(3300113,SH,WDTP,WDTE)
36307 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
36309 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
36313 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
36314 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
36315 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
36316 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
36329 CALL PYLDCM(ZTC,6,6,INDX,D)
36333 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36338 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36344 XIG=SQRT(PYALPS(-TH)/ALPRHT)
36346 ZTC(1,1)=DCMPLX(TH)
36347 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
36348 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
36349 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
36350 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
36351 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
36353 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
36357 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
36358 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
36359 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
36360 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
36372 CALL PYLDCM(ZTC,6,6,INDX,D)
36376 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36380 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36386 XIG=SQRT(PYALPS(-UH)/ALPRHT)
36388 ZTC(1,1)=DCMPLX(UH,0D0)
36389 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
36390 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
36391 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
36392 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
36393 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
36395 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
36399 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
36400 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
36401 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
36402 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
36414 CALL PYLDCM(ZTC,6,6,INDX,D)
36418 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36422 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36429 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
36430 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
36431 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
36432 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
36433 DQGS=DGGS-DGVS*DCMPLX(TANT3)
36434 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36436 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
36437 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
36438 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
36439 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
36440 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36441 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36444 SQDQTS=ABS(DQTS)**2
36445 SQDQQS=ABS(DQQS)**2
36446 SQDQQT=ABS(DQQT)**2
36447 SQDQQU=ABS(DQQU)**2
36448 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
36450 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
36452 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
36454 SQDGGS=ABS(DGGS)**2
36455 SQDGGT=ABS(DGGT)**2
36456 SQDGGU=ABS(DGGU)**2
36460 REDGTU=DBLE(DGGU*DCONJG(DGGT))
36461 REDGSU=DBLE(DGGU*DCONJG(DGGS))
36462 REDGST=DBLE(DGGS*DCONJG(DGGT))
36463 REDQST=DBLE(DQQS*DCONJG(DQQT))
36464 REDQTU=DBLE(DQQT*DCONJG(DQQU))
36469 C...Differential cross section expressions.
36471 IF(ISUB.LE.190) THEN
36472 IF(ISUB.EQ.149) THEN
36473 C...g + g -> eta_tc
36474 KCTC=PYCOMP(KTECHN+331)
36475 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
36477 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
36478 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36480 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
36482 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36487 SIGH(NCHN)=HI*FACBW*HF
36490 ELSEIF(ISUB.EQ.165) THEN
36491 C...q + qbar -> l+ + l- (including contact term for compositeness)
36492 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36493 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36494 KFF=IABS(KFPR(ISUB,1))
36496 AF=SIGN(1D0,EF+0.1D0)
36501 IF(KFF.LE.10) FCOF=3D0
36503 IF(KFF.EQ.6) WID2=WIDS(6,1)
36504 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
36505 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
36506 DO 260 I=MMINA,MMAXA
36507 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
36508 EI=KCHG(IABS(I),1)/3D0
36509 AI=SIGN(1D0,EI+0.1D0)
36514 IF(IABS(I).LE.10) FCOI=FACA/3D0
36515 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
36516 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
36517 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
36518 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
36520 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
36521 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
36523 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
36524 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
36525 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
36526 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
36527 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
36532 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
36535 ELSEIF(ISUB.EQ.166) THEN
36536 C...q + q'bar -> l + nu_l (including contact term for compositeness)
36537 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
36538 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
36539 KFF=IABS(KFPR(ISUB,1))
36541 IF(KFF.LE.10) FCOF=3D0
36542 DO 280 I=MMIN1,MMAX1
36543 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
36545 DO 270 J=MMIN2,MMAX2
36546 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
36548 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
36549 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36552 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36554 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
36555 & MOD(J,2).EQ.0)) THEN
36556 IF(KFF.EQ.5) WID2=WIDS(6,2)
36557 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
36558 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
36560 IF(KFF.EQ.5) WID2=WIDS(6,3)
36561 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
36562 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
36568 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
36569 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
36570 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
36575 ELSEIF(ISUB.LE.200) THEN
36576 IF(ISUB.EQ.191) THEN
36577 C...q + qbar -> rho_tc0.
36578 KCTC=PYCOMP(KTECHN+113)
36579 SQMRHT=PMAS(KCTC,1)**2
36580 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36582 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
36583 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36584 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36585 ALPRHT=2.16D0*(3D0/ITCM(1))
36586 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
36587 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
36588 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36589 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36590 DO 290 I=MMINA,MMAXA
36591 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
36593 EI=KCHG(IABS(I),1)/3D0
36594 AI=SIGN(1D0,EI+0.1D0)
36598 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
36599 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
36600 IF(IA.LE.10) HI=HI*FACA/3D0
36605 SIGH(NCHN)=HI*FACBW*HF
36608 ELSEIF(ISUB.EQ.192) THEN
36609 C...q + qbar' -> rho_tc+/-.
36610 KCTC=PYCOMP(KTECHN+213)
36611 SQMRHT=PMAS(KCTC,1)**2
36612 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36614 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
36615 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36616 ALPRHT=2.16D0*(3D0/ITCM(1))
36617 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
36618 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
36619 DO 310 I=MMIN1,MMAX1
36620 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
36622 DO 300 J=MMIN2,MMAX2
36623 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
36625 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
36626 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36628 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36629 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
36631 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36636 SIGH(NCHN)=HI*FACBW*HF
36640 ELSEIF(ISUB.EQ.193) THEN
36641 C...q + qbar -> omega_tc0.
36642 KCTC=PYCOMP(KTECHN+223)
36643 SQMOMT=PMAS(KCTC,1)**2
36644 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36646 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
36647 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36648 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36649 ALPRHT=2.16D0*(3D0/ITCM(1))
36650 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
36651 & (2D0*RTCM(2)-1D0)**2
36652 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36653 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36654 DO 320 I=MMINA,MMAXA
36655 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
36657 EI=KCHG(IABS(I),1)/3D0
36658 AI=SIGN(1D0,EI+0.1D0)
36662 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
36663 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
36664 IF(IA.LE.10) HI=HI*FACA/3D0
36669 SIGH(NCHN)=HI*FACBW*HF
36672 ELSEIF(ISUB.EQ.194) THEN
36673 C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
36674 C...Default final state is e+e-
36676 ALPRHT=2.16D0*(3D0/ITCM(1))
36679 SN2W=2D0*SQRT(XW*XW1)
36680 C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
36681 C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
36683 QUPD=2D0*RTCM(2)-1D0
36684 FAR=SQRT(AEM/ALPRHT)
36688 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36689 FZX=-FAR/SN2W*RTCM(47)
36695 CALL PYWIDT(23,SH,WDTP,WDTE)
36696 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
36697 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36698 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
36699 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36700 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
36701 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
36702 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
36703 C...Propagator including a_T^0
36704 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
36705 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
36706 C...Add in techni-a contribution
36707 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
36708 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
36709 $ SFZX*SSMR*SSMO)/DETD/SH
36710 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
36711 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
36713 XWRHT=1D0/(4D0*XW*(1D0-XW))
36714 KFF=IABS(KFPR(ISUB,1))
36716 AF=SIGN(1D0,EF+0.1D0)
36721 IF(KFF.LE.10) FCOF=3D0
36724 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
36725 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
36726 DZZ=DZZ*DCMPLX(XWRHT,0D0)
36727 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
36729 DO 330 I=MMINA,MMAXA
36730 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
36731 EI=KCHG(IABS(I),1)/3D0
36732 AI=SIGN(1D0,EI+0.1D0)
36737 IF(IABS(I).LE.10) FCOI=FCOI/3D0
36738 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
36739 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
36740 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
36741 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
36742 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
36743 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
36748 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
36751 ELSEIF(ISUB.EQ.195) THEN
36752 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
36755 ALPRHT=2.16D0*(3D0/ITCM(1))
36756 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
36758 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36759 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36761 C...Propagator including a_T^+
36763 CALL PYWIDT(24,SH,WDTP,WDTE)
36764 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36765 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36766 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36767 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36768 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36769 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36770 & DCMPLX(FWX**2,0D0)*SSMR
36771 DWW=SSMR*SSMX/DETD/SH
36773 IF(KFA.LE.8) FCOF=3D0
36774 HP=FACTC*ABS(DWW)**2*FCOF
36776 DO 350 I=MMIN1,MMAX1
36777 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
36779 DO 340 J=MMIN2,MMAX2
36780 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
36782 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
36783 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36785 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36787 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36792 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
36797 ELSEIF(ISUB.LE.380) THEN
36798 ALPRHT=2.16D0*(3D0/ITCM(1))
36799 IF(ISUB.EQ.361) THEN
36800 FAR=SQRT(AEM/ALPRHT)
36804 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36805 FZX=-FAR/SN2W*RTCM(47)
36811 CALL PYWIDT(23,SH,WDTP,WDTE)
36812 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
36813 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36814 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
36815 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36816 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
36817 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
36818 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
36819 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
36820 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
36821 C...Add in techni-a contribution
36822 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
36823 DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
36824 $ SFZX*FAR*SSMO)/DETD/SH
36825 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
36826 DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
36827 $ SFZX*FAO*SSMR)/DETD/SH
36828 DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
36829 DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
36830 DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
36831 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
36832 $ SFZX*SSMR*SSMO)/DETD/SH
36833 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
36834 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
36836 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
36837 C...W+W-, W pi_tc, pi_T pi_T, etc.
36838 FACA=(SH**2*BE34**2-(TH-UH)**2)
36839 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36840 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36841 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36842 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
36843 DO 370 I=MMINA,MMAXA
36844 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
36846 EI=KCHG(IABS(I),1)/3D0
36847 AI=SIGN(1D0,EI+0.1D0)
36849 VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
36850 VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
36851 C...........Eqs. (5) and (6) in LSTC-rates.pdf
36852 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
36853 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
36854 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
36855 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
36856 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
36857 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
36858 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
36859 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
36860 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
36861 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
36862 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
36863 C...........Eqs. (5) and (7) in LSTC-rates.pdf
36864 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
36865 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
36866 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
36867 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
36868 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
36869 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
36870 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
36872 C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
36874 c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36875 c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36876 c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36877 c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36878 F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36879 F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36880 HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
36882 IF(IA.LE.10) HI=HI/3D0
36887 IF(KFA.EQ.KFB) THEN
36888 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
36889 ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
36890 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
36895 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
36897 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
36901 ELSEIF(ISUB.EQ.370) THEN
36902 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
36903 C...f + fbar' -> gamma pi_tc, etc.
36904 FACA=(SH**2*BE34**2-(TH-UH)**2)
36905 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36906 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36907 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36908 ALPRHT=2.16D0*(3D0/ITCM(1))
36909 FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
36910 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36911 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36913 CALL PYWIDT(24,SH,WDTP,WDTE)
36914 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36915 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36916 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36917 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36918 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36919 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36920 & DCMPLX(FWX**2,0D0)*SSMR
36921 DWW=SSMR*SSMX/DETD/SH
36922 DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
36923 DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
36924 HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
36925 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
36927 C...........Eq. (25) in PRD67-115011 with DWW term dropped.
36929 c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
36930 HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
36931 C...Add in W_L Z_T axial and vector contributions.
36932 IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
36933 $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
36934 $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
36935 $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
36936 DO 410 I=MMIN1,MMAX1
36937 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
36939 DO 400 J=MMIN2,MMAX2
36940 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
36942 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
36943 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36945 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36947 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36952 IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
36953 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
36955 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
36956 & WIDS(PYCOMP(KFB),2)
36962 ELSEIF(ISUB.LE.390) THEN
36963 IF(ISUB.EQ.381) THEN
36964 C...f + f' -> f + f' (g exchange)
36965 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
36966 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
36967 & MSTP(34)*2D0/3D0*UH2*REDQST)
36968 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
36969 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
36970 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
36971 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
36972 C...Modifications from contact interactions (compositeness)
36973 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
36974 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36975 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
36976 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36977 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
36978 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
36979 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
36980 ELSEIF(ITCM(5).EQ.5) THEN
36985 CSM.......Check this change from
36989 DO 430 I=MMIN1,MMAX1
36991 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36992 DO 420 J=MMIN2,MMAX2
36994 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
36999 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
37002 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
37005 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
37006 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
37013 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
37014 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
37015 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
37017 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
37018 SIGH(NCHN)=0.5D0*FACCI2*RATCII
37024 ELSEIF(ISUB.EQ.382) THEN
37025 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
37026 CALL PYWIDT(21,SH,WDTP,WDTE)
37027 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
37028 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37029 IF(ITCM(5).EQ.1) THEN
37030 C...Modifications from contact interactions (compositeness)
37033 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
37034 & WDTE(I,2)+WDTE(I,4))
37036 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
37037 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
37038 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37039 ELSEIF(ITCM(5).EQ.5) THEN
37040 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
37041 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
37042 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
37044 DO 450 I=MMINA,MMAXA
37045 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37046 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
37051 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
37053 ELSEIF(ITCM(5).EQ.5) THEN
37065 ELSEIF(ISUB.EQ.383) THEN
37066 C...f + fbar -> g + g (q + qbar -> g + g only)
37067 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37068 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37069 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37070 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37071 IF(ITCM(5).EQ.5) THEN
37072 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37073 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37074 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37075 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37077 DO 460 I=MMINA,MMAXA
37078 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37079 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
37084 SIGH(NCHN)=0.5D0*FACGG1
37085 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
37090 SIGH(NCHN)=0.5D0*FACGG2
37091 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
37094 ELSEIF(ISUB.EQ.384) THEN
37095 C...f + g -> f + g (q + g -> q + g only)
37096 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
37097 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
37098 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
37099 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
37100 DO 480 I=MMINA,MMAXA
37101 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
37103 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
37104 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
37107 ISIG(NCHN,3-ISDE)=21
37112 ISIG(NCHN,3-ISDE)=21
37118 ELSEIF(ISUB.EQ.385) THEN
37119 C...g + g -> f + fbar (g + g -> q + qbar only)
37120 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
37122 C...Begin by d, u, s flavours.
37124 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
37125 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
37126 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
37127 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
37128 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
37129 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
37130 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37131 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37132 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37133 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37144 C...Next c and b flavours: modified that and uhat for fixed
37145 C...cos(theta-hat).
37147 SQMAVG=PMAS(IFL,1)**2
37148 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
37149 BE34=SQRT(1D0-4D0*SQMAVG/SH)
37150 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37151 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37152 THUHQ=THQ*UHQ-SQMAVG*SH
37153 IF(MSTP(34).EQ.0) THEN
37154 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37155 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37157 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37158 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37159 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37160 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37162 IF(ITCM(5).GE.5) THEN
37164 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37165 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37166 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37167 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37169 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37170 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37171 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37172 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37175 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
37176 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
37180 ISIG(NCHN,3)=1+2*(IFL-3)
37185 ISIG(NCHN,3)=2+2*(IFL-3)
37191 ELSEIF(ISUB.EQ.386) THEN
37193 IF(ITCM(5).LE.4) THEN
37194 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
37195 & 2D0*TH/SH+TH2/SH2)*FACA
37196 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
37197 & 2D0*SH/UH+SH2/UH2)*FACA
37198 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
37199 & 2D0*UH/TH+UH2/TH2)
37201 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
37202 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
37203 & 4D0*REDGST*(SH + 2D0*TH)*
37204 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
37205 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
37206 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
37207 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
37208 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
37209 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
37210 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
37211 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
37212 & 4D0*REDGSU*(SH + 2D0*UH)*
37213 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
37214 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
37215 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
37216 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
37217 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
37218 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
37219 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
37220 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
37221 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
37222 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
37223 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
37224 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
37225 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
37226 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
37227 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
37228 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
37229 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
37230 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
37231 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
37232 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
37233 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
37234 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
37236 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
37241 SIGH(NCHN)=0.5D0*FACGG1
37246 SIGH(NCHN)=0.5D0*FACGG2
37251 SIGH(NCHN)=0.5D0*FACGG3
37254 ELSEIF(ISUB.EQ.387) THEN
37255 C...q + qbar -> Q + Qbar
37256 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37257 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37258 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37259 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
37261 IF(ITCM(5).GE.5) THEN
37262 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37263 FACQQB=FACQQB*SH2*SQDQTS
37265 FACQQB=FACQQB*SH2*SQDQQS
37268 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
37270 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37271 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37273 DO 520 I=MMINA,MMAXA
37274 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37275 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
37283 ELSEIF(ISUB.EQ.388) THEN
37284 C...g + g -> Q + Qbar
37285 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37286 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37287 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37288 THUHQ=THQ*UHQ-SQMAVG*SH
37289 IF(MSTP(34).EQ.0) THEN
37290 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37291 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37293 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37294 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37295 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37296 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37298 IF(ITCM(5).GE.5) THEN
37299 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37300 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37301 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37302 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37303 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37305 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37306 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37307 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37308 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37311 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
37312 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
37313 IF(MSTP(35).GE.1) THEN
37314 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
37315 FACQQ1=FACQQ1*FATRE
37316 FACQQ2=FACQQ2*FATRE
37319 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37320 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37323 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
37343 C*********************************************************************
37346 C...Subprocess cross sections for assorted exotic processes,
37347 C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
37348 C...Auxiliary to PYSIGH.
37350 SUBROUTINE PYSGEX(NCHN,SIGS)
37352 C...Double precision and integer declarations
37353 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37354 IMPLICIT INTEGER(I-N)
37355 INTEGER PYK,PYCHGE,PYCOMP
37356 C...Parameter statement to help give large particle numbers.
37357 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37358 &KEXCIT=4000000,KDIMEN=5000000)
37360 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37361 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37362 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
37363 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37364 COMMON/PYINT1/MINT(400),VINT(400)
37365 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
37366 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
37367 COMMON/PYINT4/MWID(500),WIDS(500,5)
37368 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
37369 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
37370 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
37371 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
37372 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
37373 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
37374 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
37376 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
37378 C...Differential cross section expressions.
37380 IF(ISUB.LE.160) THEN
37381 IF(ISUB.EQ.141) THEN
37382 C...f + fbar -> gamma*/Z0/Z'0
37383 SQMZP=PMAS(32,1)**2
37385 CALL PYWIDT(32,SH,WDTP,WDTE)
37391 FACZP=4D0*COMFAC*3D0
37392 DO 100 I=MMINA,MMAXA
37393 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
37394 EI=KCHG(IABS(I),1)/3D0
37400 VPI=PARU(123-2*MOD(IABS(I),2))
37401 API=PARU(124-2*MOD(IABS(I),2))
37402 ELSEIF(IA.LE.4) THEN
37403 VPI=PARJ(182-2*MOD(IABS(I),2))
37404 API=PARJ(183-2*MOD(IABS(I),2))
37406 VPI=PARJ(190-2*MOD(IABS(I),2))
37407 API=PARJ(191-2*MOD(IABS(I),2))
37411 VPI=PARU(127-2*MOD(IABS(I),2))
37412 API=PARU(128-2*MOD(IABS(I),2))
37413 ELSEIF(IA.LE.14) THEN
37414 VPI=PARJ(186-2*MOD(IABS(I),2))
37415 API=PARJ(187-2*MOD(IABS(I),2))
37417 VPI=PARJ(194-2*MOD(IABS(I),2))
37418 API=PARJ(195-2*MOD(IABS(I),2))
37422 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
37424 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
37426 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
37431 C...Special case: if only branching ratios known then use them.
37432 IF(MWID(32).EQ.2.AND.MSTP(44).EQ.3) THEN
37435 HI=SHR*WDTP(IA)*FACA/9D0
37436 ELSEIF(IA.LT.20) THEN
37439 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37440 SIGH(NCHN)=HI*FACZP*HF/((SH-SQMZP)**2+HSP**2)
37442 C...Normal cross section.
37443 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
37444 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
37445 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
37446 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
37447 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
37448 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
37449 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
37450 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
37454 ELSEIF(ISUB.EQ.142) THEN
37455 C...f + fbar' -> W'+/-
37456 SQMWP=PMAS(34,1)**2
37457 CALL PYWIDT(34,SH,WDTP,WDTE)
37459 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
37460 HP=AEM/(24D0*XW)*SH
37461 DO 120 I=MMIN1,MMAX1
37462 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
37464 DO 110 J=MMIN2,MMAX2
37465 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
37467 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
37468 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37470 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37471 C...Special case: if only branching ratios known then use them.
37472 IF(MWID(34).EQ.2) THEN
37474 DO 105 IDC=MDCY(34,2),MDCY(34,2)+MDCY(34,3)-1
37475 IF((IA.EQ.IABS(KFDP(IDC,1)).AND.JA.EQ.
37476 & IABS(KFDP(IDC,2))).OR.(IA.EQ.IABS(KFDP(IDC,2))
37477 & .AND.JA.EQ.IABS(KFDP(IDC,1))))
37478 & HI=SHR*WDTP(IDC+1-MDCY(34,2))
37480 IF(IA.LT.10) HI=HI*FACA/9D0
37482 C...Normal cross section.
37483 HI=HP*(PARU(133)**2+PARU(134)**2)
37484 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
37485 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37491 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
37492 SIGH(NCHN)=HI*FACBW*HF
37496 ELSEIF(ISUB.EQ.144) THEN
37499 CALL PYWIDT(41,SH,WDTP,WDTE)
37501 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
37502 HP=AEM/(12D0*XW)*SH
37503 DO 140 I=MMIN1,MMAX1
37504 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
37506 DO 130 J=MMIN2,MMAX2
37507 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
37509 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
37511 IF(IA.LE.10) HI=HI*FACA/3D0
37512 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
37517 SIGH(NCHN)=HI*FACBW*HF
37521 ELSEIF(ISUB.EQ.145) THEN
37522 C...q + l -> LQ (leptoquark)
37523 SQMLQ=PMAS(42,1)**2
37524 CALL PYWIDT(42,SH,WDTP,WDTE)
37526 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
37527 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
37529 KFLQQ=KFDP(MDCY(42,2),1)
37530 KFLQL=KFDP(MDCY(42,2),2)
37531 DO 160 I=MMIN1,MMAX1
37532 IF(KFAC(1,I).EQ.0) GOTO 160
37534 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
37535 DO 150 J=MMIN2,MMAX2
37536 IF(KFAC(2,J).EQ.0) GOTO 150
37538 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
37539 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
37540 IF(JA.EQ.IA) GOTO 150
37541 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
37542 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
37544 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
37549 SIGH(NCHN)=HI*FACBW*HF
37553 ELSEIF(ISUB.EQ.146) THEN
37554 C...e + gamma* -> e* (excited lepton)
37555 KFQSTR=KFPR(ISUB,1)
37556 KCQSTR=PYCOMP(KFQSTR)
37557 KFQEXC=MOD(KFQSTR,KEXCIT)
37558 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
37560 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
37561 QF=-RTCM(43)/2D0-RTCM(44)/2D0
37562 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
37563 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
37566 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
37568 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
37569 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
37571 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37572 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
37575 ISIG(NCHN,3-ISDE)=22
37577 SIGH(NCHN)=HI*FACBW*HF
37581 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
37582 C...d + g -> d* and u + g -> u* (excited quarks)
37583 KFQSTR=KFPR(ISUB,1)
37584 KCQSTR=PYCOMP(KFQSTR)
37585 KFQEXC=MOD(KFQSTR,KEXCIT)
37586 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
37588 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
37589 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
37590 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
37593 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
37595 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
37596 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
37598 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37599 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
37602 ISIG(NCHN,3-ISDE)=21
37604 SIGH(NCHN)=HI*FACBW*HF
37609 ELSEIF(ISUB.LE.190) THEN
37610 IF(ISUB.EQ.162) THEN
37611 C...q + g -> LQ + lbar; LQ=leptoquark
37612 SQMLQ=PMAS(42,1)**2
37613 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
37614 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
37615 KFLQQ=KFDP(MDCY(42,2),1)
37616 DO 220 I=MMINA,MMAXA
37617 IF(IABS(I).NE.KFLQQ) GOTO 220
37620 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
37621 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
37624 ISIG(NCHN,3-ISDE)=21
37626 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
37630 ELSEIF(ISUB.EQ.163) THEN
37631 C...g + g -> LQ + LQbar; LQ=leptoquark
37632 SQMLQ=PMAS(42,1)**2
37633 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
37634 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
37635 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
37636 & ((TH-SQMLQ)*(UH-SQMLQ)))
37637 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
37641 C...Since don't know proper colour flow, randomize between alternatives
37642 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
37646 ELSEIF(ISUB.EQ.164) THEN
37647 C...q + qbar -> LQ + LQbar; LQ=leptoquark
37648 DELTA=0.25D0*(SQM3-SQM4)**2/SH
37649 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
37652 C SQMLQ=PMAS(42,1)**2
37653 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
37654 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
37655 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
37656 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
37657 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
37658 KFLQQ=KFDP(MDCY(42,2),1)
37659 DO 240 I=MMINA,MMAXA
37660 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37661 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
37667 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
37670 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
37671 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
37672 KFQSTR=KFPR(ISUB,2)
37673 KCQSTR=PYCOMP(KFQSTR)
37674 KFQEXC=MOD(KFQSTR,KEXCIT)
37675 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
37676 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
37677 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
37678 C...Propagators: as simulated in PYOFSH and as desired
37679 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
37680 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
37681 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
37682 GMMQC=SQRT(SQM4)*WDTP(0)
37683 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
37684 FACQSA=FACQSA*HBW4C/HBW4
37685 FACQSB=FACQSB*HBW4C/HBW4
37686 C...Branching ratios.
37687 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
37688 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
37689 DO 260 I=MMIN1,MMAX1
37691 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
37692 DO 250 J=MMIN2,MMAX2
37694 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
37695 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
37700 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
37701 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
37706 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
37707 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
37708 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
37713 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
37714 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
37715 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
37716 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
37721 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
37722 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
37727 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
37728 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
37729 ELSEIF(I.EQ.-J) THEN
37734 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37735 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37740 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37741 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37742 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
37747 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
37748 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
37749 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
37754 ELSEIF(ISUB.EQ.169) THEN
37755 C...q + qbar -> e + e* (excited lepton)
37756 KFQSTR=KFPR(ISUB,2)
37757 KCQSTR=PYCOMP(KFQSTR)
37758 KFQEXC=MOD(KFQSTR,KEXCIT)
37759 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
37760 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
37761 C...Propagators: as simulated in PYOFSH and as desired
37762 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
37763 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
37764 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
37765 GMMQC=SQRT(SQM4)*WDTP(0)
37766 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
37767 FACQSB=FACQSB*HBW4C/HBW4
37768 C...Branching ratios.
37769 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
37770 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
37771 DO 270 I=MMIN1,MMAX1
37773 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
37776 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
37781 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37782 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37787 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37788 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37792 ELSEIF(ISUB.LE.360) THEN
37793 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
37794 C...l + l -> H_L++/-- or H_R++/--.
37796 KFREC=PYCOMP(KFRES)
37797 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37799 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
37800 DO 290 I=MMIN1,MMAX1
37802 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
37804 DO 280 J=MMIN2,MMAX2
37806 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
37808 IF(I*J.LT.0) GOTO 280
37809 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37814 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
37815 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37816 SIGH(NCHN)=HI*FACBW*HF
37820 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
37821 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
37823 KFREC=PYCOMP(KFRES)
37824 C...Propagators: as simulated in PYOFSH and as desired
37825 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
37826 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
37827 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
37828 GMMC=SQRT(SQM3)*WDTP(0)
37829 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
37830 FHCC=COMFAC*AEM*HBW3C/HBW3
37831 DO 310 I=MMINA,MMAXA
37833 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
37835 J=ISIGN(KFPR(ISUB,2),-I)
37836 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
37837 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
37838 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
37840 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
37841 & (TH-SQM4)*SH)/(TH-SQM4)**2
37842 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
37844 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
37845 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
37846 & ((UH-SQM3)*(TH-SQM4))
37847 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
37848 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
37849 & ((UH-SQM3)*(SH-SQML))
37850 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
37851 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
37852 & ((SH-SQML)*(TH-SQM4))
37853 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
37854 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
37856 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
37857 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
37860 ISIG(NCHN,3-ISDE)=22
37862 SIGH(NCHN)=FHCC*SMM*WIDSC
37866 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
37867 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
37869 KFREC=PYCOMP(KFRES)
37870 SQMH=PMAS(KFREC,1)**2
37871 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
37872 C...Propagators: H++/-- as simulated in PYOFSH and as desired
37873 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
37874 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
37875 GMMH3=SQRT(SQM3)*WDTP(0)
37876 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
37877 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
37878 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
37879 GMMH4=SQRT(SQM4)*WDTP(0)
37880 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
37881 C...Kinematical and coupling functions
37882 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
37883 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
37884 C...Loop over allowed flavours
37885 DO 320 I=MMINA,MMAXA
37886 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
37887 EI=KCHG(IABS(I),1)/3D0
37888 AI=SIGN(1D0,EI+0.1D0)
37891 IF(IABS(I).LE.10) FCOI=FACA/3D0
37892 IF(ISUB.EQ.349) THEN
37893 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
37894 IF(IABS(I).LT.10) THEN
37895 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37896 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37897 & (VI**2+AI**2)*XWHH**2*HBWZ)
37899 IAOFF=181+3*((IABS(I)-11)/2)
37900 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37902 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37903 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37904 & (VI**2+AI**2)*XWHH**2*HBWZ)+
37905 & 8D0*AEM*(EI*HSUM/(SH*TH)+
37906 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
37910 IF(IABS(I).LT.10) THEN
37911 DSIGHH=8D0*AEM**2*EI**2/SH2
37913 IAOFF=181+3*((IABS(I)-11)/2)
37914 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37916 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
37924 SIGH(NCHN)=FACHH*FCOI*DSIGHH
37927 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
37928 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
37930 KFREC=PYCOMP(KFRES)
37931 SQMH=PMAS(KFREC,1)**2
37932 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
37933 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
37934 & PMAS(PYCOMP(9900024),1)**2
37935 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
37936 FACPRT=1D0/((VINT(204)**2-VINT(215))*
37937 & (VINT(209)**2-VINT(216)))
37938 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
37939 & (VINT(209)**2+2D0*VINT(218)))
37940 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37942 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
37943 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
37945 DO 340 I=MMIN1,MMAX1
37946 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
37947 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
37948 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
37949 DO 330 J=MMIN2,MMAX2
37950 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
37951 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
37952 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
37954 IF(IABS(KCHH).NE.2) GOTO 330
37955 FACLR=VINT(180+I)*VINT(180+J)
37956 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37957 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
37958 FACPRP=0.5D0*(FACPRT+FACPRU)**2
37966 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
37970 ELSEIF(ISUB.EQ.353) THEN
37971 C...f + fbar -> Z_R0
37972 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37973 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37975 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
37976 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37977 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
37978 DO 350 I=MMINA,MMAXA
37979 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
37980 IF(IABS(I).LE.8) THEN
37981 EI=KCHG(IABS(I),1)/3D0
37982 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
37983 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
37988 HI=HP*(VI**2+AI**2)
37989 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37994 SIGH(NCHN)=HI*FACBW*HF
37997 ELSEIF(ISUB.EQ.354) THEN
37998 C...f + fbar' -> W_R+/-
37999 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
38000 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
38002 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
38003 HP=AEM/(24D0*XW)*SH
38004 DO 370 I=MMIN1,MMAX1
38005 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
38007 DO 360 J=MMIN2,MMAX2
38008 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
38010 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
38011 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
38013 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38015 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
38020 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
38021 SIGH(NCHN)=HI*FACBW*HF
38026 ELSEIF(ISUB.LE.400) THEN
38027 IF(ISUB.EQ.391) THEN
38028 C...f + fbar -> G*.
38029 KFGSTR=KFPR(ISUB,1)
38030 KCGSTR=PYCOMP(KFGSTR)
38031 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38033 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38034 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
38035 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38036 C...Modify cross section in wings of peak.
38037 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38038 DO 380 I=MMINA,MMAXA
38039 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
38041 IF(IABS(I).LE.10) HI=HI*FACA/3D0
38049 ELSEIF(ISUB.EQ.392) THEN
38051 KFGSTR=KFPR(ISUB,1)
38052 KCGSTR=PYCOMP(KFGSTR)
38053 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38055 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38056 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
38057 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38058 C...Modify cross section in wings of peak.
38059 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38060 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
38068 ELSEIF(ISUB.EQ.393) THEN
38069 C...q + qbar -> g + G*.
38070 KFGSTR=KFPR(ISUB,2)
38071 KCGSTR=PYCOMP(KFGSTR)
38072 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
38073 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
38074 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
38076 C...Propagators: as simulated in PYOFSH and as desired
38077 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38078 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38079 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38080 HS=SQRT(SQM4)*WDTP(0)
38081 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38082 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38083 FACG=FACG*HBW4C/HBW4
38084 DO 400 I=MMINA,MMAXA
38085 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
38086 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
38094 ELSEIF(ISUB.EQ.394) THEN
38095 C...q + g -> q + G*.
38096 KFGSTR=KFPR(ISUB,2)
38097 KCGSTR=PYCOMP(KFGSTR)
38098 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
38099 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
38100 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
38101 & 2D0*TH2*TH/(UH*SH2))
38102 C...Propagators: as simulated in PYOFSH and as desired
38103 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38104 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38105 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38106 HS=SQRT(SQM4)*WDTP(0)
38107 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38108 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38109 FACG=FACG*HBW4C/HBW4
38110 DO 420 I=MMINA,MMAXA
38111 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
38113 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
38114 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
38117 ISIG(NCHN,3-ISDE)=21
38123 ELSEIF(ISUB.EQ.395) THEN
38124 C...g + g -> g + G*.
38125 KFGSTR=KFPR(ISUB,2)
38126 KCGSTR=PYCOMP(KFGSTR)
38127 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
38128 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
38129 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
38130 C...Propagators: as simulated in PYOFSH and as desired
38131 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38132 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38133 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38134 HS=SQRT(SQM4)*WDTP(0)
38135 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38136 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38137 FACG=FACG*HBW4C/HBW4
38138 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
38151 C*********************************************************************
38154 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
38155 C...parton distributions according to a few different parametrizations.
38156 C...Note that what is coded is x times the probability distribution,
38157 C...i.e. xq(x,Q2) etc.
38159 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
38161 C...Double precision and integer declarations.
38162 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38163 IMPLICIT INTEGER(I-N)
38164 INTEGER PYK,PYCHGE,PYCOMP
38166 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38167 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38168 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38169 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38170 COMMON/PYINT1/MINT(400),VINT(400)
38171 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38173 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38174 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
38175 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
38176 & XMI(2,240),PT2MI(240),IMISEP(0:240)
38177 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
38180 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
38181 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
38184 C...Interface to PDFLIB.
38185 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
38187 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38188 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38189 CHARACTER*20 PARM(20)
38190 DATA VALUE/20*0D0/,PARM/20*' '/
38192 C...Data related to Schuler-Sjostrand photon distributions.
38193 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
38195 C...Valence PDF momentum integral parametrizations PER PARTON!
38196 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
38197 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
38198 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
38199 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
38201 C...Reset parton distributions.
38210 C...Check x and particle species.
38211 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38212 WRITE(MSTU(11),5000) X
38216 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
38217 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
38218 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
38219 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
38220 &KFA.NE.310.AND.KFA.NE.130) THEN
38221 WRITE(MSTU(11),5100) KF
38225 C...Electron (or muon or tau) parton distribution call.
38226 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
38227 CALL PYPDEL(KFA,X,Q2,XPEL)
38232 C...Photon parton distribution call (VDM+anomalous).
38233 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
38234 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
38235 CALL PYPDGA(X,Q2,XPGA)
38239 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
38242 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
38243 XPVAL(4)=MIN(XPQ(4),XPVU)
38244 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
38250 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
38253 IF(MSTP(55).GE.7) P2MX=4.0D0
38254 IF(MSTP(57).EQ.0) Q2MX=P2MX
38256 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38257 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38260 XPVAL(KFL)=VXPDGM(KFL)
38263 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
38266 IF(MSTP(55).GE.11) P2MX=4.0D0
38267 IF(MSTP(57).EQ.0) Q2MX=P2MX
38269 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38270 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38272 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38273 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38276 ELSEIF(MSTP(56).EQ.2) THEN
38277 C...Call PDFLIB parton distributions.
38281 VALUE(2)=MSTP(55)/1000
38283 VALUE(3)=MOD(MSTP(55),1000)
38284 IF(MINT(93).NE.3000000+MSTP(55)) THEN
38285 CALL PDFSET_ALICE(PARM,VALUE)
38286 MINT(93)=3000000+MSTP(55)
38289 QQ2=MAX(0D0,Q2MIN,Q2)
38290 IF(MSTP(57).EQ.0) QQ2=Q2MIN
38292 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38294 IF(MSTP(55).EQ.5004) THEN
38295 IF(5D0*P2.LT.QQ2.AND.
38296 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
38297 & P2.GE.0D0.AND.P2.LT.10D0.AND.
38298 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
38299 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
38314 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
38342 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
38345 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
38346 XPVAL(4)=MIN(XPQ(4),XPVU)
38347 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
38354 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
38357 C...Pion/gammaVDM parton distribution call.
38358 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
38359 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
38360 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
38361 & MSTP(55).LE.12) THEN
38362 ISET=1+MOD(MSTP(55)-1,4)
38365 IF(ISET.GE.3) P2MX=4.0D0
38366 IF(MSTP(57).EQ.0) Q2MX=P2MX
38368 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38369 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38371 XPQ(KFL)=XPVMD(KFL)
38372 XPVAL(KFL)=VXPVMD(KFL)
38375 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
38376 CALL PYPDPI(X,Q2,XPPI)
38380 XPVAL(2)=XPQ(2)-XPQ(-2)
38381 XPVAL(-1)=XPQ(-1)-XPQ(1)
38382 ELSEIF(MSTP(54).EQ.2) THEN
38383 C...Call PDFLIB parton distributions.
38387 VALUE(2)=MSTP(53)/1000
38389 VALUE(3)=MOD(MSTP(53),1000)
38390 IF(MINT(93).NE.2000000+MSTP(53)) THEN
38391 CALL PDFSET_ALICE(PARM,VALUE)
38392 MINT(93)=2000000+MSTP(53)
38395 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38396 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38398 & (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38416 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
38419 C...Anomalous photon parton distribution call.
38420 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
38423 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
38424 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
38425 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
38426 IF(MSTP(57).EQ.0) Q2MX=P2MX
38428 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38429 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
38431 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
38432 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
38435 ELSEIF(MSTP(56).EQ.1) THEN
38436 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
38437 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
38438 IF(MSTP(57).EQ.0) Q2MX=P2MX
38440 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38441 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
38443 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
38444 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
38447 ELSEIF(MSTP(56).EQ.2) THEN
38448 IF(MSTP(57).EQ.0) Q2MX=P2MX
38449 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
38452 XPVAL(KFL)=VXPGA(KFL)
38455 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
38456 IF(MSTP(57).EQ.0) Q2MX=P2MX
38457 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
38460 XPVAL(KFL)=VXPGA(KFL)
38464 220 RKF=11D0*PYR(0)
38466 IF(RKF.GT.1D0) KFR=2
38467 IF(RKF.GT.5D0) KFR=3
38468 IF(RKF.GT.6D0) KFR=4
38469 IF(RKF.GT.10D0) KFR=5
38470 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
38471 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
38472 IF(MSTP(57).EQ.0) Q2MX=P2MX
38473 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
38476 XPVAL(KFL)=VXPGA(KFL)
38481 C...Proton parton distribution call.
38483 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
38484 CALL PYPDPR(X,Q2,XPPR)
38488 C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
38489 XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1))
38490 XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2))
38491 ELSEIF(MSTP(52).EQ.2) THEN
38492 C...Call PDFLIB parton distributions.
38496 VALUE(2)=MSTP(51)/1000
38498 VALUE(3)=MOD(MSTP(51),1000)
38499 IF(MINT(93).NE.1000000+MSTP(51)) THEN
38500 CALL PDFSET_ALICE(PARM,VALUE)
38501 MINT(93)=1000000+MSTP(51)
38504 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38505 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38506 CALL STRUCTM_ALICE(
38507 & XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38525 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
38529 C...Isospin average for pi0/gammaVDM.
38530 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
38531 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
38536 XPS=0.5D0*(XPQ(1)+XPQ(-2))
38537 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
38541 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
38542 & XPVAL(3)+XPVAL(4)+XPVAL(5)
38546 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
38547 XPQ(1)=XPQ(1)+0.2D0*XPV
38548 XPQ(2)=XPQ(2)+0.8D0*XPV
38549 XPVAL(1)=0.2D0*XPVL
38550 XPVAL(2)=0.8D0*XPVL
38551 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
38554 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
38557 IF(MSTP(55).GE.9) THEN
38563 XPQ(1)=XPQ(1)+0.5D0*XPV
38564 XPQ(2)=XPQ(2)+0.5D0*XPV
38565 XPVAL(1)=0.5D0*XPVL
38566 XPVAL(2)=0.5D0*XPVL
38570 XPVAL(-KFL)=XPVAL(KFL)
38573 C...Rescale for gammaVDM by effective gamma -> rho coupling.
38574 C+++Do not rescale?
38575 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
38576 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
38578 XPQ(KFL)=VINT(281)*XPQ(KFL)
38579 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
38581 VINT(232)=VINT(281)*XPV
38584 C...Simple recipes for kaons.
38585 ELSEIF(KFA.EQ.321) THEN
38586 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
38588 XPVAL(-3)=XPVAL(-1)
38590 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
38591 XPS=0.5D0*(XPQ(1)+XPQ(-2))
38592 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
38595 XPQ(1)=XPQ(1)+0.5D0*XPV
38596 XPQ(-1)=XPQ(-1)+0.5D0*XPV
38597 XPQ(3)=XPQ(3)+0.5D0*XPV
38598 XPQ(-3)=XPQ(-3)+0.5D0*XPV
38599 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
38603 XPVAL(-1)=0.5D0*XPV
38605 XPVAL(-3)=0.5D0*XPV
38607 C...Isospin conjugation for neutron.
38608 ELSEIF(KFA.EQ.2112) THEN
38619 C...Simple recipes for hyperon (average valence parton distribution).
38620 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
38621 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
38622 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
38623 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
38628 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
38629 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
38630 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
38631 XPV=(XPVAL(1)+XPVAL(2))/3D0
38634 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
38635 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
38636 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
38639 C...Charge conjugation for antiparticle.
38642 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
38649 XPVAL(KFL)=XPVAL(-KFL)
38654 C...MULTIPLE INTERACTIONS - PDF RESHAPING.
38657 C...Only reshape PDFs for the non-first interactions;
38658 C...But need valence/sea separation already from first interaction.
38659 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
38660 KFVSEL=KFIVAL(JS,1)
38661 C...If valence quark kicked out of pi0 or gamma then that decides
38662 C...whether we should consider state as d dbar, u ubar, s sbar, etc.
38663 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
38666 XPVL=XPVL+XPVAL(KFL)
38667 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
38670 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
38671 XPVAL(IABS(KFVSEL))=XPVL
38674 XPVAL(-KFL)=XPVAL(KFL)
38677 C...If valence quark kicked out of K0S or K0S then that decides whether
38678 C...we should consider state as d sbar or s dbar.
38679 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
38681 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
38682 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
38683 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
38684 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
38687 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
38688 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
38689 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
38693 C...XPQ distributions are nominal for a (signed) beam particle
38694 C...of KF type, with 1-Sum(x_prev) rescaled to 1.
38702 IF(IFL.EQ.0) GOTO 350
38704 C...Count up number of original IFL valence quarks.
38706 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
38707 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
38708 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
38709 C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
38710 C...bookkeep as if d dbar (for total momentum sum in valence sector).
38711 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
38712 C...Count down number of remaining IFL valence quarks. Skip current
38713 C...interaction initiator.
38715 DO 330 I1=1,NMI(JS)
38716 IF (I1.EQ.MINT(36)) GOTO 330
38717 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
38721 C...Separate out original VALENCE and SEA content.
38723 SEA=MAX(0D0,XPQ(IFL)-VAL)
38727 C...Rescale valence content if changed.
38728 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
38729 & (VAL*IVREM)/IVORG
38731 C...Momentum integrals of original and removed valence quarks.
38732 IF(IVORG.NE.0) THEN
38733 C...For p/n/pbar/nbar beams can split into d_val and u_val.
38734 C...Isospin conjugation for neutrons
38735 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
38737 IF (KFA.EQ.2112) IAFLP=3-IAFLP
38738 VPAVG=PAVG(IAFLP,Q2)
38739 C...For other baryons average d_val and u_val, like for PDFs.
38740 ELSEIF(KFA.GT.1000) THEN
38741 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
38742 C...For mesons and photon average d_val and u_val and scale by 3/2.
38743 C...Very crude, especially for photon.
38745 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
38747 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
38748 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
38751 C...Now add companions (at X with partner having been at Z=XASSOC).
38752 C...NOTE: due to the assumed simple x scaling, the partner was at what
38753 C...corresponds to a higher Z than XASSOC, if there were intermediate
38754 C...scatterings. Nothing done about that for the moment.
38755 DO 340 IVC=1,NVC(JS,IFL)
38756 C...Skip companions that have been kicked out
38757 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
38761 C...Momentum fraction of the partner quark.
38762 C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
38763 XS=XASSOC(JS,IFL,IVC)
38766 C...Momentum fraction of the companion quark.
38767 C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
38769 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
38770 C...Add to momentum sum, with rescaling compensation factor.
38771 XCFAC=(XREM+XS)/XREM*CMPFAC
38772 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
38777 C...Wait until all flavours treated, then rescale seas and gluon.
38780 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
38781 IF (RSFAC.LE.0D0) THEN
38782 C...First calculate factor needed to exactly restore pz cons.
38783 IF (NRESC.EQ.1) CMPFAC =
38784 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
38785 C...Add a bit of headroom
38787 C...Try a few times if more headroom is needed, then print error message.
38788 IF (NRESC.LE.10) GOTO 345
38790 & '(PYPDFU:) Negative reshaping factor persists!')
38791 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
38795 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
38796 C...Also store resulting distributions in XPQ
38798 DO 360 ISVC=-1,NVC(JS,IFL)
38799 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
38802 C...Save companion reweighting factor for PYPTIS.
38807 C...Allow gluon also in position 21.
38810 C...Check positivity and reset above maximum allowed flavour.
38812 XPQ(KFL)=MAX(0D0,XPQ(KFL))
38813 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
38816 C...Formats for error printouts.
38817 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
38818 5100 FORMAT(' Error: illegal particle code for parton distribution;',
38820 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
38822 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
38823 & ' Removed valence momentum fraction : ',F6.3/
38824 & ' Added companion momentum fraction : ',F6.3/
38825 & ' Resulting rescale factor : ',F6.3)
38827 C...Reset side pointer and return
38833 C*********************************************************************
38836 C...Gives proton parton distribution at small x and/or Q^2 according to
38837 C...correct limiting behaviour.
38839 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
38841 C...Double precision and integer declarations.
38842 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38843 IMPLICIT INTEGER(I-N)
38844 INTEGER PYK,PYCHGE,PYCOMP
38846 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38847 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38848 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38849 COMMON/PYINT1/MINT(400),VINT(400)
38850 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
38852 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
38853 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
38855 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
38859 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
38860 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
38861 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
38863 CALL PYPDFU(KF,X,Q2,XPQ)
38867 C...Reset. Check x.
38871 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38872 WRITE(MSTU(11),5000) X
38876 C...Define valence content.
38880 IF(KF.EQ.2212) THEN
38883 ELSEIF(KF.EQ.-2212) THEN
38886 ELSEIF(KF.EQ.2112) THEN
38889 ELSEIF(KF.EQ.-2112) THEN
38892 ELSEIF(KF.EQ.211) THEN
38896 ELSEIF(KF.EQ.-211) THEN
38900 ELSEIF(MINT(105).LE.223) THEN
38905 ELSEIF(MINT(105).EQ.333) THEN
38910 ELSEIF(MINT(105).EQ.443) THEN
38917 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
38919 CALL PYPDFU(KFC,X,Q2,XPA)
38920 Q2MN=MAX(3D0,VINT(231))
38921 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
38922 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
38924 C...Large Q2 and large x: naive call is enough.
38925 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
38931 C...Small Q2 and large x: dampen boundary value.
38932 ELSEIF(X.GT.XMN) THEN
38934 C...Evaluate at boundary and define dampening factors.
38936 CALL PYPDFU(KFC,X,Q2MN,XPA)
38937 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
38938 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
38940 C...Separate valence and sea parts of parton distribution.
38942 XFV1=XPA(KFV1)-XPA(-KFV1)
38943 XPA(KFV1)=XPA(-KFV1)
38944 XFV2=XPA(KFV2)-XPA(-KFV2)
38945 XPA(KFV2)=XPA(-KFV2)
38947 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38948 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38949 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38950 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38953 C...Dampen valence and sea separately. Put back together.
38955 XPQ(KFL)=FS*XPA(KFL)
38958 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
38959 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
38961 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
38962 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
38963 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
38964 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
38968 C...Large Q2 and small x: interpolate behaviour.
38969 ELSEIF(Q2.GT.Q2MN) THEN
38971 C...Evaluate at extremes and define coefficients for interpolation.
38973 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38976 CALL PYPDFU(KFC,X,Q2B,XPB)
38978 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
38979 FVA=(X/XMN)**0.45D0*FLA
38980 FSA=(X/XMN)**(-0.08D0)*FLA
38983 C...Separate valence and sea parts of parton distribution.
38985 XFVA1=XPA(KFV1)-XPA(-KFV1)
38986 XPA(KFV1)=XPA(-KFV1)
38987 XFVA2=XPA(KFV2)-XPA(-KFV2)
38988 XPA(KFV2)=XPA(-KFV2)
38989 XFVB1=XPB(KFV1)-XPB(-KFV1)
38990 XPB(KFV1)=XPB(-KFV1)
38991 XFVB2=XPB(KFV2)-XPB(-KFV2)
38992 XPB(KFV2)=XPB(-KFV2)
38994 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
38995 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
38996 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
38997 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
38998 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
38999 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
39000 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
39001 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
39004 C...Interpolate for valence and sea. Put back together.
39006 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
39009 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
39010 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
39012 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39013 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39014 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39015 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39019 C...Small Q2 and small x: dampen boundary value and add term.
39022 C...Evaluate at boundary and define dampening factors.
39024 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
39025 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
39027 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
39028 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
39029 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
39030 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
39031 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
39032 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
39034 C...Separate valence and sea parts of parton distribution.
39036 XFV1=XPA(KFV1)-XPA(-KFV1)
39037 XPA(KFV1)=XPA(-KFV1)
39038 XFV2=XPA(KFV2)-XPA(-KFV2)
39039 XPA(KFV2)=XPA(-KFV2)
39041 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
39042 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
39043 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
39044 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
39047 C...Dampen valence and sea separately. Add constant terms.
39048 C...Put back together.
39050 XPQ(KFL)=FSA*XPA(KFL)
39054 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
39056 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
39057 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
39060 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
39062 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39063 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39064 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39065 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39071 C...Format for error printout.
39072 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
39077 C*********************************************************************
39080 C...Gives electron (or muon, or tau) parton distribution.
39082 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
39084 C...Double precision and integer declarations.
39085 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39086 IMPLICIT INTEGER(I-N)
39087 INTEGER PYK,PYCHGE,PYCOMP
39089 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39090 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39091 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39092 COMMON/PYINT1/MINT(400),VINT(400)
39093 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39095 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
39097 C...Interface to PDFLIB.
39098 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
39100 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
39101 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
39102 CHARACTER*20 PARM(20)
39103 DATA VALUE/20*0D0/,PARM/20*' '/
39105 C...Some common constants.
39111 IF(KFA.EQ.13) PME=PMAS(13,1)
39112 IF(KFA.EQ.15) PME=PMAS(15,1)
39113 XL=LOG(MAX(1D-10,X))
39114 X1L=LOG(MAX(1D-10,1D0-X))
39115 HLE=LOG(MAX(3D0,Q2/PME**2))
39116 HBE2=(AEM/PARU(1))*(HLE-1D0)
39118 C...Electron inside electron, see R. Kleiss et al., in Z physics at
39119 C...LEP 1, CERN 89-08, p. 34
39120 IF(MSTP(59).LE.1) THEN
39121 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
39122 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
39123 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
39124 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
39125 & 4D0*XL/(1D0-X)-5D0-X)
39127 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
39128 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
39129 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
39131 C...Zero distribution for very large x and rescale it for intermediate.
39132 IF(X.GT.1D0-1D-10) THEN
39134 ELSEIF(X.GT.1D0-1D-7) THEN
39135 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
39139 C...Photon and (transverse) W- inside electron.
39140 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
39141 IF(MSTP(13).LE.1) THEN
39144 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
39146 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
39147 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
39148 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
39150 C...Electron or positron inside photon inside electron.
39151 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
39152 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
39153 & 2D0*X*(1D0+X)*XL)
39154 XPEL(11)=XPEL(11)+XFSEA
39157 C...Initialize PDFLIB photon parton distributions.
39158 IF(MSTP(56).EQ.2) THEN
39162 VALUE(2)=MSTP(55)/1000
39164 VALUE(3)=MOD(MSTP(55),1000)
39165 IF(MINT(93).NE.3000000+MSTP(55)) THEN
39166 CALL PDFSET_ALICE(PARM,VALUE)
39167 MINT(93)=3000000+MSTP(55)
39171 C...Quarks and gluons inside photon inside electron:
39172 C...numerical convolution required.
39181 IF(ITER.EQ.0) NSTP=2
39183 SXP(KFL)=0.5D0*SXP(KFL)
39186 IF(ITER.EQ.0) WTSTP=0.5D0
39187 C...Pick grid of x_{gamma} values logarithmically even.
39192 XLE=XL*(ISTP-0.5D0)/NSTP
39194 XE=MIN(1D0-1D-10,EXP(XLE))
39195 XG=MIN(1D0-1D-10,X/XE)
39196 C...Evaluate photon inside electron parton distribution for convolution.
39197 XPGP=1D0+(1D0-XE)**2
39198 IF(MSTP(13).LE.1) THEN
39201 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
39203 C...Evaluate photon parton distributions for convolution.
39204 IF(MSTP(56).EQ.1) THEN
39205 IF(MSTP(55).EQ.1) THEN
39206 CALL PYPDGA(XG,Q2,XPGA)
39207 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
39210 IF(MSTP(55).GE.7) P2MX=4.0D0
39211 IF(MSTP(57).EQ.0) Q2MX=P2MX
39213 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39214 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39216 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
39219 IF(MSTP(55).GE.11) P2MX=4.0D0
39220 IF(MSTP(57).EQ.0) Q2MX=P2MX
39222 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39223 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39227 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
39229 ELSEIF(MSTP(56).EQ.2) THEN
39230 C...Call PDFLIB parton distributions.
39232 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39233 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39235 & (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
39236 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
39237 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
39238 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
39239 SXP(3)=SXP(3)+WTSTP*XPGP*STR
39240 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
39241 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
39242 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
39245 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
39246 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
39247 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
39249 C...Put convolution into output arrays.
39251 XPEL(0)=FCONV*SXP(0)
39253 XPEL(KFL)=FCONV*SXP(KFL)
39254 XPEL(-KFL)=XPEL(KFL)
39261 C*********************************************************************
39264 C...Gives photon parton distribution.
39266 SUBROUTINE PYPDGA(X,Q2,XPGA)
39268 C...Double precision and integer declarations.
39269 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39270 IMPLICIT INTEGER(I-N)
39271 INTEGER PYK,PYCHGE,PYCOMP
39273 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39274 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39275 COMMON/PYINT1/MINT(400),VINT(400)
39276 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
39278 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
39279 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
39280 &DGCS(4,3),DGDS(4,3),DGES(4,3)
39282 C...The following data lines are coefficients needed in the
39283 C...Drees and Grassie photon parton distribution parametrization.
39284 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
39285 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
39286 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
39287 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
39288 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
39289 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
39290 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
39291 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
39292 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
39293 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
39294 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
39295 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
39296 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
39297 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
39298 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
39299 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
39300 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
39301 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
39302 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
39303 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
39304 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
39305 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
39306 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
39307 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
39308 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
39309 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
39311 C...Photon parton distribution from Drees and Grassie.
39312 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
39317 IF(MSTP(57).LE.0) THEN
39320 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
39324 IF(Q2.GT.25D0) NF=4
39325 IF(Q2.GT.300D0) NF=5
39329 C...Evaluate gluon content.
39330 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
39331 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
39332 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
39333 XPGL=DGA*X**DGB*X1**DGC
39335 C...Evaluate up- and down-type quark content.
39336 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
39337 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
39338 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
39339 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
39340 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
39341 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
39342 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
39343 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
39344 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
39345 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
39346 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
39348 IF(NF.EQ.4) DGF=10D0
39349 IF(NF.EQ.5) DGF=55D0/6D0
39350 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
39352 XPQU=(XPQS+9D0*XPQN)/6D0
39353 XPQD=(XPQS-4.5D0*XPQN)/6D0
39354 ELSEIF(NF.EQ.4) THEN
39355 XPQU=(XPQS+6D0*XPQN)/8D0
39356 XPQD=(XPQS-6D0*XPQN)/8D0
39358 XPQU=(XPQS+7.5D0*XPQN)/10D0
39359 XPQD=(XPQS-5D0*XPQN)/10D0
39362 C...Put into output arrays.
39367 IF(NF.GE.4) XPGA(4)=AEM*XPQU
39368 IF(NF.GE.5) XPGA(5)=AEM*XPQD
39370 XPGA(-KFL)=XPGA(KFL)
39376 C*********************************************************************
39379 C...Constructs the F2 and parton distributions of the photon
39380 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
39381 C...For F2, c and b are included by the Bethe-Heitler formula;
39382 C...in the 'MSbar' scheme additionally a Cgamma term is added.
39383 C...Contains the SaS sets 1D, 1M, 2D and 2M.
39384 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39386 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
39388 C...Double precision and integer declarations.
39389 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39390 IMPLICIT INTEGER(I-N)
39391 INTEGER PYK,PYCHGE,PYCOMP
39393 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
39395 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
39396 SAVE /PYINT8/,/PYINT9/
39398 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
39399 C...Charm and bottom masses (low to compensate for J/psi etc.).
39400 DATA PMC/1.3D0/, PMB/4.6D0/
39401 C...alpha_em and alpha_em/(2*pi).
39402 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
39403 C...Lambda value for 4 flavours.
39405 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
39407 C...VMD couplings f_V**2/(4*pi).
39408 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
39409 C...Masses for rho (=omega) and phi.
39410 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
39411 C...Number of points in integration for IP2=1.
39429 C...Set Q0 cut-off parameter as function of set used.
39437 C...Scale choice for off-shell photon; common factors.
39442 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
39443 FACNOR=LOG(Q2/Q02)/NSTEP
39444 ELSEIF(IP2.EQ.2) THEN
39446 ELSEIF(IP2.EQ.3) THEN
39448 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
39449 ELSEIF(IP2.EQ.4) THEN
39450 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39451 & ((Q2+P2)*(Q02+P2)))
39452 ELSEIF(IP2.EQ.5) THEN
39453 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39454 & ((Q2+P2)*(Q02+P2)))
39455 P2MX=Q0*SQRT(P2MXA)
39456 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
39457 ELSEIF(IP2.EQ.6) THEN
39458 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39459 & ((Q2+P2)*(Q02+P2)))
39460 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
39462 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39463 & ((Q2+P2)*(Q02+P2)))
39464 P2MX=Q0*SQRT(P2MXA)
39466 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
39467 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
39468 IF(ABS(Q2-Q02).GT.1D-6) THEN
39469 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
39470 ELSEIF(P2.LT.Q02) THEN
39471 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
39477 C...Call VMD parametrization for d quark and use to give rho, omega,
39478 C...phi. Note dipole dampening for off-shell photon.
39479 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39483 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
39484 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
39486 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
39488 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
39489 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
39490 XPVMD(3)=XPVMD(3)+FACS*XFVAL
39491 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
39492 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
39493 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
39494 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
39495 VXPVMD(2)=FRACU*FACUD*XFVAL
39496 VXPVMD(3)=FACS*XFVAL
39497 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
39498 VXPVMD(-2)=FRACU*FACUD*XFVAL
39499 VXPVMD(-3)=FACS*XFVAL
39502 C...Anomalous parametrizations for different strategies
39503 C...for off-shell photons; except full integration.
39505 C...Call anomalous parametrization for d + u + s.
39506 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39508 XPANL(KFL)=FACNOR*XPGA(KFL)
39509 VXPANL(KFL)=FACNOR*VXPGA(KFL)
39512 C...Call anomalous parametrization for c and b.
39513 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39515 XPANH(KFL)=FACNOR*XPGA(KFL)
39516 VXPANH(KFL)=FACNOR*VXPGA(KFL)
39518 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39520 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
39521 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
39525 C...Special option: loop over flavours and integrate over k2.
39527 DO 160 ISTEP=1,NSTEP
39528 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
39529 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
39530 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
39531 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
39532 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
39533 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
39534 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
39536 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
39537 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
39538 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
39539 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
39545 C...Call Bethe-Heitler term expression for charm and bottom.
39546 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
39549 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
39553 C...For MSbar subtraction call C^gamma term expression for d, u, s.
39554 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
39555 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
39557 XPDIR(KFL)=XPGA(KFL)
39561 C...Store result in output array.
39564 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
39565 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
39566 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
39567 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
39568 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
39574 C*********************************************************************
39577 C...Evaluates the VMD parton distributions of a photon,
39578 C...evolved homogeneously from an initial scale P2 to Q2.
39579 C...Does not include dipole suppression factor.
39580 C...ISET is parton distribution set, see above;
39581 C...additionally ISET=0 is used for the evolution of an anomalous photon
39582 C...which branched at a scale P2 and then evolved homogeneously to Q2.
39583 C...ALAM is the 4-flavour Lambda, which is automatically converted
39584 C...to 3- and 5-flavour equivalents as needed.
39585 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39587 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39589 C...Double precision and integer declarations.
39590 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39591 IMPLICIT INTEGER(I-N)
39592 INTEGER PYK,PYCHGE,PYCOMP
39593 C...Local arrays and data.
39594 DIMENSION XPGA(-6:6), VXPGA(-6:6)
39595 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
39604 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39605 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
39606 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
39607 P2EFF=MAX(P2,1.2D0*ALAM3**2)
39608 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
39609 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
39610 Q2EFF=MAX(Q2,P2EFF)
39612 C...Find number of flavours at lower and upper scale.
39614 IF(P2EFF.LT.PMC**2) NFP=3
39615 IF(P2EFF.GT.PMB**2) NFP=5
39617 IF(Q2EFF.LT.PMC**2) NFQ=3
39618 IF(Q2EFF.GT.PMB**2) NFQ=5
39620 C...Find s as sum of 3-, 4- and 5-flavour parts.
39624 IF(NFQ.EQ.3) Q2DIV=Q2EFF
39625 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
39627 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
39629 IF(NFP.EQ.3) P2DIV=PMC**2
39631 IF(NFQ.EQ.5) Q2DIV=PMB**2
39632 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
39636 IF(NFP.EQ.5) P2DIV=P2EFF
39637 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
39640 C...Calculate frequent combinations of x and s.
39647 C...Evaluate homogeneous anomalous parton distributions below or
39648 C...above threshold.
39650 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39651 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39652 XVAL = X * 1.5D0 * (X**2+X1**2)
39656 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
39657 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
39658 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
39659 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
39660 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
39661 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
39662 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
39663 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
39664 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
39665 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
39666 & (2D0*X-1D0)*X*XL**2)
39669 C...Evaluate set 1D parton distributions below or above threshold.
39670 ELSEIF(ISET.EQ.1) THEN
39671 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39672 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39673 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
39674 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
39675 XSEA = 0.100D0 * X1**3.76D0
39677 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
39678 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
39679 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
39680 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
39681 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
39682 & X**0.40D0 * X1**(1.76D0+3D0*S)
39683 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
39684 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
39685 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
39686 XSEA0 = 0.100D0 * X1**3.76D0
39689 C...Evaluate set 1M parton distributions below or above threshold.
39690 ELSEIF(ISET.EQ.2) THEN
39691 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39692 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39693 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
39694 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
39697 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
39698 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
39699 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
39700 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
39701 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
39702 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
39703 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
39704 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
39709 C...Evaluate set 2D parton distributions below or above threshold.
39710 ELSEIF(ISET.EQ.3) THEN
39711 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39712 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39713 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
39714 XGLU = 1.925D0 * X1**2
39715 XSEA = 0.242D0 * X1**4
39717 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
39718 & X**(0.46D0+0.25D0*S) *
39719 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
39720 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
39721 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
39722 & EXP(-18.67D0*S) *
39723 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
39724 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
39725 & XL**(9.3D0*S/(1D0+1.7D0*S))
39726 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
39727 & (1D0-0.607D0*S+21.95D0*S2) *
39728 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
39729 XSEA0 = 0.242D0 * X1**4
39732 C...Evaluate set 2M parton distributions below or above threshold.
39733 ELSEIF(ISET.EQ.4) THEN
39734 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39735 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39736 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
39737 XGLU = 1.808D0 * X1**2
39738 XSEA = 0.209D0 * X1**4
39740 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
39741 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
39742 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
39743 & XL**(5.15D0*S/(1D0+2D0*S)) +
39744 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
39745 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
39746 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
39747 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
39748 & XL**(10.9D0*S/(1D0+2.5D0*S))
39749 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
39750 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
39751 & X1**(4D0+S) * XL**(0.45D0*S)
39752 XSEA0 = 0.209D0 * X1**4
39756 C...Threshold factors for c and b sea.
39757 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39759 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39760 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39762 XCHM=XSEA*(1D0-(SCH/SLL)**2)
39764 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
39768 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39769 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39771 XBOT=XSEA*(1D0-(SBT/SLL)**2)
39773 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
39777 C...Fill parton distributions.
39784 XPGA(KFA)=XPGA(KFA)+XVAL
39786 XPGA(-KFL)=XPGA(KFL)
39794 C*********************************************************************
39797 C...Evaluates the parton distributions of the anomalous photon,
39798 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
39799 C...KF=0 gives the sum over (up to) 5 flavours,
39800 C...KF<0 limits to flavours up to abs(KF),
39801 C...KF>0 is for flavour KF only.
39802 C...ALAM is the 4-flavour Lambda, which is automatically converted
39803 C...to 3- and 5-flavour equivalents as needed.
39804 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39806 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39808 C...Double precision and integer declarations.
39809 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39810 IMPLICIT INTEGER(I-N)
39811 INTEGER PYK,PYCHGE,PYCOMP
39812 C...Local arrays and data.
39813 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
39814 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
39821 IF(Q2.LE.P2) RETURN
39824 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39825 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
39827 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
39828 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
39829 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
39830 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
39831 Q2EFF=MAX(Q2,P2EFF)
39834 C...Find number of flavours at lower and upper scale.
39836 IF(P2EFF.LT.PMC**2) NFP=3
39837 IF(P2EFF.GT.PMB**2) NFP=5
39839 IF(Q2EFF.LT.PMC**2) NFQ=3
39840 IF(Q2EFF.GT.PMB**2) NFQ=5
39842 C...Define range of flavour loop.
39846 ELSEIF(KF.LT.0) THEN
39854 C...Loop over flavours the photon can branch into.
39855 DO 110 KFL=KFLMN,KFLMX
39857 C...Light flavours: calculate t range and (approximate) s range.
39858 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
39859 TDIFF=LOG(Q2EFF/P2EFF)
39860 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39861 & LOG(P2EFF/ALAMSQ(NFQ)))
39862 IF(NFQ.GT.NFP) THEN
39864 IF(NFQ.EQ.4) Q2DIV=PMC**2
39865 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
39866 & LOG(P2EFF/ALAMSQ(NFQ)))
39867 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
39868 & LOG(P2EFF/ALAMSQ(NFQ-1)))
39869 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
39871 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
39873 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
39874 & LOG(P2EFF/ALAMSQ(4)))
39875 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
39876 & LOG(P2EFF/ALAMSQ(3)))
39877 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
39880 C...u and s quark do not need a separate treatment when d has been done.
39881 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
39883 C...Charm: as above, but only include range above c threshold.
39884 ELSEIF(KFL.EQ.4) THEN
39885 IF(Q2.LE.PMC**2) GOTO 110
39886 P2EFF=MAX(P2EFF,PMC**2)
39887 Q2EFF=MAX(Q2EFF,P2EFF)
39888 TDIFF=LOG(Q2EFF/P2EFF)
39889 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39890 & LOG(P2EFF/ALAMSQ(NFQ)))
39891 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
39893 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
39894 & LOG(P2EFF/ALAMSQ(NFQ)))
39895 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
39896 & LOG(P2EFF/ALAMSQ(NFQ-1)))
39897 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
39900 C...Bottom: as above, but only include range above b threshold.
39901 ELSEIF(KFL.EQ.5) THEN
39902 IF(Q2.LE.PMB**2) GOTO 110
39903 P2EFF=MAX(P2EFF,PMB**2)
39904 Q2EFF=MAX(Q2,P2EFF)
39905 TDIFF=LOG(Q2EFF/P2EFF)
39906 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39907 & LOG(P2EFF/ALAMSQ(NFQ)))
39910 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
39912 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
39913 FAC=AEM2PI*2D0*CHSQ*TDIFF
39915 C...Evaluate parton distributions (normalized to unit momentum sum).
39916 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
39917 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
39918 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
39919 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
39920 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
39921 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
39922 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
39923 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
39924 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
39925 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
39926 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
39927 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
39929 C...Threshold factors for c and b sea.
39930 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39932 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39933 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39934 XCHM=XSEA*(1D0-(SCH/SLL)**3)
39937 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39938 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39939 XBOT=XSEA*(1D0-(SBT/SLL)**3)
39943 C...Add contribution of each valence flavour.
39944 XPGA(0)=XPGA(0)+FAC*XGLU
39945 XPGA(1)=XPGA(1)+FAC*XSEA
39946 XPGA(2)=XPGA(2)+FAC*XSEA
39947 XPGA(3)=XPGA(3)+FAC*XSEA
39948 XPGA(4)=XPGA(4)+FAC*XCHM
39949 XPGA(5)=XPGA(5)+FAC*XBOT
39950 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
39951 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
39954 XPGA(-KFL)=XPGA(KFL)
39955 VXPGA(-KFL)=VXPGA(KFL)
39962 C*********************************************************************
39965 C...Evaluates the Bethe-Heitler cross section for heavy flavour
39967 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39969 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
39971 C...Double precision and integer declarations.
39972 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39973 IMPLICIT INTEGER(I-N)
39974 INTEGER PYK,PYCHGE,PYCOMP
39977 DATA AEM2PI/0.0011614D0/
39983 C...Check kinematics limits.
39984 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
39986 BETA2=1D0-4D0*PM2/W2
39987 IF(BETA2.LT.1D-10) RETURN
39991 C...Simple case: P2 = 0.
39992 IF(P2.LT.1D-4) THEN
39993 IF(BETA.LT.0.99D0) THEN
39994 XBL=LOG((1D0+BETA)/(1D0-BETA))
39996 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
39998 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
39999 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
40001 C...Complicated case: P2 > 0, based on approximation of
40002 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
40004 RPQ=1D0-4D0*X**2*P2/Q2
40005 IF(RPQ.GT.1D-10) THEN
40006 RPBE=SQRT(RPQ*BETA2)
40007 IF(RPBE.LT.0.99D0) THEN
40008 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
40009 XBI=2D0*RPBE/(1D0-RPBE**2)
40011 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
40012 XBL=LOG((1D0+RPBE)**2/RPBESN)
40013 XBI=2D0*RPBE/RPBESN
40015 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
40016 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
40017 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
40021 C...Multiply by charge-squared etc. to get parton distribution.
40023 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
40024 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
40029 C*********************************************************************
40032 C...Evaluates the direct contribution, i.e. the C^gamma term,
40033 C...as needed in MSbar parametrizations.
40034 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40036 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
40038 C...Double precision and integer declarations.
40039 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40040 IMPLICIT INTEGER(I-N)
40041 INTEGER PYK,PYCHGE,PYCOMP
40042 C...Local array and data.
40043 DIMENSION XPGA(-6:6)
40044 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
40051 C...Evaluate common x-dependent expression.
40052 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
40053 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
40055 C...d, u, s part by simple charge factor.
40056 XPGA(1)=(1D0/9D0)*CGAM
40057 XPGA(2)=(4D0/9D0)*CGAM
40058 XPGA(3)=(1D0/9D0)*CGAM
40060 C...Also fill for antiquarks.
40068 C*********************************************************************
40071 C...Gives pi+ parton distribution according to two different
40072 C...parametrizations.
40074 SUBROUTINE PYPDPI(X,Q2,XPPI)
40076 C...Double precision and integer declarations.
40077 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40078 IMPLICIT INTEGER(I-N)
40079 INTEGER PYK,PYCHGE,PYCOMP
40081 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40082 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40083 COMMON/PYINT1/MINT(400),VINT(400)
40084 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40086 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
40088 C...The following data lines are coefficients needed in the
40089 C...Owens pion parton distribution parametrizations, see below.
40090 C...Expansion coefficients for up and down valence quark distributions.
40091 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
40092 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40093 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40094 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40095 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
40096 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40097 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40098 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40099 C...Expansion coefficients for gluon distribution.
40100 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
40101 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
40102 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
40103 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
40104 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
40105 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
40106 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
40107 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
40108 C...Expansion coefficients for (up+down+strange) quark sea distribution.
40109 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
40110 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40111 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
40112 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
40113 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
40114 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40115 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
40116 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
40117 C...Expansion coefficients for charm quark sea distribution.
40118 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
40119 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
40120 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
40121 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
40122 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
40123 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
40124 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
40125 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
40127 C...Euler's beta function, requires ordinary Gamma function
40128 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
40130 C...Reset output array.
40135 IF(MSTP(53).LE.2) THEN
40136 C...Pion parton distributions from Owens.
40137 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
40139 C...Determine set, Lambda and s expansion variable.
40141 IF(NSET.EQ.1) ALAM=0.2D0
40142 IF(NSET.EQ.2) ALAM=0.4D0
40144 IF(MSTP(57).LE.0) THEN
40147 Q2IN=MIN(2D3,MAX(4D0,Q2))
40148 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
40151 C...Calculate parton distributions.
40154 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
40155 & COW(3,IS,KFL,NSET)*SD**2
40158 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
40160 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
40165 C...Put into output array.
40168 XPPI(2)=XQ(1)+XQ(3)/6D0
40171 XPPI(-1)=XQ(1)+XQ(3)/6D0
40176 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
40177 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40181 C...Determine s expansion variable and some x expressions.
40183 IF(MSTP(57).LE.0) THEN
40186 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
40187 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
40193 C...Evaluate valence, gluon and sea distributions.
40194 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
40195 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
40196 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
40198 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
40199 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
40201 & (1D0-X)**(0.390D0+1.053D0*SD)
40202 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
40204 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
40206 & XL**(2.538D0-0.763D0*SD)
40207 IF(SD.LE.0.888D0) THEN
40210 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
40212 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
40215 IF(SD.LE.1.351D0) THEN
40218 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
40219 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
40223 C...Put into output array.
40231 XPPI(-KFL)=XPPI(KFL)
40233 XPPI(2)=XPPI(2)+XFVAL
40234 XPPI(-1)=XPPI(-1)+XFVAL
40240 C*********************************************************************
40243 C...Gives proton parton distributions according to a few different
40244 C...parametrizations.
40246 SUBROUTINE PYPDPR(X,Q2,XPPR)
40248 C...Double precision and integer declarations.
40249 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40250 IMPLICIT INTEGER(I-N)
40251 INTEGER PYK,PYCHGE,PYCOMP
40253 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40254 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40255 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40256 COMMON/PYINT1/MINT(400),VINT(400)
40257 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
40258 C...Arrays and data.
40259 DIMENSION XPPR(-6:6),Q2MIN(16)
40260 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
40261 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
40263 C...Reset output array.
40268 C...Common preliminaries.
40269 NSET=MAX(1,MIN(16,MSTP(51)))
40270 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
40271 VINT(231)=Q2MIN(NSET)
40272 IF(MSTP(57).EQ.0) THEN
40275 Q2L=MAX(Q2MIN(NSET),Q2)
40278 IF(NSET.GE.1.AND.NSET.LE.3) THEN
40279 C...Interface to the CTEQ 3 parton distributions.
40280 QRT=SQRT(MAX(1D0,Q2L))
40282 C...Loop over flavours.
40285 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
40286 ELSEIF(I.LE.2) THEN
40287 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
40293 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
40294 C...Interface to the GRV 94 distributions.
40296 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40297 ELSEIF(NSET.EQ.5) THEN
40298 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40300 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40303 C...Put into output array.
40305 XPPR(-1)=0.5D0*(UDB+DEL)
40306 XPPR(-2)=0.5D0*(UDB-DEL)
40310 XPPR(1)=DV+XPPR(-1)
40311 XPPR(2)=UV+XPPR(-2)
40316 ELSEIF(NSET.EQ.7) THEN
40317 C...Interface to the CTEQ 5L parton distributions.
40318 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
40319 C...freezing x*f(x,Q2) at borders.
40320 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
40321 XIN=MAX(1D-6,MIN(1D0,X))
40323 C...Loop over flavours (with u <-> d notation mismatch).
40324 SUMUDB=PYCT5L(-1,XIN,QRT)
40325 RATUDB=PYCT5L(-2,XIN,QRT)
40328 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
40329 ELSEIF(I.EQ.2) THEN
40330 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
40331 ELSEIF(I.EQ.-1) THEN
40332 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
40333 ELSEIF(I.EQ.-2) THEN
40334 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
40336 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
40337 IF(I.LT.0) XPPR(-I)=XPPR(I)
40341 ELSEIF(NSET.EQ.8) THEN
40342 C...Interface to the CTEQ 5M1 parton distributions.
40343 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
40344 XIN=MAX(1D-6,MIN(1D0,X))
40346 C...Loop over flavours (with u <-> d notation mismatch).
40347 SUMUDB=PYCT5M(-1,XIN,QRT)
40348 RATUDB=PYCT5M(-2,XIN,QRT)
40351 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
40352 ELSEIF(I.EQ.2) THEN
40353 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
40354 ELSEIF(I.EQ.-1) THEN
40355 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
40356 ELSEIF(I.EQ.-2) THEN
40357 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
40359 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
40360 IF(I.LT.0) XPPR(-I)=XPPR(I)
40364 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
40365 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
40366 C...obsolete but offers backwards compatibility.
40367 CALL PYPDPO(X,Q2L,XPPR)
40369 C...Symmetric choice for debugging only
40370 ELSEIF(NSET.EQ.16) THEN
40388 C*********************************************************************
40391 C...Gives the CTEQ 3 parton distribution function sets in
40392 C...parametrized form, of October 24, 1994.
40393 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
40394 C...J. Qiu, W.K. Tung and H. Weerts.
40396 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
40398 C...Double precision declaration.
40399 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40400 IMPLICIT INTEGER(I-N)
40402 C...Data on Lambda values of fits, minimum Q and quark masses.
40403 DIMENSION ALM(3), QMS(4:6)
40404 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
40405 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
40407 C....Check flavour thresholds. Set up QI for SB.
40410 IF(Q .LE. QMS(IP)) THEN
40419 C...Use "standard lambda" of parametrization program for expansion.
40421 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
40426 C...Expansion for CTEQ3L.
40427 IF(ISET .EQ. 1) THEN
40428 IF(IPRT .EQ. 2) THEN
40429 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
40431 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
40432 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
40433 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
40434 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
40435 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
40436 ELSEIF(IPRT .EQ. 1) THEN
40437 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
40439 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
40440 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
40441 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
40442 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
40443 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
40444 ELSEIF(IPRT .EQ. 0) THEN
40445 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
40447 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
40448 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
40449 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
40450 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
40451 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
40452 ELSEIF(IPRT .EQ. -1) THEN
40453 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
40455 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
40456 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
40457 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
40458 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
40459 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
40460 ELSEIF(IPRT .EQ. -2) THEN
40461 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
40463 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
40464 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
40465 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
40466 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
40467 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
40468 ELSEIF(IPRT .EQ. -3) THEN
40469 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
40471 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
40472 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
40473 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
40474 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
40475 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
40476 ELSEIF(IPRT .EQ. -4) THEN
40477 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
40479 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
40480 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
40481 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
40482 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
40483 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
40484 ELSEIF(IPRT .EQ. -5) THEN
40485 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
40487 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
40488 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
40489 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
40490 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
40491 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
40492 ELSEIF(IPRT .EQ. -6) THEN
40493 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
40495 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
40496 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
40497 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
40498 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
40499 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
40502 C...Expansion for CTEQ3M.
40503 ELSEIF(ISET .EQ. 2) THEN
40504 IF(IPRT .EQ. 2) THEN
40505 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
40507 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
40508 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
40509 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
40510 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
40511 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
40512 ELSEIF(IPRT .EQ. 1) THEN
40513 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
40515 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
40516 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
40517 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
40518 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
40519 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
40520 ELSEIF(IPRT .EQ. 0) THEN
40521 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
40523 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
40524 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
40525 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
40526 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
40527 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
40528 ELSEIF(IPRT .EQ. -1) THEN
40529 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
40531 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
40532 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
40533 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
40534 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
40535 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
40536 ELSEIF(IPRT .EQ. -2) THEN
40537 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
40539 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
40540 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
40541 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
40542 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
40543 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
40544 ELSEIF(IPRT .EQ. -3) THEN
40545 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
40547 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
40548 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
40549 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
40550 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
40551 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
40552 ELSEIF(IPRT .EQ. -4) THEN
40553 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
40555 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
40556 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
40557 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
40558 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
40559 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
40560 ELSEIF(IPRT .EQ. -5) THEN
40561 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
40563 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
40564 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
40565 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
40566 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
40567 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
40568 ELSEIF(IPRT .EQ. -6) THEN
40569 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
40571 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
40572 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
40573 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
40574 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
40575 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
40578 C...Expansion for CTEQ3D.
40579 ELSEIF(ISET .EQ. 3) THEN
40580 IF(IPRT .EQ. 2) THEN
40581 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
40583 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
40584 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
40585 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
40586 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
40587 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
40588 ELSEIF(IPRT .EQ. 1) THEN
40589 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
40591 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
40592 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
40593 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
40594 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
40595 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
40596 ELSEIF(IPRT .EQ. 0) THEN
40597 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
40599 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
40600 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
40601 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
40602 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
40603 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
40604 ELSEIF(IPRT .EQ. -1) THEN
40605 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
40607 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
40608 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
40609 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
40610 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
40611 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
40612 ELSEIF(IPRT .EQ. -2) THEN
40613 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
40615 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
40616 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
40617 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
40618 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
40619 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
40620 ELSEIF(IPRT .EQ. -3) THEN
40621 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
40623 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
40624 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
40625 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
40626 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
40627 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
40628 ELSEIF(IPRT .EQ. -4) THEN
40629 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
40631 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
40632 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
40633 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
40634 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
40635 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
40636 ELSEIF(IPRT .EQ. -5) THEN
40637 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
40639 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
40640 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
40641 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
40642 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
40643 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
40644 ELSEIF(IPRT .EQ. -6) THEN
40645 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
40647 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
40648 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
40649 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
40650 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
40651 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
40655 C...Calculation of x * f(x, Q).
40656 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
40657 & *(LOG(1D0+1D0/X))**A5 )
40662 C*********************************************************************
40665 C...Gives the GRV 94 L (leading order) parton distribution function set
40666 C...in parametrized form.
40667 C...Authors: M. Glueck, E. Reya and A. Vogt.
40669 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40671 C...Double precision declaration.
40672 IMPLICIT DOUBLE PRECISION (A - Z)
40674 C...Common expressions.
40676 LAM2 = 0.2322D0 * 0.2322D0
40677 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40683 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
40684 AKU = 0.590D0 - 0.024D0 * S
40685 BKU = 0.131D0 + 0.063D0 * S
40686 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
40687 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
40688 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
40689 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
40690 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40693 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
40695 BKD = 0.486D0 + 0.062D0 * S
40696 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
40697 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
40698 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
40699 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
40700 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40703 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
40704 AKE = 0.409D0 - 0.005D0 * S
40705 BKE = 0.799D0 + 0.071D0 * S
40706 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
40707 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
40709 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
40710 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40715 AKX = 0.410D0 - 0.232D0 * S
40716 BKX = 0.534D0 - 0.457D0 * S
40717 AGX = 0.890D0 - 0.140D0 * S
40719 CX = 0.320D0 + 0.683D0 * S
40720 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
40721 EX = 4.119D0 + 1.713D0 * S
40722 ESX = 0.682D0 + 2.978D0 * S
40723 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40730 AKS = 1.798D0 - 0.596D0 * S
40731 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
40732 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
40733 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
40734 EST = 3.981D0 + 1.638D0 * S
40736 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40744 BC = 4.24D0 - 0.804D0 * S
40745 DCT = 3.46D0 - 1.076D0 * S
40746 ECT = 4.61D0 + 1.49D0 * S
40747 ESC = 2.555D0 + 1.961D0 * S
40748 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40757 DBT = 2.929D0 + 1.396D0 * S
40758 EBT = 4.71D0 + 1.514D0 * S
40759 ESB = 4.02D0 + 1.239D0 * S
40760 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40765 AKG = 1.742D0 - 0.930D0 * S
40766 BKG = - 0.399D0 * S2
40767 AG = 7.486D0 - 2.185D0 * S
40768 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
40769 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
40770 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
40771 EG = 0.807D0 + 2.005D0 * S
40772 ESG = 3.841D0 + 0.316D0 * S
40773 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
40779 C*********************************************************************
40782 C...Gives the GRV 94 M (MSbar) parton distribution function set
40783 C...in parametrized form.
40784 C...Authors: M. Glueck, E. Reya and A. Vogt.
40786 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40788 C...Double precision declaration.
40789 IMPLICIT DOUBLE PRECISION (A - Z)
40791 C...Common expressions.
40793 LAM2 = 0.248D0 * 0.248D0
40794 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40800 NU = 1.304D0 + 0.863D0 * S
40801 AKU = 0.558D0 - 0.020D0 * S
40803 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
40804 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
40805 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
40806 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
40807 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40810 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
40811 AKD = 0.270D0 - 0.019D0 * S
40813 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
40814 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
40815 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
40816 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
40817 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40820 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
40821 AKE = 0.409D0 - 0.007D0 * S
40822 BKE = 0.782D0 + 0.082D0 * S
40823 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
40824 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
40826 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
40827 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40835 BGX = 3.210D0 - 1.866D0 * S
40837 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
40838 EX = 3.077D0 + 1.446D0 * S
40839 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
40840 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40847 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
40848 AS = -4.329D0 + 1.131D0 * S
40849 BS = 9.568D0 - 1.744D0 * S
40850 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
40851 EST = 3.031D0 + 1.639D0 * S
40852 ESS = 5.837D0 + 0.815D0 * S
40853 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40859 AKC = -0.625D0 - 0.523D0 * S
40861 BC = 1.896D0 + 1.616D0 * S
40862 DCT = 4.12D0 + 0.683D0 * S
40863 ECT = 4.36D0 + 1.328D0 * S
40864 ESC = 0.677D0 + 0.679D0 * S
40865 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40871 AKB = - 0.193D0 * S
40874 DBT = 3.447D0 + 0.927D0 * S
40875 EBT = 4.68D0 + 1.259D0 * S
40876 ESB = 1.892D0 + 2.199D0 * S
40877 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40882 AKG = 1.724D0 + 0.157D0 * S
40883 BKG = 0.800D0 + 1.016D0 * S
40884 AG = 7.517D0 - 2.547D0 * S
40885 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
40886 CG = 4.039D0 + 1.491D0 * S
40887 DG = 3.404D0 + 0.830D0 * S
40888 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
40889 ESG = 3.256D0 - 0.436D0 * S
40890 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
40895 C*********************************************************************
40898 C...Gives the GRV 94 D (DIS) parton distribution function set
40899 C...in parametrized form.
40900 C...Authors: M. Glueck, E. Reya and A. Vogt.
40902 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40904 C...Double precision declaration.
40905 IMPLICIT DOUBLE PRECISION (A - Z)
40907 C...Common expressions.
40909 LAM2 = 0.248D0 * 0.248D0
40910 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40916 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
40917 AKU = 0.563D0 - 0.025D0 * S
40918 BKU = 0.054D0 + 0.154D0 * S
40919 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
40920 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
40921 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
40922 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
40923 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40926 ND = 0.156D0 - 0.017D0 * S
40927 AKD = 0.299D0 - 0.022D0 * S
40928 BKD = 0.259D0 - 0.015D0 * S
40929 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
40930 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
40931 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
40932 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
40933 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40936 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
40937 AKE = 0.419D0 - 0.013D0 * S
40938 BKE = 1.064D0 - 0.038D0 * S
40939 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
40940 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
40941 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
40942 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
40943 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40948 AKX = 0.326D0 + 0.150D0 * S
40949 BKX = 0.956D0 + 0.405D0 * S
40951 BGX = 3.794D0 - 2.359D0 * DS
40953 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
40954 EX = 3.049D0 + 1.597D0 * S
40955 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
40956 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40963 AKS = 1.415D0 - 0.641D0 * DS
40964 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
40965 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
40966 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
40967 EST = 4.546D0 + 0.372D0 * S2
40968 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
40969 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40975 AKC = -0.625D0 - 0.523D0 * S
40977 BC = 1.896D0 + 1.616D0 * S
40978 DCT = 4.12D0 + 0.683D0 * S
40979 ECT = 4.36D0 + 1.328D0 * S
40980 ESC = 0.677D0 + 0.679D0 * S
40981 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40987 AKB = - 0.193D0 * S
40990 DBT = 3.447D0 + 0.927D0 * S
40991 EBT = 4.68D0 + 1.259D0 * S
40992 ESB = 1.892D0 + 2.199D0 * S
40993 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40999 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
41000 AG = 25.09D0 - 7.935D0 * S
41001 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
41002 CG = 590.3D0 - 173.8D0 * S
41003 DG = 5.196D0 + 1.857D0 * S
41004 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
41005 ESG = 3.232D0 - 0.542D0 * S
41006 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
41011 C*********************************************************************
41014 C...Auxiliary for the GRV 94 parton distribution functions
41015 C...for u and d valence and d-u sea.
41016 C...Authors: M. Glueck, E. Reya and A. Vogt.
41018 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
41020 C...Double precision declaration.
41021 IMPLICIT DOUBLE PRECISION (A - Z)
41025 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
41031 C*********************************************************************
41034 C...Auxiliary for the GRV 94 parton distribution functions
41035 C...for d+u sea and gluon.
41036 C...Authors: M. Glueck, E. Reya and A. Vogt.
41038 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
41040 C...Double precision declaration.
41041 IMPLICIT DOUBLE PRECISION (A - Z)
41045 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
41046 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
41051 C*********************************************************************
41054 C...Auxiliary for the GRV 94 parton distribution functions
41055 C...for s, c and b sea.
41056 C...Authors: M. Glueck, E. Reya and A. Vogt.
41058 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
41060 C...Double precision declaration.
41061 IMPLICIT DOUBLE PRECISION (A - Z)
41069 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
41070 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
41076 C*********************************************************************
41079 C...Auxiliary function for parametrization of CTEQ5L.
41080 C...Author: J. Pumplin 9/99.
41082 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
41083 C...in Parametrized Form
41084 C... September 15, 1999
41086 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
41087 C... CTEQ5 PPARTON DISTRIBUTIONS"
41090 C...The CTEQ5M1 set given here is an updated version of the original
41091 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
41092 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
41093 C...almost all applications.
41094 C...The improvement is in the QCD evolution which is now more
41095 C...accurate, and which agrees completely with the benchmark work
41096 C...of the HERA 96/97 Workshop.
41097 C...The differences between the parametrized and the corresponding
41098 C...table versions (on which it is based) are of similar order as
41099 C...between the two version.
41101 C...!! Because accurate parametrizations over a wide range of (x,Q)
41102 C...is hard to obtain, only the most widely used sets CTEQ5M and
41103 C...CTEQ5L are available in parametrized form for now.
41105 C...These parametrizations were obtained by Jon Pumplin.
41107 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
41108 C -------------------------------------------------------------------
41109 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
41110 C 3 CTEQ5L Leading Order 0.127 192 146
41111 C -------------------------------------------------------------------
41112 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
41113 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
41116 C...The two Iset value are adopted to agree with the standard table
41119 C...Range of validity:
41120 C...The range of (x, Q) covered by this parametrization of the QCD
41121 C...evolved parton distributions is 1E-6 < x < 1 ;
41122 C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
41123 C...data only in a subset of that region; and the assumed DGLAP
41124 C...evolution is unlikely to be valid for all of it either.
41126 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
41127 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
41128 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
41129 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
41131 FUNCTION PYCT5L(IFL,X,Q)
41133 C...Double precision declaration.
41134 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41135 IMPLICIT INTEGER(I-N)
41137 PARAMETER (NEX=8, NLF=2)
41138 DIMENSION AM(0:NEX,0:NLF,-5:2)
41139 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41140 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41141 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41142 DIMENSION AF(0:NEX)
41144 DATA MEXVEC( 2) / 8 /
41145 DATA MLFVEC( 2) / 2 /
41146 DATA UT1VEC( 2) / 0.4971265E+01 /
41147 DATA UT2VEC( 2) / -0.1105128E+01 /
41148 DATA ALFVEC( 2) / 0.2987216E+00 /
41149 DATA QMAVEC( 2) / 0.0000000E+00 /
41150 DATA (AM( 0,K, 2),K=0, 2)
41151 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
41152 DATA (AM( 1,K, 2),K=0, 2)
41153 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
41154 DATA (AM( 2,K, 2),K=0, 2)
41155 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
41156 DATA (AM( 3,K, 2),K=0, 2)
41157 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
41158 DATA (AM( 4,K, 2),K=0, 2)
41159 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
41160 DATA (AM( 5,K, 2),K=0, 2)
41161 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
41162 DATA (AM( 6,K, 2),K=0, 2)
41163 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
41164 DATA (AM( 7,K, 2),K=0, 2)
41165 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
41166 DATA (AM( 8,K, 2),K=0, 2)
41167 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
41169 DATA MEXVEC( 1) / 8 /
41170 DATA MLFVEC( 1) / 2 /
41171 DATA UT1VEC( 1) / 0.2612618E+01 /
41172 DATA UT2VEC( 1) / -0.1258304E+06 /
41173 DATA ALFVEC( 1) / 0.3407552E+00 /
41174 DATA QMAVEC( 1) / 0.0000000E+00 /
41175 DATA (AM( 0,K, 1),K=0, 2)
41176 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
41177 DATA (AM( 1,K, 1),K=0, 2)
41178 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
41179 DATA (AM( 2,K, 1),K=0, 2)
41180 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
41181 DATA (AM( 3,K, 1),K=0, 2)
41182 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
41183 DATA (AM( 4,K, 1),K=0, 2)
41184 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
41185 DATA (AM( 5,K, 1),K=0, 2)
41186 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
41187 DATA (AM( 6,K, 1),K=0, 2)
41188 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
41189 DATA (AM( 7,K, 1),K=0, 2)
41190 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
41191 DATA (AM( 8,K, 1),K=0, 2)
41192 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
41194 DATA MEXVEC( 0) / 8 /
41195 DATA MLFVEC( 0) / 2 /
41196 DATA UT1VEC( 0) / -0.4656819E+00 /
41197 DATA UT2VEC( 0) / -0.2742390E+03 /
41198 DATA ALFVEC( 0) / 0.4491863E+00 /
41199 DATA QMAVEC( 0) / 0.0000000E+00 /
41200 DATA (AM( 0,K, 0),K=0, 2)
41201 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
41202 DATA (AM( 1,K, 0),K=0, 2)
41203 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
41204 DATA (AM( 2,K, 0),K=0, 2)
41205 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
41206 DATA (AM( 3,K, 0),K=0, 2)
41207 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
41208 DATA (AM( 4,K, 0),K=0, 2)
41209 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
41210 DATA (AM( 5,K, 0),K=0, 2)
41211 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
41212 DATA (AM( 6,K, 0),K=0, 2)
41213 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
41214 DATA (AM( 7,K, 0),K=0, 2)
41215 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
41216 DATA (AM( 8,K, 0),K=0, 2)
41217 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
41219 DATA MEXVEC(-1) / 8 /
41220 DATA MLFVEC(-1) / 2 /
41221 DATA UT1VEC(-1) / 0.3862583E+01 /
41222 DATA UT2VEC(-1) / -0.1265969E+01 /
41223 DATA ALFVEC(-1) / 0.2457668E+00 /
41224 DATA QMAVEC(-1) / 0.0000000E+00 /
41225 DATA (AM( 0,K,-1),K=0, 2)
41226 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
41227 DATA (AM( 1,K,-1),K=0, 2)
41228 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
41229 DATA (AM( 2,K,-1),K=0, 2)
41230 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
41231 DATA (AM( 3,K,-1),K=0, 2)
41232 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
41233 DATA (AM( 4,K,-1),K=0, 2)
41234 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
41235 DATA (AM( 5,K,-1),K=0, 2)
41236 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
41237 DATA (AM( 6,K,-1),K=0, 2)
41238 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
41239 DATA (AM( 7,K,-1),K=0, 2)
41240 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
41241 DATA (AM( 8,K,-1),K=0, 2)
41242 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
41244 DATA MEXVEC(-2) / 7 /
41245 DATA MLFVEC(-2) / 2 /
41246 DATA UT1VEC(-2) / 0.1895615E+00 /
41247 DATA UT2VEC(-2) / -0.3069097E+01 /
41248 DATA ALFVEC(-2) / 0.5293999E+00 /
41249 DATA QMAVEC(-2) / 0.0000000E+00 /
41250 DATA (AM( 0,K,-2),K=0, 2)
41251 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
41252 DATA (AM( 1,K,-2),K=0, 2)
41253 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
41254 DATA (AM( 2,K,-2),K=0, 2)
41255 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
41256 DATA (AM( 3,K,-2),K=0, 2)
41257 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
41258 DATA (AM( 4,K,-2),K=0, 2)
41259 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
41260 DATA (AM( 5,K,-2),K=0, 2)
41261 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
41262 DATA (AM( 6,K,-2),K=0, 2)
41263 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
41264 DATA (AM( 7,K,-2),K=0, 2)
41265 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
41267 DATA MEXVEC(-3) / 7 /
41268 DATA MLFVEC(-3) / 2 /
41269 DATA UT1VEC(-3) / 0.3753257E+01 /
41270 DATA UT2VEC(-3) / -0.1113085E+01 /
41271 DATA ALFVEC(-3) / 0.3713141E+00 /
41272 DATA QMAVEC(-3) / 0.0000000E+00 /
41273 DATA (AM( 0,K,-3),K=0, 2)
41274 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
41275 DATA (AM( 1,K,-3),K=0, 2)
41276 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
41277 DATA (AM( 2,K,-3),K=0, 2)
41278 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
41279 DATA (AM( 3,K,-3),K=0, 2)
41280 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
41281 DATA (AM( 4,K,-3),K=0, 2)
41282 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
41283 DATA (AM( 5,K,-3),K=0, 2)
41284 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
41285 DATA (AM( 6,K,-3),K=0, 2)
41286 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
41287 DATA (AM( 7,K,-3),K=0, 2)
41288 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
41290 DATA MEXVEC(-4) / 7 /
41291 DATA MLFVEC(-4) / 2 /
41292 DATA UT1VEC(-4) / 0.4400772E+01 /
41293 DATA UT2VEC(-4) / -0.1356116E+01 /
41294 DATA ALFVEC(-4) / 0.3712017E-01 /
41295 DATA QMAVEC(-4) / 0.1300000E+01 /
41296 DATA (AM( 0,K,-4),K=0, 2)
41297 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
41298 DATA (AM( 1,K,-4),K=0, 2)
41299 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
41300 DATA (AM( 2,K,-4),K=0, 2)
41301 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
41302 DATA (AM( 3,K,-4),K=0, 2)
41303 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
41304 DATA (AM( 4,K,-4),K=0, 2)
41305 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
41306 DATA (AM( 5,K,-4),K=0, 2)
41307 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
41308 DATA (AM( 6,K,-4),K=0, 2)
41309 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
41310 DATA (AM( 7,K,-4),K=0, 2)
41311 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
41313 DATA MEXVEC(-5) / 6 /
41314 DATA MLFVEC(-5) / 2 /
41315 DATA UT1VEC(-5) / 0.5562568E+01 /
41316 DATA UT2VEC(-5) / -0.1801317E+01 /
41317 DATA ALFVEC(-5) / 0.4952010E-02 /
41318 DATA QMAVEC(-5) / 0.4500000E+01 /
41319 DATA (AM( 0,K,-5),K=0, 2)
41320 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
41321 DATA (AM( 1,K,-5),K=0, 2)
41322 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
41323 DATA (AM( 2,K,-5),K=0, 2)
41324 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
41325 DATA (AM( 3,K,-5),K=0, 2)
41326 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
41327 DATA (AM( 4,K,-5),K=0, 2)
41328 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
41329 DATA (AM( 5,K,-5),K=0, 2)
41330 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
41331 DATA (AM( 6,K,-5),K=0, 2)
41332 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
41334 IF(Q .LE. QMAVEC(IFL)) THEN
41339 IF(X .GE. 1.D0) THEN
41344 TMP = LOG(Q/ALFVEC(IFL))
41345 IF(TMP .LE. 0.D0) THEN
41357 DO 100 K = 0, MLFVEC(IFL)
41358 AF(I) = AF(I) + SBX*AM(I,K,IFL)
41364 U = LOG(X/0.00001D0)
41366 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
41367 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
41368 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
41369 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
41370 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
41372 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
41374 C...Include threshold factor.
41375 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
41380 C*********************************************************************
41383 C...Auxiliary function for parametrization of CTEQ5M1.
41384 C...Author: J. Pumplin 9/99.
41386 FUNCTION PYCT5M(IFL,X,Q)
41388 C...Double precision declaration.
41389 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41390 IMPLICIT INTEGER(I-N)
41392 PARAMETER (NEX=8, NLF=2)
41393 DIMENSION AM(0:NEX,0:NLF,-5:2)
41394 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41395 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41396 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41397 DIMENSION AF(0:NEX)
41399 DATA MEXVEC( 2) / 8 /
41400 DATA MLFVEC( 2) / 2 /
41401 DATA UT1VEC( 2) / 0.5141718E+01 /
41402 DATA UT2VEC( 2) / -0.1346944E+01 /
41403 DATA ALFVEC( 2) / 0.5260555E+00 /
41404 DATA QMAVEC( 2) / 0.0000000E+00 /
41405 DATA (AM( 0,K, 2),K=0, 2)
41406 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
41407 DATA (AM( 1,K, 2),K=0, 2)
41408 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
41409 DATA (AM( 2,K, 2),K=0, 2)
41410 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
41411 DATA (AM( 3,K, 2),K=0, 2)
41412 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
41413 DATA (AM( 4,K, 2),K=0, 2)
41414 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
41415 DATA (AM( 5,K, 2),K=0, 2)
41416 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
41417 DATA (AM( 6,K, 2),K=0, 2)
41418 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
41419 DATA (AM( 7,K, 2),K=0, 2)
41420 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
41421 DATA (AM( 8,K, 2),K=0, 2)
41422 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
41424 DATA MEXVEC( 1) / 8 /
41425 DATA MLFVEC( 1) / 2 /
41426 DATA UT1VEC( 1) / 0.4138426E+01 /
41427 DATA UT2VEC( 1) / -0.3221374E+01 /
41428 DATA ALFVEC( 1) / 0.4960962E+00 /
41429 DATA QMAVEC( 1) / 0.0000000E+00 /
41430 DATA (AM( 0,K, 1),K=0, 2)
41431 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
41432 DATA (AM( 1,K, 1),K=0, 2)
41433 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
41434 DATA (AM( 2,K, 1),K=0, 2)
41435 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
41436 DATA (AM( 3,K, 1),K=0, 2)
41437 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
41438 DATA (AM( 4,K, 1),K=0, 2)
41439 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
41440 DATA (AM( 5,K, 1),K=0, 2)
41441 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
41442 DATA (AM( 6,K, 1),K=0, 2)
41443 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
41444 DATA (AM( 7,K, 1),K=0, 2)
41445 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
41446 DATA (AM( 8,K, 1),K=0, 2)
41447 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
41449 DATA MEXVEC( 0) / 8 /
41450 DATA MLFVEC( 0) / 2 /
41451 DATA UT1VEC( 0) / -0.1026789E+01 /
41452 DATA UT2VEC( 0) / -0.9051707E+01 /
41453 DATA ALFVEC( 0) / 0.9462977E+00 /
41454 DATA QMAVEC( 0) / 0.0000000E+00 /
41455 DATA (AM( 0,K, 0),K=0, 2)
41456 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
41457 DATA (AM( 1,K, 0),K=0, 2)
41458 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
41459 DATA (AM( 2,K, 0),K=0, 2)
41460 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
41461 DATA (AM( 3,K, 0),K=0, 2)
41462 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
41463 DATA (AM( 4,K, 0),K=0, 2)
41464 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
41465 DATA (AM( 5,K, 0),K=0, 2)
41466 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
41467 DATA (AM( 6,K, 0),K=0, 2)
41468 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
41469 DATA (AM( 7,K, 0),K=0, 2)
41470 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
41471 DATA (AM( 8,K, 0),K=0, 2)
41472 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
41474 DATA MEXVEC(-1) / 8 /
41475 DATA MLFVEC(-1) / 2 /
41476 DATA UT1VEC(-1) / 0.5243571E+01 /
41477 DATA UT2VEC(-1) / -0.2870513E+01 /
41478 DATA ALFVEC(-1) / 0.6701448E+00 /
41479 DATA QMAVEC(-1) / 0.0000000E+00 /
41480 DATA (AM( 0,K,-1),K=0, 2)
41481 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
41482 DATA (AM( 1,K,-1),K=0, 2)
41483 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
41484 DATA (AM( 2,K,-1),K=0, 2)
41485 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
41486 DATA (AM( 3,K,-1),K=0, 2)
41487 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
41488 DATA (AM( 4,K,-1),K=0, 2)
41489 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
41490 DATA (AM( 5,K,-1),K=0, 2)
41491 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
41492 DATA (AM( 6,K,-1),K=0, 2)
41493 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
41494 DATA (AM( 7,K,-1),K=0, 2)
41495 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
41496 DATA (AM( 8,K,-1),K=0, 2)
41497 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
41499 DATA MEXVEC(-2) / 7 /
41500 DATA MLFVEC(-2) / 2 /
41501 DATA UT1VEC(-2) / 0.4782210E+01 /
41502 DATA UT2VEC(-2) / -0.1976856E+02 /
41503 DATA ALFVEC(-2) / 0.7558374E+00 /
41504 DATA QMAVEC(-2) / 0.0000000E+00 /
41505 DATA (AM( 0,K,-2),K=0, 2)
41506 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
41507 DATA (AM( 1,K,-2),K=0, 2)
41508 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
41509 DATA (AM( 2,K,-2),K=0, 2)
41510 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
41511 DATA (AM( 3,K,-2),K=0, 2)
41512 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
41513 DATA (AM( 4,K,-2),K=0, 2)
41514 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
41515 DATA (AM( 5,K,-2),K=0, 2)
41516 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
41517 DATA (AM( 6,K,-2),K=0, 2)
41518 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
41519 DATA (AM( 7,K,-2),K=0, 2)
41520 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
41522 DATA MEXVEC(-3) / 7 /
41523 DATA MLFVEC(-3) / 2 /
41524 DATA UT1VEC(-3) / 0.4518239E+01 /
41525 DATA UT2VEC(-3) / -0.2690590E+01 /
41526 DATA ALFVEC(-3) / 0.6124079E+00 /
41527 DATA QMAVEC(-3) / 0.0000000E+00 /
41528 DATA (AM( 0,K,-3),K=0, 2)
41529 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
41530 DATA (AM( 1,K,-3),K=0, 2)
41531 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
41532 DATA (AM( 2,K,-3),K=0, 2)
41533 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
41534 DATA (AM( 3,K,-3),K=0, 2)
41535 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
41536 DATA (AM( 4,K,-3),K=0, 2)
41537 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
41538 DATA (AM( 5,K,-3),K=0, 2)
41539 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
41540 DATA (AM( 6,K,-3),K=0, 2)
41541 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
41542 DATA (AM( 7,K,-3),K=0, 2)
41543 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
41545 DATA MEXVEC(-4) / 7 /
41546 DATA MLFVEC(-4) / 2 /
41547 DATA UT1VEC(-4) / 0.2783230E+01 /
41548 DATA UT2VEC(-4) / -0.1746328E+01 /
41549 DATA ALFVEC(-4) / 0.1115653E+01 /
41550 DATA QMAVEC(-4) / 0.1300000E+01 /
41551 DATA (AM( 0,K,-4),K=0, 2)
41552 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
41553 DATA (AM( 1,K,-4),K=0, 2)
41554 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
41555 DATA (AM( 2,K,-4),K=0, 2)
41556 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
41557 DATA (AM( 3,K,-4),K=0, 2)
41558 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
41559 DATA (AM( 4,K,-4),K=0, 2)
41560 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
41561 DATA (AM( 5,K,-4),K=0, 2)
41562 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
41563 DATA (AM( 6,K,-4),K=0, 2)
41564 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
41565 DATA (AM( 7,K,-4),K=0, 2)
41566 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
41568 DATA MEXVEC(-5) / 6 /
41569 DATA MLFVEC(-5) / 2 /
41570 DATA UT1VEC(-5) / 0.1619654E+02 /
41571 DATA UT2VEC(-5) / -0.3367346E+01 /
41572 DATA ALFVEC(-5) / 0.5109891E-02 /
41573 DATA QMAVEC(-5) / 0.4500000E+01 /
41574 DATA (AM( 0,K,-5),K=0, 2)
41575 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
41576 DATA (AM( 1,K,-5),K=0, 2)
41577 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
41578 DATA (AM( 2,K,-5),K=0, 2)
41579 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
41580 DATA (AM( 3,K,-5),K=0, 2)
41581 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
41582 DATA (AM( 4,K,-5),K=0, 2)
41583 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
41584 DATA (AM( 5,K,-5),K=0, 2)
41585 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
41586 DATA (AM( 6,K,-5),K=0, 2)
41587 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
41589 IF(Q .LE. QMAVEC(IFL)) THEN
41594 IF(X .GE. 1.D0) THEN
41599 TMP = LOG(Q/ALFVEC(IFL))
41600 IF(TMP .LE. 0.D0) THEN
41612 DO 100 K = 0, MLFVEC(IFL)
41613 AF(I) = AF(I) + SBX*AM(I,K,IFL)
41619 U = LOG(X/0.00001D0)
41621 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
41622 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
41623 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
41624 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
41625 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
41627 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
41629 C...Include threshold factor.
41630 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
41635 C*********************************************************************
41638 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
41639 C...a few older parametrizations, now obsolete but convenient for
41640 C...backwards checks.
41642 SUBROUTINE PYPDPO(X,Q2,XPPR)
41644 C...Double precision and integer declarations.
41645 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41646 IMPLICIT INTEGER(I-N)
41647 INTEGER PYK,PYCHGE,PYCOMP
41649 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41650 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41651 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41652 COMMON/PYINT1/MINT(400),VINT(400)
41653 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
41654 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
41655 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
41658 C...The following data lines are coefficients needed in the
41659 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
41660 C...parametrizations, see below.
41661 C...Powers of 1-x in different cases.
41662 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
41663 C...Expansion coefficients for up valence quark distribution.
41664 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
41665 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
41666 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
41667 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
41668 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
41669 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
41670 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
41671 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
41672 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
41673 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
41674 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
41675 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
41676 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
41677 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
41678 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
41679 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
41680 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
41681 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
41682 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
41683 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
41684 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
41685 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
41686 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
41687 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
41688 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
41689 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
41690 C...Expansion coefficients for down valence quark distribution.
41691 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
41692 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
41693 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
41694 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
41695 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
41696 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
41697 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
41698 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
41699 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
41700 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
41701 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
41702 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
41703 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
41704 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
41705 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
41706 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
41707 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
41708 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
41709 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
41710 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
41711 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
41712 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
41713 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
41714 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
41715 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
41716 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
41717 C...Expansion coefficients for up and down sea quark distributions.
41718 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
41719 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
41720 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
41721 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
41722 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
41723 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
41724 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
41725 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
41726 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
41727 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
41728 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
41729 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
41730 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
41731 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
41732 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
41733 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
41734 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
41735 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
41736 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
41737 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
41738 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
41739 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
41740 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
41741 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
41742 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
41743 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
41744 C...Expansion coefficients for gluon distribution.
41745 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
41746 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
41747 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
41748 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
41749 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
41750 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
41751 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
41752 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
41753 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
41754 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
41755 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
41756 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
41757 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
41758 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
41759 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
41760 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
41761 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
41762 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
41763 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
41764 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
41765 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
41766 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
41767 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
41768 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
41769 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
41770 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
41771 C...Expansion coefficients for strange sea quark distribution.
41772 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
41773 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
41774 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
41775 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
41776 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
41777 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
41778 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
41779 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
41780 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
41781 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
41782 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
41783 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
41784 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
41785 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
41786 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
41787 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
41788 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
41789 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
41790 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
41791 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
41792 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
41793 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
41794 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
41795 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
41796 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
41797 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
41798 C...Expansion coefficients for charm sea quark distribution.
41799 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
41800 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
41801 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
41802 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
41803 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
41804 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
41805 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
41806 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
41807 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
41808 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
41809 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
41810 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
41811 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
41812 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
41813 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
41814 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
41815 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
41816 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
41817 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
41818 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
41819 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
41820 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
41821 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
41822 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
41823 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
41824 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
41825 C...Expansion coefficients for bottom sea quark distribution.
41826 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
41827 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
41828 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
41829 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
41830 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
41831 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
41832 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
41833 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
41834 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
41835 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
41836 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
41837 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
41838 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
41839 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
41840 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
41841 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
41842 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
41843 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
41844 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
41845 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
41846 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
41847 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
41848 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
41849 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
41850 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
41851 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
41852 C...Expansion coefficients for top sea quark distribution.
41853 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
41854 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
41855 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
41856 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
41857 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
41858 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
41859 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
41860 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
41861 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
41862 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
41863 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
41864 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
41865 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
41866 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
41867 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
41868 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
41869 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
41870 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
41871 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
41872 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
41873 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
41874 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
41875 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
41876 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
41877 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
41878 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
41880 C...The following data lines are coefficients needed in the
41881 C...Duke, Owens proton structure function parametrizations, see below.
41882 C...Expansion coefficients for (up+down) valence quark distribution.
41883 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
41884 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41885 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41886 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
41887 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
41888 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41889 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41890 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
41891 C...Expansion coefficients for down valence quark distribution.
41892 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
41893 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41894 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
41895 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
41896 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
41897 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41898 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
41899 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
41900 C...Expansion coefficients for (up+down+strange) sea quark distribution.
41901 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
41902 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41903 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
41904 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
41905 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
41906 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41907 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
41908 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
41909 C...Expansion coefficients for charm sea quark distribution.
41910 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
41911 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41912 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
41913 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
41914 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
41915 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41916 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
41917 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
41918 C...Expansion coefficients for gluon distribution.
41919 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
41920 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41921 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
41922 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
41923 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
41924 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41925 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
41926 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
41928 C...Euler's beta function, requires ordinary Gamma function
41929 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
41931 C...Leading order proton parton distributions from Glueck, Reya and
41932 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
41934 IF(MSTP(51).EQ.11) THEN
41936 C...Determine s expansion variable and some x expressions.
41937 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
41938 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
41943 C...Evaluate valence, gluon and sea distributions.
41944 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
41945 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
41946 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
41947 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
41948 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
41949 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
41950 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
41951 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
41952 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
41953 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
41954 & SQRT(4.066D0*SD**1.218D0*XL)))*
41955 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
41956 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
41957 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
41958 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
41959 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
41960 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
41961 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
41962 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
41963 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
41964 IF(SD.LE.0.888D0) THEN
41967 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
41968 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
41969 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
41971 IF(SD.LE.1.351D0) THEN
41974 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
41975 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
41976 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
41979 C...Put into output array.
41981 XPPR(1)=XFVDD+XFSEA
41982 XPPR(2)=XFVUD-XFVDD+XFSEA
41992 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
41993 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
41994 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
41996 C...Determine set, Lambda and x and t expansion variables.
41998 IF(NSET.EQ.1) ALAM=0.2D0
41999 IF(NSET.EQ.2) ALAM=0.29D0
42000 TMIN=LOG(5D0/ALAM**2)
42001 TMAX=LOG(1D8/ALAM**2)
42002 T=LOG(MAX(1D0,Q2/ALAM**2))
42003 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42005 IF(X.LE.0.1D0) NX=2
42006 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
42007 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
42009 C...Chebyshev polynomials for x and t expansion.
42012 TX(3)=2D0*VX**2-1D0
42013 TX(4)=4D0*VX**3-3D0*VX
42014 TX(5)=8D0*VX**4-8D0*VX**2+1D0
42015 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
42018 TT(3)=2D0*VT**2-1D0
42019 TT(4)=4D0*VT**3-3D0*VT
42020 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42021 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42023 C...Calculate structure functions.
42028 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
42031 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
42034 C...Put into output array.
42036 XPPR(1)=XQ(2)+XQ(3)
42037 XPPR(2)=XQ(1)+XQ(3)
42045 C...Special expansion for bottom (threshold effects).
42046 IF(MSTP(58).GE.5) THEN
42047 IF(NSET.EQ.1) TMIN=8.1905D0
42048 IF(NSET.EQ.2) TMIN=7.4474D0
42050 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42053 TT(3)=2D0*VT**2-1D0
42054 TT(4)=4D0*VT**3-3D0*VT
42055 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42056 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42060 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
42063 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
42068 C...Special expansion for top (threshold effects).
42069 IF(MSTP(58).GE.6) THEN
42070 IF(NSET.EQ.1) TMIN=11.5528D0
42071 IF(NSET.EQ.2) TMIN=10.8097D0
42072 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
42073 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
42075 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42078 TT(3)=2D0*VT**2-1D0
42079 TT(4)=4D0*VT**3-3D0*VT
42080 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42081 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42085 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
42088 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
42093 C...Proton parton distributions from Duke, Owens.
42094 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
42095 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
42097 C...Determine set, Lambda and s expansion parameter.
42099 IF(NSET.EQ.1) ALAM=0.2D0
42100 IF(NSET.EQ.2) ALAM=0.4D0
42101 Q2IN=MIN(1D6,MAX(4D0,Q2))
42102 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
42104 C...Calculate structure functions.
42107 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
42108 & CDO(3,IS,KFL,NSET)*SD**2
42111 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
42112 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
42114 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
42115 & TS(5)*X**2+TS(6)*X**3)
42119 C...Put into output arrays.
42121 XPPR(1)=XQ(2)+XQ(3)/6D0
42122 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
42135 C*********************************************************************
42138 C...Gives threshold attractive/repulsive factor for heavy flavour
42141 FUNCTION PYHFTH(SH,SQM,FRATT)
42143 C...Double precision and integer declarations.
42144 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42145 IMPLICIT INTEGER(I-N)
42146 INTEGER PYK,PYCHGE,PYCOMP
42148 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42149 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42150 COMMON/PYINT1/MINT(400),VINT(400)
42151 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
42153 C...Value for alpha_strong.
42154 IF(MSTP(35).LE.1) THEN
42159 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
42165 C...Evaluate attractive and repulsive factors.
42166 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42167 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
42168 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42169 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
42170 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
42176 C*********************************************************************
42179 C...Splits a hadron remnant into two (partons or hadron + parton)
42180 C...in case it is more complicated than just a quark or a diquark.
42182 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
42184 C...Double precision and integer declarations.
42185 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42186 IMPLICIT INTEGER(I-N)
42187 INTEGER PYK,PYCHGE,PYCOMP
42188 C...Commonblocks. PYDAT1 temporary
42189 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42190 COMMON/PYINT1/MINT(400),VINT(400)
42191 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42192 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
42196 C...Preliminaries. Parton composition.
42199 KFL(1)=MOD(KFA/1000,10)
42200 KFL(2)=MOD(KFA/100,10)
42201 KFL(3)=MOD(KFA/10,10)
42202 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
42203 KFL(2)=INT(1.5D0+PYR(0))
42204 IF(MINT(105).EQ.333) KFL(2)=3
42205 IF(MINT(105).EQ.443) KFL(2)=4
42207 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
42210 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
42213 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
42214 KFL(2)=MOD(KFA/10,10)
42215 KFL(3)=MOD(KFA/100,10)
42217 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
42224 C...Subdivide lepton.
42225 IF(KFA.GE.11.AND.KFA.LE.18) THEN
42226 IF(KFLR.EQ.KFA) THEN
42228 ELSEIF(KFLR.EQ.22) THEN
42230 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
42232 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
42234 ELSEIF(KFLR.EQ.21) THEN
42242 C...Subdivide photon.
42243 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
42244 IF(KFLR.NE.21) THEN
42249 IF(RAGR.GT.0.125D0) KFLSP=2
42250 IF(RAGR.GT.0.625D0) KFLSP=3
42251 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
42255 C...Subdivide Reggeon or Pomeron.
42256 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
42257 IF(KFLIN.EQ.21) THEN
42263 C...Subdivide meson.
42264 ELSEIF(KFL(1).EQ.0) THEN
42265 KFL(2)=KFL(2)*(-1)**KFL(2)
42266 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
42267 IF(KFLR.EQ.KFL(2)) THEN
42269 ELSEIF(KFLR.EQ.KFL(3)) THEN
42271 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
42274 ELSEIF(KFLR.EQ.21) THEN
42277 ELSEIF(KFLR*KFL(2).GT.0) THEN
42280 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
42281 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42283 ELSEIF(KFLCH.EQ.0) THEN
42284 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42292 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
42293 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42295 ELSEIF(KFLCH.EQ.0) THEN
42296 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42303 C...Special case for extracting photon from baryon without splitting
42304 C...the latter. (Currently only used by external programs.)
42305 ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
42309 C...Subdivide baryon.
42313 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
42316 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
42319 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
42320 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
42323 IAGR=1.00001D0+2.99998D0*PYR(0)
42326 IF(IAGR.EQ.1) ID1=2
42327 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
42330 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
42331 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
42332 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
42333 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
42334 ELSEIF(MOD(KFA,10).EQ.2) THEN
42335 IF(IAGR.EQ.1) KSP=1
42336 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
42338 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
42339 IF(KFLR.EQ.21) THEN
42341 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
42344 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
42345 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42347 ELSEIF(KFLCH.EQ.0) THEN
42348 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42352 ELSEIF(NAGR.EQ.0) THEN
42355 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
42356 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42358 ELSEIF(KFLCH.EQ.0) THEN
42359 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42367 C...Add on correct sign for result.
42374 C*********************************************************************
42377 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
42378 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
42379 C...(Dover, 1965) 6.1.36.
42383 C...Double precision and integer declarations.
42384 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42385 IMPLICIT INTEGER(I-N)
42386 INTEGER PYK,PYCHGE,PYCOMP
42387 C...Local array and data.
42389 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
42390 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
42399 PYGAMM=PYGAMM+B(I)*DXP
42405 PYGAMM=(X-IX)*PYGAMM
42412 C***********************************************************************
42415 C...Calculates real and imaginary parts of the auxiliary functions W1
42416 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
42417 C...der Bij, Nucl. Phys. B297 (1988) 221.
42419 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
42421 C...Double precision and integer declarations.
42422 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42423 IMPLICIT INTEGER(I-N)
42424 INTEGER PYK,PYCHGE,PYCOMP
42426 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42429 ASINH(X)=LOG(X+SQRT(X**2+1D0))
42430 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
42432 IF(EPS.LT.0D0) THEN
42433 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
42434 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
42436 ELSEIF(EPS.LT.1D0) THEN
42437 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
42438 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
42439 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
42440 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
42442 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
42443 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
42450 C***********************************************************************
42453 C...Calculates real and imaginary parts of the auxiliary function I3;
42454 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
42455 C...Nucl. Phys. B297 (1988) 221.
42457 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
42459 C...Double precision and integer declarations.
42460 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42461 IMPLICIT INTEGER(I-N)
42462 INTEGER PYK,PYCHGE,PYCOMP
42464 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42467 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
42468 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
42470 IF(EPS.LT.0D0) THEN
42471 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42472 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
42473 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
42474 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
42475 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
42476 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
42477 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
42478 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
42480 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
42481 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
42482 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
42483 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
42484 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
42485 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
42486 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
42487 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
42488 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42489 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
42490 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
42491 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
42492 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
42493 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
42494 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
42495 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
42497 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
42498 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
42499 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
42500 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
42501 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
42504 ELSEIF(EPS.LT.1D0) THEN
42505 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42506 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
42507 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
42508 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
42509 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
42510 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
42511 & (0.25D0*(RAT+1D0)*EPS))
42512 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
42513 & (0.25D0*(RAT+1D0)*EPS))
42514 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
42515 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
42516 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
42517 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
42518 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
42519 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
42520 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
42521 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
42522 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42523 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
42524 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
42525 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
42526 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
42527 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
42528 & (1D0+0.25D0*RAT*EPS-GA))
42529 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
42530 & (1D0+0.25D0*RAT*EPS-GA))
42532 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
42533 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
42534 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
42535 & LOG((GA+BE-1D0)/(BE-GA))
42536 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
42539 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
42540 RCTHE=RSQ*(1D0-2D0*BE/EPS)
42541 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
42542 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
42543 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
42545 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
42546 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
42547 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
42548 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
42549 & (PHI-THE)*(PHI+THE-PARU(1))
42550 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
42551 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
42554 Y3RE=2D0/(2D0*BE-1D0)*F3RE
42555 Y3IM=2D0/(2D0*BE-1D0)*F3IM
42560 C***********************************************************************
42563 C...Calculates real and imaginary part of Spence function; see
42564 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
42566 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
42568 C...Double precision and integer declarations.
42569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42570 IMPLICIT INTEGER(I-N)
42571 INTEGER PYK,PYCHGE,PYCOMP
42573 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42575 C...Local array and data.
42578 &1.000000D+00, -5.000000D-01, 1.666667D-01,
42579 &0.000000D+00, -3.333333D-02, 0.000000D+00,
42580 &2.380952D-02, 0.000000D+00, -3.333333D-02,
42581 &0.000000D+00, 7.575757D-02, 0.000000D+00,
42582 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
42586 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
42587 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
42588 IF(IREIM.EQ.2) PYSPEN=0D0
42592 XMOD=SQRT(XRE**2+XIM**2)
42593 IF(XMOD.LT.1D-6) THEN
42594 IF(IREIM.EQ.1) PYSPEN=0D0
42595 IF(IREIM.EQ.2) PYSPEN=0D0
42599 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42603 IF(XMOD.GT.1D0) THEN
42605 ALGXIM=XARG-SIGN(PARU(1),XARG)
42606 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
42607 SP0IM=-ALGXRE*ALGXIM
42614 IF(XRE.GT.0.5D0) THEN
42619 XMOD=SQRT(XRE**2+XIM**2)
42620 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42623 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
42624 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
42630 XMOD=SQRT(XRE**2+XIM**2)
42631 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42640 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
42641 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
42642 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
42645 SPRE=SPRE+B(I)*TERMRE
42646 SPIM=SPIM+B(I)*TERMIM
42649 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
42650 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
42655 C***********************************************************************
42658 C...Calculates the matrix element for the processes
42659 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
42660 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
42661 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
42663 SUBROUTINE PYQQBH(WTQQBH)
42665 C...Double precision and integer declarations.
42666 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42667 IMPLICIT INTEGER(I-N)
42668 INTEGER PYK,PYCHGE,PYCOMP
42670 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42671 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42672 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42673 COMMON/PYINT1/MINT(400),VINT(400)
42674 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42675 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
42676 C...Local arrays and function.
42677 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
42678 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
42681 C...Mass parameters.
42684 SHPR=SQRT(VINT(26))*VINT(1)
42685 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
42686 PH=SQRT(VINT(21))*VINT(1)
42690 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
42692 PT=SQRT(MAX(0D0,VINT(197+5*I)))
42693 PP(I,1)=PT*COS(VINT(198+5*I))
42694 PP(I,2)=PT*SIN(VINT(198+5*I))
42696 PP(3,1)=-PP(1,1)-PP(2,1)
42697 PP(3,2)=-PP(1,2)-PP(2,2)
42698 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
42699 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
42700 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
42702 PP(3,3)=PMT3*SINH(VINT(211))
42703 PP(3,4)=PMT3*COSH(VINT(211))
42704 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
42705 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
42706 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
42707 PP(2,3)=-PP(1,3)-PP(3,3)
42708 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
42709 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
42711 C...Set up incoming kinematics and derived momentum combinations.
42715 PP(I,3)=-0.5D0*SHPR*(-1)**I
42716 PP(I,4)=-0.5D0*SHPR
42719 PP(6,J)=PP(1,J)+PP(2,J)
42720 PP(7,J)=PP(1,J)+PP(3,J)
42721 PP(8,J)=PP(1,J)+PP(4,J)
42722 PP(9,J)=PP(1,J)+PP(5,J)
42723 PP(10,J)=-PP(2,J)-PP(3,J)
42724 PP(11,J)=-PP(2,J)-PP(4,J)
42725 PP(12,J)=-PP(2,J)-PP(5,J)
42726 PP(13,J)=-PP(4,J)-PP(5,J)
42729 C...Derived kinematics invariants.
42758 C...Define colour coefficients for g + g -> Q + Qbar + H.
42759 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
42763 CLR(I+3,J+3)=16D0/3D0
42764 CLR(I,J+3)=-2D0/3D0
42765 CLR(I+3,J)=-2D0/3D0
42778 CLR(6+K1,6+K2)=12D0
42782 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
42783 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
42784 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
42785 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
42786 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
42787 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
42788 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
42790 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
42791 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
42792 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42793 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
42794 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
42795 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
42796 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
42797 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
42798 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
42799 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
42800 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
42801 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
42802 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
42803 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
42804 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
42805 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
42806 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
42807 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
42809 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
42810 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
42811 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
42812 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
42813 & +X4*X9*X5+X4*X5**2)
42814 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
42815 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
42816 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
42817 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
42818 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
42819 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
42820 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
42821 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
42822 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
42823 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
42824 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
42825 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
42826 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
42827 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
42828 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
42829 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
42830 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
42831 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
42832 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
42833 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
42835 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
42836 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
42837 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
42838 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
42839 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
42840 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
42841 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
42843 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
42844 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
42845 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
42846 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
42847 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
42848 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
42850 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
42851 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
42852 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
42853 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
42854 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
42855 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
42856 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
42858 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
42859 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
42860 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
42861 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
42862 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
42863 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
42864 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
42865 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
42866 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
42867 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
42868 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
42869 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
42870 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
42871 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
42872 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
42873 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
42874 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
42875 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
42876 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
42877 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
42878 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
42879 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
42880 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
42881 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
42882 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
42883 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
42884 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
42885 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
42886 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
42887 & +X3*X8*X5+X3*X5**2)
42888 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
42889 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
42890 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
42891 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
42892 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
42893 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
42894 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
42896 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
42897 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
42898 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
42899 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
42900 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
42901 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
42902 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
42903 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
42904 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
42905 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
42906 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
42907 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
42908 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
42909 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
42910 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
42911 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
42912 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
42913 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
42914 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
42915 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
42916 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
42917 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
42918 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
42919 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
42920 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
42921 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
42923 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
42924 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
42925 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42926 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
42927 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
42928 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
42929 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
42930 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
42931 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
42932 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
42933 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
42934 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
42935 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
42936 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
42937 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
42938 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
42939 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
42940 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
42941 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
42942 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
42943 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
42944 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
42945 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
42946 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
42947 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
42948 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
42950 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42951 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42952 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
42953 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
42954 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
42955 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
42956 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
42957 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
42958 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
42959 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
42960 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
42961 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42962 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42963 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
42964 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
42965 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
42966 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
42967 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
42968 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
42969 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
42970 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
42971 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
42972 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
42973 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
42974 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
42975 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
42976 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
42977 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
42978 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
42979 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
42980 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
42981 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
42982 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
42983 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
42984 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
42985 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
42986 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
42987 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
42988 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
42989 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
42990 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
42991 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
42992 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
42993 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
42995 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
42996 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
42997 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
42998 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
42999 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
43000 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
43001 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
43002 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
43003 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
43004 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
43005 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
43007 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43008 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
43009 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
43010 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43011 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
43012 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
43014 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43015 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
43016 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
43018 FM(9,10)=0.5D0*(FMXX+FM(9,10))
43019 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43020 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
43021 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
43023 C...Repackage matrix elements.
43029 RM(7,7)=FM(7,7)-2D0*FM(9,9)
43030 RM(7,8)=FM(7,8)-2D0*FM(9,10)
43031 RM(8,8)=FM(8,8)-2D0*FM(10,10)
43033 C...Produce final result: matrix elements * colours * propagators.
43038 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
43041 WTQQBH=-WTQQBH/256D0
43044 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
43045 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
43046 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
43048 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
43049 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
43050 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
43052 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
43053 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
43056 C...Produce final result: matrix elements * propagators.
43058 A12=A12/(DX(7)*DX(8))
43060 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
43066 C*********************************************************************
43068 C...PYSTBH (and auxiliaries)
43069 C.. Evaluates the matrix elements for t + b + H production.
43071 SUBROUTINE PYSTBH(WTTBH)
43073 C...DOUBLE PRECISION AND INTEGER DECLARATIONS
43074 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43075 IMPLICIT INTEGER(I-N)
43076 INTEGER PYK,PYCHGE,PYCOMP
43079 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43080 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43081 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43082 COMMON/PYINT1/MINT(400),VINT(400)
43083 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43084 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
43085 COMMON/PYINT4/MWID(500),WIDS(500,5)
43086 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
43087 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43088 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
43089 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
43090 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
43091 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
43092 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43093 DOUBLE PRECISION MW2
43094 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
43095 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
43097 C...LOCAL ARRAYS AND COMPLEX VARIABLES
43098 DIMENSION QQ(4,2),PP(4,3)
43103 C...KINEMATIC PARAMETERS.
43104 SHPR=SQRT(VINT(26))*VINT(1)
43105 PH=SQRT(VINT(21))*VINT(1)
43108 C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
43110 PT=SQRT(MAX(0D0,VINT(197+5*I)))
43111 PP(1,I)=PT*COS(VINT(198+5*I))
43112 PP(2,I)=PT*SIN(VINT(198+5*I))
43114 PP(1,3)=-PP(1,1)-PP(1,2)
43115 PP(2,3)=-PP(2,1)-PP(2,2)
43116 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
43117 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
43118 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
43120 PP(3,3)=PMT3*SINH(VINT(211))
43121 PP(4,3)=PMT3*COSH(VINT(211))
43122 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
43123 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
43124 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
43125 PP(3,2)=-PP(3,1)-PP(3,3)
43126 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
43127 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
43129 C...CM SYSTEM, INGOING QUARKS/GLUONS
43130 QQ(3,1) = SHPR/2.D0
43135 C...PARAMETERS FOR AMPLITUDE METHOD
43139 MW2 = PMAS(24,1)**2
43142 RMB=PYMRUN(5,VINT(52))
43146 IF (ISUB.EQ.401) THEN
43147 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43148 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43149 ELSE IF (ISUB.EQ.402) THEN
43150 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43151 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43156 C------------------------------------------------------------------
43157 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
43158 C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
43159 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43160 IMPLICIT INTEGER(I-N)
43161 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
43162 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43165 C TOP WIDTH CALCULATION
43172 IF (MT .LT. (MHP+MB)) THEN
43174 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43175 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43176 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43179 C T ->BW +T ->B H^+
43180 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43181 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43182 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43184 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
43185 & -4.D0*(MHP*MB/MT**2)**2 )
43186 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
43187 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
43188 GAMT = GAMTBW+GAMTBH
43195 C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
43196 C GG->TBH^+, QQBAR->TBH^+
43197 C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
43198 C (FOR INSTANCE WITH PYTHIA)
43199 C------------------------------------------------------------
43200 C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
43201 C PHYS REV. D 60 (1999) 115011
43202 C (THESE FILES PREPARED BY J.-L. KNEUR)
43203 C------------------------------------------------------------
43205 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43207 C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
43209 C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
43210 C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
43211 C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
43212 C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
43213 C "PHYSICAL PARAMETERS" INPUT:
43214 C MT,MB TOP AND BOTTOM MASSES;
43215 C MHP CHARGED HIGGS MASS
43216 C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
43218 C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
43219 C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
43220 C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
43221 C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
43222 C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
43223 C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
43224 C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
43226 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43227 IMPLICIT INTEGER(I-N)
43228 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43229 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43230 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43231 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43232 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43234 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43235 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
43236 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43237 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43238 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43239 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
43240 C (TAN BETA) VALUES
43242 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43243 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43248 C COLLECTING THE RELEVANT OVERALL FACTORS:
43249 C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
43250 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
43251 C COUPLING CONSTANT (OVERALL NORMALIZATION)
43252 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
43253 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
43254 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
43255 C ALPHAS IS ALPHA_STRONG;
43256 C SW2 IS SIN(THETA_W)**2.
43259 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
43261 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
43262 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
43263 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
43265 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
43266 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
43268 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
43270 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
43271 S = 2*PYTBHS(Q1,Q2)
43278 C TOP WIDTH CALCULATION
43279 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
43280 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
43281 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
43282 A1INV= S -2*P1Q1 -2*P1Q2
43283 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
43284 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
43285 C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
43287 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
43288 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
43289 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
43290 C NOW COMES THE AMP**2:
43291 C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
43292 C THE EXPRESSIONS BELOW
43295 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
43296 &512*A1*A2*MB*MT/3-
43297 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
43298 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
43299 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
43300 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
43301 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
43302 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
43303 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
43304 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
43305 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
43306 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
43307 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
43308 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
43309 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43310 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43311 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
43312 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
43313 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
43314 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
43315 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43316 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
43317 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
43318 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43319 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43320 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43321 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
43322 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43323 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43324 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43325 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43326 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43327 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
43328 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43329 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43330 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
43331 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
43332 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43333 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
43334 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43335 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43336 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
43337 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
43338 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43339 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
43340 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43341 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43342 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43343 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43344 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
43345 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
43346 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43347 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
43348 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43349 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
43350 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
43351 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43352 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43353 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
43354 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
43355 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
43356 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43357 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43358 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43359 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43360 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43361 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
43362 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43363 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43364 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43365 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
43366 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43367 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
43368 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43369 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43370 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
43371 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43372 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43373 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43374 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
43375 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43376 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43377 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43378 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43379 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43380 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43381 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
43382 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43383 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43384 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
43385 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43386 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43387 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43388 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43389 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43390 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43391 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
43392 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43393 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43394 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43395 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
43396 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43397 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43398 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43399 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43400 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
43401 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
43402 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
43403 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
43404 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
43405 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
43406 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
43407 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
43408 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
43409 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
43410 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
43411 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
43412 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
43413 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
43414 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
43415 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
43416 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
43417 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
43418 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
43419 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
43420 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
43421 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
43422 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
43423 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
43424 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
43425 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
43426 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
43427 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
43428 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
43429 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
43430 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
43431 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
43432 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
43433 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
43434 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
43435 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
43436 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
43437 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
43438 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
43439 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
43440 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
43441 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
43442 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
43443 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
43444 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43445 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
43446 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43447 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
43448 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
43449 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43450 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43451 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43452 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
43453 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
43454 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
43455 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43456 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43457 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
43458 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
43459 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
43460 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
43461 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43462 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43463 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
43464 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
43465 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
43466 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
43467 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
43468 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
43469 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
43470 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
43471 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43472 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
43473 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43474 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43475 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43476 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
43477 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
43478 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43479 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43480 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
43481 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43482 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43483 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
43484 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
43485 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
43486 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
43487 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
43488 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
43489 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
43490 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
43491 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
43492 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
43493 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
43494 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
43495 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
43496 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
43497 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
43498 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
43499 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43500 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43501 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
43502 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
43503 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
43504 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
43505 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
43506 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43507 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43508 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
43509 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43510 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43511 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
43512 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
43513 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
43514 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
43515 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
43516 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
43517 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
43518 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
43519 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
43520 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
43521 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
43522 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
43523 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
43524 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
43525 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
43526 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
43527 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
43528 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
43529 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
43530 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
43531 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
43532 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
43533 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
43534 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
43535 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
43536 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
43537 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
43538 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
43539 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
43540 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43541 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43542 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43543 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
43544 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
43545 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
43546 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
43547 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
43548 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
43549 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
43550 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
43551 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
43552 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
43553 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
43554 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43555 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43556 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
43557 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43558 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43559 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
43560 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
43561 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
43562 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
43563 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
43564 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
43565 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
43566 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
43567 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
43568 &384*A12*MB*MT*P1Q1**2/S**2+
43569 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
43570 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
43571 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
43572 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
43573 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
43574 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
43575 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
43576 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
43577 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
43578 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
43579 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
43580 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
43581 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
43582 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
43583 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
43584 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
43585 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
43586 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
43587 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
43588 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
43589 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
43590 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
43591 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
43592 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
43593 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
43594 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
43595 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
43596 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
43597 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
43598 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
43599 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
43600 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
43601 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
43602 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
43603 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
43604 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
43605 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
43606 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
43607 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
43608 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
43609 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
43610 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
43611 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
43612 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
43613 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
43614 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
43615 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
43616 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
43617 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
43618 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
43619 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
43620 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
43621 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
43622 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
43623 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43624 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43625 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
43626 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43627 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43628 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
43629 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
43630 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
43631 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
43632 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
43633 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
43634 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
43635 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
43636 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
43637 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
43638 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
43639 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
43640 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
43641 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
43642 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
43643 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
43644 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
43645 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43646 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43647 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
43648 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
43649 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
43650 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
43651 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
43652 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
43653 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
43654 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
43655 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
43656 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
43657 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
43658 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
43659 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
43660 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
43661 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
43662 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
43663 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
43664 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
43665 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
43666 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
43667 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43668 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43669 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
43670 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
43671 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
43672 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
43673 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
43674 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
43675 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
43676 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
43677 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
43678 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
43679 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43680 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43681 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
43682 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43683 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43684 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
43685 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
43686 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
43687 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
43688 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
43689 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
43690 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43691 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43692 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43693 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43694 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43695 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43696 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
43697 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
43698 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
43699 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
43700 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
43701 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
43702 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43703 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43704 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
43705 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
43706 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
43707 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
43708 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
43709 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
43710 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
43711 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
43712 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
43713 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
43714 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
43715 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
43716 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
43717 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
43718 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
43719 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
43720 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
43721 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
43722 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
43723 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
43724 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
43725 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
43726 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
43727 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43728 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43729 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
43730 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
43731 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
43732 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
43733 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
43734 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
43735 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43736 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43737 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
43738 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
43739 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
43740 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43741 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43742 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
43743 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
43744 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
43747 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43748 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43749 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43750 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43751 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
43752 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43753 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43754 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
43755 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
43756 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
43757 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
43758 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
43759 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
43760 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
43761 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
43762 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
43763 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
43764 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
43765 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
43766 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43767 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43768 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
43769 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
43770 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
43771 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
43772 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
43773 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
43774 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
43775 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
43776 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
43777 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
43778 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
43779 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
43780 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
43781 &272*A1*A2*P1Q1*S/(3*P1Q2)+
43782 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
43783 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
43784 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
43785 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
43786 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
43787 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
43788 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
43789 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
43790 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
43791 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
43792 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
43793 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
43794 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
43795 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
43796 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
43797 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
43798 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
43799 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
43800 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
43801 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
43802 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
43803 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
43804 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
43805 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
43806 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
43807 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
43808 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
43809 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43810 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
43811 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
43812 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
43813 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
43814 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
43815 &32*A12*P2Q1*S/(3*P1Q1)-
43816 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
43817 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
43818 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
43819 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
43820 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
43821 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
43822 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
43823 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
43824 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
43825 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
43826 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
43827 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
43828 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
43829 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
43830 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
43831 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
43832 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
43833 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
43834 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
43835 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
43836 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
43837 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
43838 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
43839 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
43840 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
43841 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
43842 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
43843 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
43844 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43845 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43846 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43847 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
43848 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
43849 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
43850 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
43851 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
43852 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
43853 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
43854 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43855 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
43856 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43857 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43858 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43859 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43860 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43861 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43862 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43863 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43864 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
43865 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
43866 &272*A1*A2*P2Q1*S/(3*P2Q2)-
43867 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
43868 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
43869 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
43870 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
43871 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
43872 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
43873 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
43874 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
43875 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
43876 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
43877 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
43878 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
43879 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
43880 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
43881 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
43882 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
43883 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
43884 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
43885 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
43886 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
43887 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
43888 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
43889 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43892 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
43893 &512*A1*A2*MB*MT/3+
43894 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
43895 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
43896 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
43897 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
43898 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
43899 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
43900 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
43901 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
43902 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
43903 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
43904 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
43905 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
43906 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43907 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43908 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
43909 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
43910 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
43911 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
43912 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43913 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
43914 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
43915 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43916 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43917 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43918 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
43919 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43920 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43921 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43922 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43923 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43924 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
43925 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43926 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43927 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
43928 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
43929 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43930 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
43931 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43932 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43933 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
43934 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
43935 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43936 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
43937 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43938 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43939 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43940 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43941 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
43942 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
43943 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43944 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
43945 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43946 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43947 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43948 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43949 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43950 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
43951 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
43952 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
43953 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43954 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43955 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43956 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
43957 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43958 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
43959 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43960 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43961 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43962 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
43963 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43964 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
43965 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43966 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43967 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43968 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43969 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43970 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43971 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
43972 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43973 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43974 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
43975 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43976 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43977 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43978 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
43979 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43980 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43981 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
43982 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43983 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43984 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
43985 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43986 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43987 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43988 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
43989 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43990 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43991 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43992 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
43993 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43994 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43995 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43996 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43997 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
43998 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
43999 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
44000 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
44001 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
44002 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
44003 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
44004 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
44005 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
44006 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
44007 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
44008 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
44009 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
44010 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
44011 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
44012 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
44013 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
44014 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
44015 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
44016 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
44017 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
44018 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
44019 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
44020 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
44021 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
44022 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
44023 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
44024 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
44025 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
44026 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
44027 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
44028 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
44029 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
44030 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
44031 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
44032 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
44033 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
44034 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
44035 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
44036 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
44037 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
44038 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44039 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44040 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
44041 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44042 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44043 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44044 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
44045 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
44046 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44047 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
44048 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44049 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
44050 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
44051 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
44052 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44053 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
44054 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
44055 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
44056 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
44057 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
44058 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44059 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
44060 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
44061 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
44062 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
44063 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
44064 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
44065 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
44066 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
44067 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
44068 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
44069 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44070 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44071 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44072 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44073 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
44074 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44075 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44076 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44077 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44078 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44079 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44080 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
44081 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
44082 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
44083 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
44084 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
44085 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
44086 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
44087 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
44088 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
44089 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
44090 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
44091 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
44092 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
44093 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
44094 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
44095 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
44096 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44097 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44098 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
44099 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
44100 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
44101 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
44102 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
44103 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44104 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
44105 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
44106 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44107 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44108 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
44109 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
44110 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
44111 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
44112 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
44113 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
44114 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
44115 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
44116 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
44117 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
44118 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
44119 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
44120 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
44121 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
44122 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
44123 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
44124 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
44125 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
44126 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
44127 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
44128 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
44129 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
44130 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
44131 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
44132 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
44133 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
44134 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
44135 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
44136 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
44137 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
44138 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44139 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44140 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
44141 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
44142 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
44143 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
44144 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
44145 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
44146 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
44147 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
44148 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
44149 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
44150 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
44151 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44152 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
44153 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
44154 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44155 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44156 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
44157 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
44158 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
44159 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
44160 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
44161 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
44162 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
44163 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
44164 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
44165 &384*A12*MB*MT*P1Q1**2/S**2+
44166 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
44167 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
44168 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
44169 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
44170 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
44171 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
44172 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
44173 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
44174 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
44175 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
44176 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
44177 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
44178 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
44179 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
44180 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
44181 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
44182 &384*A2**2*MB*MT*P2Q2**2/S**2+
44183 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
44184 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
44185 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
44186 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
44187 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
44188 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
44189 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
44190 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
44191 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
44192 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
44193 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
44194 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
44195 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
44196 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
44197 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
44198 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
44199 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
44200 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
44201 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
44202 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
44203 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
44204 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
44205 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
44206 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
44207 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
44208 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
44209 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
44210 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
44211 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
44212 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
44213 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
44214 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
44215 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
44216 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
44217 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
44218 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
44219 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
44220 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
44221 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44222 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
44223 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44224 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
44225 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
44226 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
44227 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
44228 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
44229 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
44230 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
44231 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
44232 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
44233 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
44234 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
44235 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
44236 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
44237 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
44238 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
44239 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
44240 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
44241 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44242 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44243 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
44244 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
44245 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
44246 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
44247 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
44248 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
44249 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
44250 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
44251 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
44252 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
44253 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
44254 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
44255 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
44256 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
44257 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
44258 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
44259 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
44260 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
44261 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
44262 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
44263 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
44264 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
44265 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
44266 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
44267 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
44268 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
44269 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
44270 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
44271 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
44272 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
44273 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
44274 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
44275 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44276 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44277 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
44278 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
44279 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
44280 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
44281 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
44282 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
44283 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
44284 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
44285 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
44286 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44287 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44288 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44289 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44290 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44291 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44292 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
44293 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
44294 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
44295 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
44296 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
44297 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
44298 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
44299 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
44300 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
44301 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
44302 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
44303 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
44304 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
44305 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
44306 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
44307 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
44308 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
44309 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
44310 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
44311 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
44312 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
44313 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
44314 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
44315 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
44316 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
44317 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
44318 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
44319 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
44320 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
44321 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
44322 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44323 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44324 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
44325 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
44326 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
44327 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
44328 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
44329 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
44330 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
44331 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
44332 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
44333 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
44334 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
44335 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44336 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44337 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
44338 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44339 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44340 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44341 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44342 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44343 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44344 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
44345 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
44346 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
44347 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
44348 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
44349 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
44350 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
44351 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
44352 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
44353 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
44354 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
44355 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
44356 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
44357 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
44358 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44359 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44360 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
44361 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
44362 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
44363 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
44364 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
44365 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
44366 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
44367 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
44368 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
44369 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
44370 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
44371 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
44372 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
44373 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
44374 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
44375 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
44378 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
44379 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
44380 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
44381 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
44382 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
44383 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
44384 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
44385 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
44386 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
44387 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
44388 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
44389 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
44390 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
44391 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
44392 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
44393 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
44394 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
44396 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
44397 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
44398 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
44399 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
44400 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
44401 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
44402 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44403 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44404 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
44405 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
44406 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
44407 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
44408 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
44409 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
44410 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
44411 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
44412 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
44413 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
44414 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
44415 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
44416 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
44417 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
44418 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
44419 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
44420 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
44421 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
44422 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
44423 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
44424 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
44425 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
44426 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
44427 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
44428 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
44429 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
44430 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
44431 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
44432 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
44433 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
44434 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
44435 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
44436 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
44437 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44438 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44439 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
44440 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
44441 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
44442 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
44443 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
44444 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
44445 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
44446 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
44447 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44448 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44449 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
44450 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44451 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44452 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44453 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44454 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44455 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44456 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44457 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
44458 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
44459 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
44460 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
44461 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
44462 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
44463 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
44464 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
44465 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
44466 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
44467 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
44468 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
44469 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
44470 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
44471 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
44472 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
44473 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
44474 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
44475 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
44476 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
44477 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
44478 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
44479 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
44480 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
44481 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44485 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
44486 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
44487 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44488 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44489 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
44490 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
44491 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44492 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
44493 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
44494 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
44495 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44496 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44497 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
44498 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
44499 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
44500 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
44501 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
44502 V910=V910+96*A1*A2*P1P2*P2Q1/S-
44503 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
44504 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
44505 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
44506 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
44507 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
44509 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
44510 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
44511 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44512 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44513 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
44514 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
44515 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44516 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
44517 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
44518 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
44519 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44520 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44521 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
44522 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
44523 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
44524 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
44525 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
44526 A910=A910+96*A1*A2*P1P2*P2Q1/S-
44527 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
44528 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
44529 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
44530 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
44531 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
44535 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
44538 C---------------------------------------------------------
44539 C 2) Q QBAR ->TBH^+
44540 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
44542 C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
44543 C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
44544 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44545 IMPLICIT INTEGER(I-N)
44546 DOUBLE PRECISION MW2,MT,MB,MHP,MW
44547 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
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/PYMSSM/IMSS(0:99),RMSS(0:99)
44551 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
44552 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
44553 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
44554 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
44555 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
44556 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
44558 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
44559 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
44566 C COLLECTING THE RELEVANT OVERALL FACTORS:
44567 C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
44568 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
44569 C COUPLING CONSTANT (OVERALL NORMALIZATION)
44570 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
44571 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
44572 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
44573 C ALPHAS IS ALPHA_STRONG;
44574 C SW2 IS SIN(THETA_W)**2.
44577 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
44579 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
44580 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
44581 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
44583 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
44584 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
44586 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
44588 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
44589 S = 2*PYTBHS(Q1,Q2)
44596 C TOP WIDTH CALCULATION
44597 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
44598 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
44599 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
44600 A1INV= S -2*P1Q1 -2*P1Q2
44601 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
44602 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
44603 C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
44604 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
44605 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
44606 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
44607 C NOW COMES THE AMP**2:
44608 C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
44609 C THE EXPRESSIONS BELOW
44610 YY(1, 1) = -16*A**2*A2**2*MB*MT+
44611 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
44612 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
44613 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
44614 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44615 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44616 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
44617 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
44618 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
44619 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
44620 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
44621 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
44622 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
44623 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
44624 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
44625 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
44626 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
44627 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
44628 &32*A2**2*MB**2*P1P2*V**2/S+
44629 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
44630 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
44631 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
44632 YY(1, 1)=2*YY(1, 1)
44634 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
44635 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
44636 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44637 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44638 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
44639 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
44640 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
44641 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44642 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
44643 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
44644 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
44645 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
44646 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
44647 &64*A**2*A1*A2*MB*MT*P1P2/S+
44648 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
44649 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
44650 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
44651 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
44652 &64*A**2*A1*A2*P1Q1*P2Q1/S-
44653 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
44654 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
44655 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
44656 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
44657 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
44658 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
44659 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
44660 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
44661 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
44662 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
44663 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
44664 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
44665 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
44666 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
44667 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
44668 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
44669 &32*A1*A2*P1P2*P1Q1*V**2/S+
44670 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
44671 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
44672 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
44673 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
44676 YY(2, 2) =-16*A**2*A12*MB*MT+
44677 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
44678 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
44679 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
44680 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
44681 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
44682 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
44683 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
44684 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
44685 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
44686 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
44687 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
44688 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
44689 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
44690 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
44691 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
44692 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
44693 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
44694 &32*A12*MT**2*P2Q2*V**2/S-
44695 &32*A12*P1Q2*P2Q2*V**2/S
44696 YY(2, 2)=2*YY(2, 2)
44698 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
44699 AMP2= FACT*PS*VTB**2*RES
44702 C=====================================================================
44703 C ************* FUNCTION SCALAR PRODUCTS *************************
44704 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
44705 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44706 IMPLICIT INTEGER(I-N)
44707 DIMENSION A(4),B(4)
44710 DUM=DUM-A(ID)*B(ID)
44716 C*********************************************************************
44719 C...Initializes supersymmetry: finds sparticle masses and
44720 C...branching ratios and stores this information.
44721 C...AUTHOR: STEPHEN MRENNA
44722 C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
44726 C...Double precision and integer declarations.
44727 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44728 IMPLICIT INTEGER(I-N)
44729 INTEGER PYK,PYCHGE,PYCOMP
44730 C...Parameter statement to help give large particle numbers.
44731 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44732 &KEXCIT=4000000,KDIMEN=5000000)
44734 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44735 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44736 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44737 COMMON/PYDAT4/CHAF(500,2)
44739 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44740 COMMON/PYINT4/MWID(500),WIDS(500,5)
44741 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44742 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44743 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
44744 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
44745 COMMON/PYHTRI/HHH(7)
44746 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
44747 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
44748 &/PYMSSM/,/PYMSRV/,/PYSSMT/
44750 C...Local variables.
44751 DOUBLE PRECISION ALFA,BETA
44752 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
44753 INTEGER I,J,J1,I1,K1
44754 INTEGER KC,LKNT,IDLAM(400,3)
44755 DOUBLE PRECISION XLAM(0:400)
44756 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
44757 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
44758 DOUBLE PRECISION DELM,XMDIF
44759 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
44760 DOUBLE PRECISION ARG,SGNMU,R
44763 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
44766 &1000001,2000001,1000002,2000002,1000003,2000003,
44767 &1000004,2000004,1000005,2000005,1000006,2000006,
44768 &1000011,2000011,1000012,2000012,1000013,2000013,
44769 &1000014,2000014,1000015,2000015,1000016,2000016,
44770 &1000021,1000022,1000023,1000025,1000035,1000024,
44771 &1000037,1000039, 25, 35, 36, 37,
44772 & 6, 24, 45, 46,1000045, 9*0/
44775 C...Automatically read QNUMBERS, MASS, and DECAY tables
44776 IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
44778 CALL PYSLHA(0,0,IFAIL)
44779 CALL PYSLHA(5,0,IFAIL)
44781 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
44783 C...Do nothing further if SUSY not requested
44785 IF(IMSSM.EQ.0) RETURN
44787 C...Save copy of MWID(KC) and MDCY(KC,1) values before
44788 C...they are set to zero for the LSP.
44795 MDCYSU(I)=MDCY(KC,1)
44799 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
44803 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
44805 MDCY(KC,1)=MDCYSU(I)
44809 C...First part of routine: set masses and couplings.
44811 C...Reset mixing values in sfermion sector to pure left/right.
44819 C...Add NMSSM states if NMSSM switched on, and change old names.
44820 IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
44821 C... Switch on NMSSM
44822 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
44852 DO 123 KCT=100,MSTU(6)
44853 IF(KCHG(KCT,4).GT.100) KCN=KCT
44859 C... Set stable for now
44865 CHAF(KCN,1)='~chi_50'
44869 C...Read spectrum from SLHA file.
44870 IF (IMSSM.EQ.11) THEN
44871 CALL PYSLHA(1,0,IFAIL)
44874 C...Common couplings.
44879 COS2B=COS(2D0*BETA)
44885 C...Define sparticle masses for a general MSSM simulation.
44886 IF(IMSSM.EQ.1) THEN
44887 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
44889 KC=PYCOMP(KSUSY1+I)
44890 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
44891 KC=PYCOMP(KSUSY2+I)
44892 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
44893 KC=PYCOMP(KSUSY1+I+1)
44894 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
44895 KC=PYCOMP(KSUSY2+I+1)
44896 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
44898 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
44899 IF(XARG.LT.0D0) THEN
44900 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
44901 & ' FROM THE SUM RULE. '
44902 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
44908 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
44909 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
44910 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
44911 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
44913 IF(IMSS(8).EQ.1) THEN
44918 C...Alternatively derive masses from SUGRA relations.
44919 ELSEIF(IMSSM.EQ.2) THEN
44923 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
44932 C...Add in extra D-term contributions.
44933 IF(IMSS(7).EQ.1) THEN
44938 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44939 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
44940 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
44941 WRITE(MSTU(11),*) 'C DX = ',DX
44942 WRITE(MSTU(11),*) 'C DY = ',DY
44943 WRITE(MSTU(11),*) 'C DS = ',DS
44944 WRITE(MSTU(11),*) 'C '
44945 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
44946 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
44947 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44948 DQ2=DY/6D0-DX/3D0-DS/3D0
44949 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
44950 DD2=DY/3D0+DX-2D0*DS/3D0
44951 DL2=-DY/2D0+DX-2D0*DS/3D0
44952 DE2=DY-DX/3D0-DS/3D0
44953 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
44954 DHD2=-DY/2D0-2D0*DX/3D0+DS
44955 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
44957 DMA2 = 2D0*DMU2+DHU2+DHD2
44959 KC=PYCOMP(KSUSY1+I)
44960 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44961 KC=PYCOMP(KSUSY2+I)
44962 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
44963 KC=PYCOMP(KSUSY1+I+1)
44964 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44965 KC=PYCOMP(KSUSY2+I+1)
44966 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
44969 KC=PYCOMP(KSUSY1+I)
44970 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44971 KC=PYCOMP(KSUSY2+I)
44972 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
44973 KC=PYCOMP(KSUSY1+I+1)
44974 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44976 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
44977 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
44980 SGNMU=SIGN(1D0,RMSS(4))
44981 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
44982 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
44983 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
44984 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
44985 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
44986 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
44987 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
44988 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
44989 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
44990 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
44991 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
44992 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
44993 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
44996 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
44997 RMSS(6)=SQRT(RMSS(6)**2+DL2)
44998 RMSS(7)=SQRT(RMSS(7)**2+DE2)
44999 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
45000 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
45001 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
45002 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
45003 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
45006 C...Fix the third generation sfermions.
45009 C...Fix the neutralino--chargino--gluino sector.
45012 C...Fix the Higgs sector.
45015 C...Choose the Gunion-Haber convention.
45019 C...Print information on mass parameters.
45020 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
45021 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45022 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
45023 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
45024 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
45025 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
45026 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
45027 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
45028 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
45029 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
45030 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45032 IF(IMSS(20).EQ.1) THEN
45033 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45034 WRITE(MSTU(11),*) ' DEBUG MODE '
45035 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
45036 & UMIX(2,1),UMIX(2,2)
45037 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
45038 & UMIXI(2,1),UMIXI(2,2)
45039 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
45040 & VMIX(2,1),VMIX(2,2)
45041 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
45042 & VMIXI(2,1),VMIXI(2,2)
45043 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
45044 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
45045 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
45046 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
45047 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
45048 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
45049 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
45050 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
45051 WRITE(MSTU(11),*) ' ALFA = ',ALFA
45052 WRITE(MSTU(11),*) ' BETA = ',BETA
45053 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
45054 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
45055 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45058 C...Set up the Higgs couplings - needed here since initialization
45059 C...in PYINRE did not yet occur when PYWIDT is called below.
45071 C2B=COSB**2-SINB**2
45072 C...tanb (used for H+)
45076 C...Coupling to d-type quarks
45077 PARU(161)=SINA/COSB
45078 C...Coupling to u-type quarks
45079 PARU(162)=-COSA/SINB
45080 C...Coupling to leptons
45081 PARU(163)=PARU(161)
45085 PARU(165)=PARU(164)
45088 C...Coupling to d-type quarks
45089 PARU(171)=-COSA/COSB
45090 C...Coupling to u-type quarks
45091 PARU(172)=-SINA/SINB
45092 C...Coupling to leptons
45093 PARU(173)=PARU(171)
45097 PARU(175)=PARU(174)
45099 IF(IMSS(4).GE.2) THEN
45100 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
45102 HHH(3)=HHH(3)+HHH(4)+HHH(5)
45103 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
45104 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
45105 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
45106 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
45110 IF(IMSS(4).GE.2) THEN
45111 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
45113 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
45114 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
45115 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
45116 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
45119 IF(IMSS(4).GE.2) THEN
45120 PARU(177)=COS(2D0*BE)*COS(BE+AL)
45122 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
45123 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
45124 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
45125 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
45128 IF(IMSS(4).GE.2) THEN
45129 PARU(178)=PARU(177)
45131 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
45134 C...Coupling to d-type quarks
45136 C...Coupling to u-type quarks
45137 PARU(182)=1D0/PARU(181)
45138 C...Coupling to leptons
45139 PARU(183)=PARU(181)
45142 C...Coupling to Z h
45143 PARU(186)=COS(BE-AL)
45144 C...Coupling to Z H
45145 PARU(187)=SIN(BE-AL)
45151 C...Coupling to W h
45152 PARU(195)=COS(BE-AL)
45154 C...Tell that all Higgs couplings have been set.
45157 C...Set R-Violating couplings.
45158 C...Set lambda couplings to common value or "natural values".
45159 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
45160 VIR3=1D0/(126D0)**3
45164 IF (IRI.NE.IRJ) THEN
45165 IF (IRI.LT.IRJ) THEN
45166 RVLAM(IRI,IRJ,IRK)=RMSS(51)
45167 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
45168 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
45169 & PMAS(9+2*IRK,1)*VIR3)
45171 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
45174 RVLAM(IRI,IRJ,IRK)=0D0
45180 C...Set lambda' couplings to common value or "natural values".
45181 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
45182 VIR3=1D0/(126D0)**3
45186 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
45187 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
45188 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
45189 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
45194 C...Set lambda'' couplings to common value or "natural values".
45195 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
45196 VIR3=1D0/(126D0)**3
45200 IF (IRJ.NE.IRK) THEN
45201 IF (IRJ.LT.IRK) THEN
45202 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
45203 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
45204 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
45205 & PMAS(2*IRK-1,1)*VIR3)
45207 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
45210 RVLAMB(IRI,IRJ,IRK) = 0D0
45217 C...Antisymmetrize couplings set by user
45218 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
45222 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
45223 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
45224 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
45226 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
45227 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
45228 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
45235 C...Write spectrum to SLHA file
45236 IF (IMSS(23).NE.0) THEN
45238 CALL PYSLHA(3,0,IFAIL)
45241 C...Second part of routine: set decay modes and branching ratios.
45243 C...Allow chi10 -> gravitino + gamma or not.
45244 KC=PYCOMP(KSUSY1+39)
45245 IF( IMSS(11) .NE. 0 ) THEN
45246 PMAS(KC,1)=RMSS(21)/1D9
45249 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
45250 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
45252 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
45253 & ' ALLOWING SUSY LLE DECAYS'
45254 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
45255 & ' ALLOWING SUSY LQD DECAYS'
45256 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
45257 & ' ALLOWING SUSY UDD DECAYS'
45258 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
45259 & ' --- Warning: R-Violating couplings possibly',
45260 & ' incompatible with proton decay'
45266 C...Loop over sparticle and Higgs species.
45267 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
45268 C...Find the LSP or NLSP for a gravitino LSP
45273 IF(KF.EQ.1000039) GOTO 300
45275 IF(PMAS(KC,1).LT.PMLSP) THEN
45281 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
45283 IF (KF.EQ.0) GOTO 370
45287 C...Check if there are any decays listed for this sparticle
45289 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
45291 CALL PYSLHA(2,KF,IFAIL)
45292 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
45293 ELSEIF (I.GE.37) THEN
45297 C...Sfermion decays.
45299 C...First check to see if sneutrino is lighter than chi10.
45300 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
45301 & PMAS(KC,1).LT.PMCHI1) THEN
45303 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
45307 ELSEIF(I.EQ.25) THEN
45308 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
45309 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
45311 C...Neutralino decays.
45312 ELSEIF(I.GE.26.AND.I.LE.29) THEN
45313 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
45314 C...chi10 stable or chi10 -> gravitino + gamma.
45315 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
45321 C...Chargino decays.
45322 ELSEIF(I.GE.30.AND.I.LE.31) THEN
45323 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
45325 C...Gravitino is stable.
45326 ELSEIF(I.EQ.32) THEN
45331 ELSEIF(I.GE.33.AND.I.LE.36) THEN
45332 C...Calculate decays to non-SUSY particles.
45333 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
45338 DO 330 I1=1,MDCY(KC,3)
45340 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
45341 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
45343 XLAM(0)=XLAM(0)+XLAM(I1)
45345 IDLAM(I1,J1)=KFDP(K1,J1)
45349 C...Add the decays to SUSY particles.
45350 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
45352 C...Zero the branching ratios for use in loop mode
45353 C...thanks to K. Matchev (FNAL)
45354 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45358 C...Set stable particles.
45366 C...Store branching ratios in the standard tables.
45368 IDC=MDCY(KC,2)+MDCY(KC,3)-1
45374 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
45375 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
45376 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
45377 BRAT(IDC)=XLAM(IL)/XLAM(0)
45379 IF(MDME(IDC,1).GE.1) THEN
45380 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
45381 & PMAS(PYCOMP(KFDP(IDC,2)),1)
45382 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
45383 & PMAS(PYCOMP(KFDP(IDC,3)),1)
45386 IF(XMDIF.GE.0D0) THEN
45387 DELM=MIN(DELM,XMDIF)
45389 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
45390 WRITE(MSTU(11),*) ' KF = ',KF
45391 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
45395 ELSEIF(IDC.EQ.IDCSV) THEN
45396 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
45397 & 'channel not recognized:'
45398 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
45405 C...Store width, cutoff and lifetime.
45407 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
45408 PMAS(KC,3)=PMAS(KC,2)*10D0
45410 PMAS(KC,3)=0.95D0*DELM
45412 IF(PMAS(KC,2).NE.0D0) THEN
45413 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
45415 C...Write decays to SLHA file
45416 IF (IMSS(24).NE.0) THEN
45418 CALL PYSLHA(4,KF,IFAIL)
45426 C*********************************************************************
45429 C...Read/write spectrum or decay data from SLHA standard file(s).
45432 C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
45433 C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
45434 C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
45435 C... (KFORIG=0 : read all decay tables)
45436 C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
45437 C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
45438 C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
45439 C... (KFORIG=0 : read all MASS entries)
45441 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
45443 C...Double precision and integer declarations.
45444 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45445 IMPLICIT INTEGER(I-N)
45446 INTEGER PYK,PYCHGE,PYCOMP
45447 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45448 &KEXCIT=4000000,KDIMEN=5000000)
45450 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45451 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45452 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45453 COMMON/PYDAT4/CHAF(500,2)
45455 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
45456 CHARACTER*40 ISAVER,VISAJE
45457 COMMON/PYINT4/MWID(500),WIDS(500,5)
45458 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
45460 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45461 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45462 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45463 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
45464 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
45466 C...Local arrays, character variables and data.
45467 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
45468 & AU(3,3),AD(3,3),AE(3,3)
45469 COMMON/PYLH3C/CPRO(2),CVER(2)
45470 C...The common block of new states (QNUMBERS / PARTICLE)
45471 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
45472 C...- NQNUM : Number of QNUMBERS blocks that have been read in
45473 C...- KQNUM(I,0) : KF of new state
45474 C...- KQNUM(I,1) : 3 times electric charge
45475 C...- KQNUM(I,2) : Number of spin states: (2S + 1)
45476 C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
45477 C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
45478 C...- KQNUM(I,5:9) : space available for further quantum numbers
45479 DIMENSION MMOD(100),MSPC(100),KFDEC(100)
45480 SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
45481 C...MMOD: flags to set for each block read in.
45482 C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
45483 C...MSPC: Flags to set for each block read in.
45484 C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
45485 C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
45486 C...11: AD 12: AE 13: YU 14: YD 15: YE
45487 C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
45488 CHARACTER CPRO*12,CVER*12,CHNLIN*6
45489 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
45490 CHARACTER CHINL*120,CHKF*9,CHTMP*16
45493 C...Date of last Change
45494 PARAMETER (DOC='13 Jul 2009')
45495 C...Local arrays and initial values
45496 DIMENSION IDC(5),KFSUSY(50)
45505 &1000001,1000002,1000003,1000004,1000005,1000006,
45506 &2000001,2000002,2000003,2000004,2000005,2000006,
45507 &1000011,1000012,1000013,1000014,1000015,1000016,
45508 &2000011,2000012,2000013,2000014,2000015,2000016,
45509 &1000021,1000022,1000023,1000025,1000035,1000024,
45510 &1000037,1000039, 25, 35, 36, 37,
45511 & 6, 24, 45, 46,1000045, 9*0/
45513 RMFUN(IP)=PMAS(PYCOMP(IP),1)
45515 C...Shorthand for spectrum and decay table unit numbers
45519 C...Default for LHEF input: read header information
45520 IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
45521 IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
45522 IF (IMSS21.EQ.MSTP(161).AND.IMSS21.NE.0) MLHEF=1
45523 IF (IMSS22.EQ.MSTP(161).AND.IMSS22.NE.0) MLHEFD=1
45526 IF (NHELLO.EQ.0) THEN
45527 IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
45528 WRITE(MSTU(11),5000) DOC
45533 C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
45536 IF (MUPDA.EQ.2) LFN=IMSS22
45537 IF (MUPDA.EQ.3) LFN=IMSS(23)
45538 IF (MUPDA.EQ.4) LFN=IMSS(24)
45539 C...Flag that we have not yet found whatever we were asked to find.
45541 C...Flag that we are skipping until <slha> tag found (if LHEF)
45543 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) ISKIP=1
45545 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
45547 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
45551 C...If reading LHEF header, start by rewinding file
45552 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
45554 C...If told to read spectrum, first zero all previous information.
45555 IF (MUPDA.EQ.1) THEN
45556 C...Zero all block read flags
45561 C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
45563 KC=PYCOMP(KFSUSY(ISUSY))
45566 C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
45574 IF (J.LE.2.AND.L.LE.2) THEN
45581 C...Zero signed masses.
45583 IF (J.LE.2) SMW(J)=0D0
45586 C...If reading decays, reset PYTHIA decay counters.
45587 ELSEIF (MUPDA.EQ.2) THEN
45588 C...Check if DECAY for this KF already read
45589 IF (KFORIG.NE.0) THEN
45590 DO 140 IDEC=1,NDECAY
45591 IF (KFORIG.EQ.KFDEC(IDEC)) THEN
45600 DO 150 KC=1,MSTU(6)
45601 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
45602 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
45604 ELSEIF (MUPDA.EQ.5) THEN
45605 C...Zero block read flags
45612 C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
45613 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
45614 C...Initialize program and version strings
45615 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
45620 C...Initialize read loop
45624 C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
45626 READ(LFN,'(A120)',END=400) CHINL
45627 C...Count which line number we're at.
45629 WRITE(CHNLIN,'(I6)') NLINE
45631 C...Skip comment and empty lines without processing.
45632 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
45634 C...We assume all upper case below. Rewrite CHINL to all upper case.
45638 IF (CHINL(INL:INL).NE.'#') THEN
45640 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
45642 C...Extra safety. Chek for sensible input on line
45643 IF (IGOOD.EQ.0) THEN
45645 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
45648 IF (INL.LT.120) GOTO 180
45650 IF (IGOOD.EQ.0) GOTO 170
45652 C...If reading from LHEF file, skip until <slha> begin tag found
45653 IF (ISKIP.NE.0) THEN
45655 IF (CHINL(I1:I1+4).EQ.'<SLHA') ISKIP=0
45657 IF (ISKIP.NE.0) GOTO 170
45660 C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
45662 IF (CHINL(I1:I1+5).EQ.'</SLHA'
45663 & .OR.CHINL(I1:I1+5).EQ.'<EVENT'
45664 & .OR.CHINL(I1:I1+4).EQ.'<INIT') THEN
45670 C...Check for BLOCK begin statement (spectrum).
45671 IF (CHINL(1:5).EQ.'BLOCK') THEN
45673 READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
45674 C...Check if another of this type of block was already read.
45675 C...(logarithmic interpolation not yet implemented, so duplicates always
45677 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
45678 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
45679 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
45680 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
45681 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
45682 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
45683 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
45684 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
45685 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
45686 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
45687 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
45688 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
45689 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
45690 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
45691 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
45692 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
45693 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
45694 C...Check for new particles
45695 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
45697 MSPC(19)=MSPC(19)+1
45699 READ(CHBLCK(9:60),*) KFQ
45702 IF (KQNUM(MQ,0).EQ.KFQ) THEN
45707 IF (NHELLO.EQ.0) THEN
45708 WRITE(MSTU(11),5000) DOC
45711 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45712 & ' * (PYSLHA:) Reading '//CHBLCK(1:8)//
45716 MSPC(19)=MSPC(19)+1
45718 C...Only read in new codes (also OK to overwrite if KF > 3000000)
45719 IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
45721 DO 230 KCT=100,MSTU(6)
45722 IF(KCHG(KCT,4).GT.100) KCQ=KCT
45728 C...First write PDG code as name
45730 WRITE(CHTMP,'(A)') CHTMP(2:10)
45731 C...Then look for real name
45734 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
45736 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
45739 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
45740 IF (IEND.LT.59) THEN
45741 READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
45742 IF (CHDUM.NE.' ') CHTMP=CHDUM
45744 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
45746 C...Set stable for now
45754 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
45755 & CHAF(KCQ,1), '. Entry ignored.'
45759 C...Finalize this line and read next.
45761 C...Check for DECAY begin statement (decays).
45762 ELSEIF (CHINL(1:3).EQ.'DEC') THEN
45766 C...Read KF code and WIDTH
45768 READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
45773 C...If this is not the KF we're looking for...
45774 IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
45775 C...Set block skip flag and read next line.
45779 C...Check whether decay table for this particle already read in
45780 DO 280 IDECAY=1,NDECAY
45781 IF (KFDEC(IDECAY).EQ.KF) THEN
45782 WRITE(MSTU(11),'(A,A,I9,A,A6,A)')
45783 & ' * (PYSLHA:) Ignoring DECAY table ',
45784 & 'for KF =',KF,' on line ',CHNLIN,
45792 C...Determine PYTHIA KC code of particle
45798 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
45802 IF (KCREP.NE.0) THEN
45803 C...Particle is already known. Do not overwrite low-mass SM particles,
45804 C...since this could give problems at hadronization / hadron decay stage.
45805 IF (IABS(KF).LT.1000000.AND.PMAS(KC,1).LT.20D0) THEN
45806 C...Set block skip flag and read next line
45807 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45808 & ' * (PYSLHA:) Ignoring DECAY table for KF =',
45809 & KF, ' (SLHA read-in not allowed)'
45814 C... Add new particle. Actually, this should not happen.
45815 C... New particles should be added already when reading the spectrum
45816 C... information, so go under previously stable category.
45821 IF (WIDTH.LE.0D0) THEN
45822 C...Stable (i.e. LSP)
45823 WRITE(MSTU(11),'(A,I9,A,A)')
45824 & ' * (PYSLHA:) Reading SLHA stable particle KF =',
45825 & KF,', ',CHAF(KCREP,1)(1:16)
45826 IF (WIDTH.LT.0D0) THEN
45827 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
45834 C...Ignore any decay lines that may be present for this KF
45841 C...Finalize and start reading in decay modes.
45843 ELSEIF (MOD(MERR,10).GE.6) THEN
45844 C...If ignore block flag set, skip directly to next line.
45849 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
45850 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
45852 READ(CHINL,*) INDX, IVAL
45853 IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
45854 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
45855 IF (INDX.EQ.3) KCHG(KCQ,2)=0
45856 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
45857 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
45858 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
45859 IF (INDX.EQ.4) THEN
45861 IF (IVAL.EQ.1) THEN
45863 IF (CHTMP.EQ.' ') THEN
45864 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
45865 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
45869 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
45870 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
45871 CHTMP(ILAST:ILAST)='-'
45873 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
45882 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
45883 C...MASS: Mass spectrum
45884 IF (CHBLCK(1:4).EQ.'MASS') THEN
45885 READ(CHINL,*) KF, VAL
45888 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
45889 C...Read in masses for almost anything
45893 C...Don't read in masses for special code particles
45894 IF (IABS(KF).GE.80.AND.IABS(KF).LT.100) THEN
45895 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45896 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45897 & KF, ' (KF reserved by PYTHIA)'
45900 C...Be careful with light SM particles / hadrons
45901 IF (PMAS(KC,1).LE.20D0) THEN
45902 IF (IABS(KF).LE.22) THEN
45903 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45904 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45905 & KF, ' (SLHA read-in not allowed)'
45908 ELSEIF (IABS(KF).GE.100.AND.IABS(KF).LT.1000000) THEN
45909 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45910 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45911 & KF, ' (SLHA read-in not allowed)'
45916 PMAS(KC,1) = ABS(VAL)
45917 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
45918 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45919 & ' * (PYSLHA:) Reading MASS entry for KF =',
45920 & KF, ', pole mass =', VAL
45923 C...Check Z, W and top masses
45924 IF (KF.EQ.23.AND.ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0)
45926 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45927 CALL PYERRM(9,'(PYSLHA:) Note Z boson mass, M ='
45930 IF (KF.EQ.24.AND.ABS(PMAS(PYCOMP(24),1)-80.4D0).GT.1D0)
45932 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45933 CALL PYERRM(9,'(PYSLHA:) Note W boson mass, M ='
45936 IF (KF.EQ.6.AND.ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0)
45938 WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
45939 CALL PYERRM(9,'(PYSLHA:) Note top quark mass, M ='
45943 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
45944 IF (KF.EQ.1000022) SMZ(1)=VAL
45945 IF (KF.EQ.1000023) SMZ(2)=VAL
45946 IF (KF.EQ.1000025) SMZ(3)=VAL
45947 IF (KF.EQ.1000035) SMZ(4)=VAL
45948 IF (KF.EQ.1000024) SMW(1)=VAL
45949 IF (KF.EQ.1000037) SMW(2)=VAL
45951 ELSEIF (MUPDA.EQ.5) THEN
45954 C... MODSEL: Model selection and global switches
45955 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
45956 READ(CHINL,*) INDX, IVAL
45957 IF (INDX.LE.200.AND.INDX.GT.0) THEN
45958 IF (IMSS(1).EQ.0) IMSS(1)=11
45961 IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
45962 C... Switch on NMSSM
45963 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
45964 IMSS(13)=MAX(1,IMSS(13))
45965 C... Add NMSSM states if not already done
45995 DO 310 KCT=100,MSTU(6)
45996 IF(KCHG(KCT,4).GT.100) KCN=KCT
46002 C... Set stable for now
46008 CHAF(KCN,1)='~chi_50'
46014 ELSEIF (MUPDA.EQ.5) THEN
46015 C...If MUPDA = 5, skip all except MASS, return if MODSEL
46017 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
46018 & CHBLCK(1:8).EQ.'PARTICLE') THEN
46019 C...Don't print a warning for QNUMBERS when reading spectrum
46021 C...MINPAR: Minimal model parameters
46022 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
46023 READ(CHINL,*) INDX, VAL
46024 IF (INDX.LE.100.AND.INDX.GT.0) THEN
46030 IF (MMOD(3).NE.0) THEN
46032 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
46036 IF (INDX.EQ.3) RMSS(5)=VAL
46037 C...EXTPAR: non-minimal model parameters.
46038 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
46039 IF (MMOD(1).NE.0) THEN
46040 READ(CHINL,*) INDX, VAL
46041 IF (INDX.LE.200.AND.INDX.GT.0) THEN
46049 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
46053 IF (INDX.EQ.25) RMSS(5)=VAL
46054 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
46055 READ(CHINL,*) INDX, VAL
46056 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
46058 ELSEIF (INDX.EQ.4) THEN
46059 PMAS(PYCOMP(23),1)=VAL
46060 ELSEIF (INDX.EQ.6) THEN
46061 PMAS(PYCOMP(6),1)=VAL
46063 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
46064 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
46065 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
46067 C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
46069 IF (CHBLCK(5:6).EQ.'IM') IM=1
46070 320 READ(CHINL,*) INDX1, INDX2, VAL
46071 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
46072 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
46073 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
46075 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
46076 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
46077 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
46079 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
46080 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
46081 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
46083 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
46084 $ .CHBLCK(1:4).EQ.'STAU') THEN
46085 IF (CHBLCK(1:4).EQ.'STOP') THEN
46088 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
46091 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
46095 C...Set SFMIX element
46096 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
46097 MSPC(ISPC)=MSPC(ISPC)+1
46099 C...Running parameters
46100 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
46101 READ(CHBLCK(8:25),*,ERR=620) Q
46102 READ(CHINL,*) INDX, VAL
46104 IF (INDX.EQ.1) THEN
46110 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
46111 READ(CHINL,*,ERR=630) VAL
46113 MSPC(17)=MSPC(17)+1
46114 C...Higgs parameters set manually or with FeynHiggs.
46115 IMSS(4)=MAX(2,IMSS(4))
46116 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
46117 & .CHBLCK(1:2).EQ.'AE') THEN
46118 READ(CHBLCK(9:26),*,ERR=620) Q
46119 READ(CHINL,*) INDX1, INDX2, VAL
46120 IF (CHBLCK(2:2).EQ.'U') THEN
46121 AU(INDX1,INDX2)=VAL
46122 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
46123 MSPC(11)=MSPC(11)+1
46124 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
46125 AD(INDX1,INDX2)=VAL
46126 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
46127 MSPC(10)=MSPC(10)+1
46128 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
46129 AE(INDX1,INDX2)=VAL
46130 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
46131 MSPC(12)=MSPC(12)+1
46135 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
46136 IF (MSPC(18).EQ.0) THEN
46137 READ(CHBLCK(9:25),*,ERR=620) Q
46140 READ(CHINL,*) INDX, VAL
46142 MSPC(18)=MSPC(18)+1
46143 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
46145 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
46146 & .CHBLCK(1:2).EQ.'YE') THEN
46148 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
46149 READ(CHINL(1:6),*) INDX
46153 IF (CHINL(IT:IT).EQ.' ') GOTO 330
46154 C...Don't read index
46155 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
46159 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
46160 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
46162 C... Set unrecognized block flag.
46167 C...Read in decay information
46168 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
46169 C...Read new decay chanel
46170 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
46172 C...Read in branching ratio and number of daughters for this mode.
46173 READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
46174 READ(CHINL(4:50),*,ERR=600) DUM, NDA
46176 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
46177 & '(PYSLHA:) Decay data arrays full by KF = '
46179 C...If first decay channel, set decays start point in decay table
46180 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
46181 IF (KFORIG.EQ.0) WRITE(MSTU(11),'(1x,A,I9,A,A16)')
46182 & '* (PYSLHA:) Reading DECAY table for '//
46183 & 'KF =',KF,', ',CHAF(KCREP,1)(1:16)
46184 C...Set particle parameters (mass set when reading BLOCK MASS above)
46186 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
46187 WRITE(MSTU(11),'(1x,A)')
46188 & '* Note: the Pythia gg->h/H/A cross section'//
46189 & ' is proportional to the h/H/A->gg width'
46190 ELSEIF (KF.EQ.23.OR.KF.EQ.24.OR.KF.EQ.6.OR.KF.EQ.32
46191 & .OR.KF.EQ.33.OR.KF.EQ.34) THEN
46192 WRITE(MSTU(11),'(1x,A,A16)')
46193 & '* Warning: will use DECAY table (fixed-width,'//
46194 & ' flat PS) for ',CHAF(KC,1)(1:16)
46197 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
46202 C...Add to list of DECAY blocks currently read
46208 C... Count up number of decay modes for this particle
46209 MDCY(KC,3)=MDCY(KC,3)+1
46210 C... Read in decay daughters.
46211 READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
46212 C... Flip sign if reading antiparticle decays (if antipartner exists)
46214 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
46215 & IDC(IDA)=MPSIGN*IDC(IDA)
46217 C...Switch on decay channel, with products ordered in decreasing ABS(KF)
46219 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
46220 BRSUM=BRSUM+ABS(BRAT(NDC))
46221 BRAT(NDC)=ABS(BRAT(NDC))
46224 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
46226 IDC(IDA)=IDC(IDA+1)
46231 IF (IFLIP.GT.0) GOTO 350
46232 C...Treat as ordinary decay, no fancy stuff.
46235 IF (IDA.LE.NDA) THEN
46236 KFDP(NDC,IDA)=IDC(IDA)
46241 C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
46242 C & (KFDP(NDC,J),J=1,NDA)
46244 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '//
46249 ELSEIF(CHINL(1:1).EQ.'+') THEN
46251 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
46258 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
46259 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
46262 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
46263 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
46264 & CHBLCK(1:MIN(INL,40))//'... on line '//CHNLIN
46265 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
46266 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
46267 & //CHBLCK(1:INL)//'... on line'//CHNLIN
46268 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
46269 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
46270 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
46271 & //'... on line'//CHNLIN
46272 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
46273 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
46274 & /CHBLCK(1:INL)//'... on line'//CHNLIN
46275 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
46278 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
46279 & CHTMP(1:9)//' on line'//CHNLIN
46281 C...Iterate read loop
46284 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
46285 & ', ignoring subsequent lines.'
46286 WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
46289 C...End of read loop
46291 C...Set flag that KC codes have been rearranged.
46295 C...Perform possible tests that new information is consistent.
46296 IF (MUPDA.EQ.1) THEN
46302 C...Don't complain about right-handed neutrinos
46303 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
46305 C...Only check gravitino in GMSB scenarios
46306 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
46308 IF (PMAS(KC,1).EQ.0D0) THEN
46311 & ,'(PYSLHA:) No mass information found for KF ='
46315 C...Check mixing matrices (MSSM only)
46316 IF (IMSS(13).EQ.0) THEN
46317 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
46318 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
46319 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
46320 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
46321 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
46322 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
46323 IF (MSPC(5).NE.4) CALL PYERRM(9
46324 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
46325 IF (MSPC(6).NE.4) CALL PYERRM(9
46326 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
46327 IF (MSPC(7).NE.4) CALL PYERRM(9
46328 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
46329 IF (MSPC(8).LT.1) CALL PYERRM(9
46330 & ,'(PYSLHA:) Too few elements in HMIX')
46331 IF (MSPC(10).EQ.0) CALL PYERRM(9
46332 & ,'(PYSLHA:) Missing A_b trilinear coupling')
46333 IF (MSPC(11).EQ.0) CALL PYERRM(9
46334 & ,'(PYSLHA:) Missing A_t trilinear coupling')
46335 IF (MSPC(12).EQ.0) CALL PYERRM(9
46336 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
46337 IF (MSPC(17).LT.1) CALL PYERRM(9
46338 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
46340 C...Check wavefunction normalizations.
46343 IF (MSPC(ISPC).EQ.4) THEN
46345 IF (ISPC.EQ.7) KFSM=15
46346 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
46348 IF (ABS(1D0-CHECK).GT.1D-3) THEN
46351 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
46354 C...Bug fix 30/09 2008: PS
46355 C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
46356 IF (SFMIX(KFSM,1)*SFMIX(KFSM,4).LT.0D0) THEN
46357 SFMIX(KFSM,3) = -SFMIX(KFSM,3)
46358 SFMIX(KFSM,4) = -SFMIX(KFSM,4)
46362 C...Neutralinos + charginos
46371 CN1=CN1+ZMIX(J,L)**2
46372 CN2=CN2+ZMIX(L,J)**2
46373 IF (J.LE.2.AND.L.LE.2) THEN
46374 CU1=CU1+UMIX(J,L)**2
46375 CU2=CU2+UMIX(L,J)**2
46376 CV1=CV1+VMIX(J,L)**2
46377 CV2=CV2+VMIX(L,J)**2
46380 C...NMIX normalization
46381 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
46382 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
46384 & '(PYSLHA:) NMIX: Inconsistent normalization.')
46385 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
46387 C...UMIX, VMIX normalizations
46388 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
46390 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
46392 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
46393 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
46396 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
46398 & '(PYSLHA:) VMIX: Inconsistent normalization.')
46399 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
46405 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
46406 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
46407 & '* (PYSLHA:) No spectrum inconsistencies were found.'
46409 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
46410 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
46411 & ,' Warning: one or more (serious)'//
46412 & ' inconsistencies were found in the spectrum !'
46413 & ,' Read the error messages above and check your'//
46416 C...Increase precision in Higgs sector using FeynHiggs
46417 IF (IMSS(4).EQ.3) THEN
46418 C...FeynHiggs needs MSOFT.
46420 IF (MSPC(18).EQ.0) THEN
46421 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
46422 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
46423 & ' Cannot call FeynHiggs.'
46426 WRITE(MSTU(11),'(1x,/1x,A/)')
46427 & '* (PYSLHA:) Now calling FeynHiggs.'
46429 IF (IERR.NE.0) IMSS(4)=2
46432 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
46434 IF (KFORIG.NE.0) IBEG=NDECAY
46435 DO 490 IDECAY=IBEG,NDECAY
46438 WRITE(CHKF,8300) KF
46439 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
46440 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
46441 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
46442 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
46446 DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46447 IF(MDME(IDA,2).GT.80) GOTO 460
46449 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
46453 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
46455 ELSEIF(PYCOMP(KP).EQ.0) THEN
46460 PMS=PMS-PMAS(KPC,1)
46461 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
46465 IF(KQ.NE.0) MERR=MAX(2,MERR)
46466 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
46468 IF(MERR.EQ.3) CALL PYERRM(17,
46469 & '(PYSLHA:) Unknown particle code in decay of KF ='
46471 IF(MERR.EQ.2) CALL PYERRM(17,
46472 & '(PYSLHA:) Charge not conserved in decay of KF ='
46474 IF(MERR.EQ.1) CALL PYERRM(7,
46475 & '(PYSLHA:) Kinematically unallowed decay of KF ='
46477 BRSUM=BRSUM+BRAT(IDA)
46478 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
46480 C...Check branching ratio sum.
46481 IF (BROPN.LE.0D0) THEN
46482 C...If zero, set stable.
46483 WRITE(CHTMP,8500) BROPN
46485 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
46486 & CHTMP(9:16)//'. Changed to stable.')
46489 C...If BR's > 1, rescale.
46490 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
46491 WRITE(CHTMP,8500) BRSUM
46492 IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
46493 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
46494 & ' ; sum was'//CHTMP(9:16)//'.')
46496 DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46497 IF(MDME(IDA,2).GT.80) GOTO 470
46498 BRAT(IDA)=FAC*BRAT(IDA)
46500 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
46501 C...If BR's < 1, insert dummy mode for proper cross section rescaling.
46502 WRITE(CHTMP,8500) BRSUM
46503 IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
46504 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
46505 & CHTMP(9:16)//'. Dummy mode will be inserted.')
46506 C...Move table and insert dummy mode
46507 DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46509 BRAT(NDC)=BRAT(IDA)
46510 KFDP(NDC,1)=KFDP(IDA,1)
46511 KFDP(NDC,2)=KFDP(IDA,2)
46512 KFDP(NDC,3)=KFDP(IDA,3)
46513 KFDP(NDC,4)=KFDP(IDA,4)
46514 KFDP(NDC,5)=KFDP(IDA,5)
46515 MDME(NDC,1)=MDME(IDA,1)
46518 BRAT(NDC)=1D0-BRSUM
46527 MDCY(KC,3)=MDCY(KC,3)+1
46528 MDCY(KC,2)=NDC-MDCY(KC,3)+1
46534 C...WRITE SPECTRUM ON SLHA FILE
46535 ELSEIF(MUPDA.EQ.3) THEN
46536 C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
46537 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
46542 PARMIN(4)=SIGN(1D0,RMSS(4))
46546 WRITE(LFN,7000) 'SLHA MSSM spectrum'
46547 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
46549 WRITE(LFN,7010) 'MODSEL', 'Model selection'
46550 WRITE(LFN,7110) 1, MODSEL(1)
46551 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
46552 IF (MODSEL(1).EQ.1) THEN
46553 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
46554 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
46555 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
46556 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
46557 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
46558 ELSEIF(MODSEL(2).EQ.2) THEN
46559 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
46560 WRITE(LFN,7210) 2, PARMIN(2), 'M'
46561 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
46562 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
46563 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
46564 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
46566 WRITE(LFN,7000) ' '
46567 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
46571 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
46573 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
46574 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
46575 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
46576 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
46577 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
46578 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
46579 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
46581 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
46585 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
46586 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
46587 WRITE(LFN,7210) 1, RMSS(4),'mu'
46588 WRITE(LFN,7010) 'ALPHA',' '
46589 WRITE(LFN,7210) 1, RMSS(18), 'alpha'
46590 WRITE(LFN,7020) 'AU',RMSUSY
46591 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
46592 WRITE(LFN,7020) 'AD',RMSUSY
46593 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
46594 WRITE(LFN,7020) 'AE',RMSUSY
46595 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
46596 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
46597 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
46598 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
46599 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
46600 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
46601 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
46602 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
46603 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
46604 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
46605 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
46606 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
46607 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
46608 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
46609 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
46610 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
46611 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
46614 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
46617 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
46620 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
46623 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
46626 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
46629 WRITE(LFN,7010) 'SPINFO'
46630 IF (IMSS(1).EQ.2) THEN
46633 ELSEIF (IMSS(1).EQ.12) THEN
46636 CVER(1)=ISAVER(1:12)
46638 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
46639 WRITE(LFN,7310) 2, CVER(1), 'Version number'
46642 C...Print user information about spectrum
46643 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
46644 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
46645 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
46646 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
46647 IF (MUPDA.EQ.1) THEN
46648 WRITE(MSTU(11),5020) LFN
46650 WRITE(MSTU(11),5010) LFN
46653 WRITE(MSTU(11),5400)
46654 WRITE(MSTU(11),5500) 'Pole masses'
46655 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
46656 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
46657 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
46658 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
46659 IF (IMSS(13).EQ.0) THEN
46660 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
46661 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
46662 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
46663 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
46664 & CHAF(37,1), ' ', ' ',' ',' ',
46665 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
46666 ELSEIF (IMSS(13).EQ.1) THEN
46675 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
46676 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
46677 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
46678 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
46679 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
46680 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
46681 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
46682 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
46683 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
46686 WRITE(MSTU(11),5400)
46687 WRITE(MSTU(11),5500) 'Mixing structure'
46688 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
46689 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
46690 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
46691 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
46692 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
46693 & ),(SFMIX(15,J),J=3,4)
46694 WRITE(MSTU(11),5400)
46695 WRITE(MSTU(11),5500) 'Couplings'
46696 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
46697 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
46698 WRITE(MSTU(11),5400)
46699 WRITE(MSTU(11),6500)
46703 C...Only rewind when reading
46704 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
46708 C...Serious error catching
46709 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
46710 write(*,*) CHINL(1:80)
46712 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
46713 WRITE(*,*) CHINL(1:72)
46715 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
46716 WRITE(*,*) CHINL(1:80)
46718 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
46719 WRITE(*,*) CHINL(1:80)
46720 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
46722 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
46723 WRITE(*,*) CHINL(1:80)
46729 C...Formats for user information printout.
46730 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.13: SUSY/BSM SPECTRUM '
46731 & ,'INTERFACE',1x,17('*')/1x,'*',1x
46732 & ,'(PYSLHA:) Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
46733 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
46734 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
46735 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
46736 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
46737 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
46738 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
46739 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
46740 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
46741 & ,'----------------')
46742 5400 FORMAT(1x,'*',1x,A)
46743 5500 FORMAT(1x,'*',1x,A,':')
46744 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
46745 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
46746 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
46747 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
46748 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
46749 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
46750 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
46751 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
46752 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
46753 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
46754 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
46755 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
46756 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
46757 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
46758 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
46759 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
46760 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
46761 & ,1x,F6.3,1x),'|')
46762 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
46763 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
46764 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
46765 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
46766 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
46767 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
46768 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
46769 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
46770 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
46771 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
46772 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
46773 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
46774 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
46775 & ,'A_tau = ',F8.2)
46776 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
46778 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
46780 C...Format to use for comments
46781 7000 FORMAT('# ',A)
46782 C...Format to use for block statements
46783 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
46784 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
46786 7110 FORMAT(1x,I4,1x,I4,3x,'#')
46787 C...Non-Indexed Double
46788 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
46790 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
46791 C...Long Indexed Double (PDG + double)
46792 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
46793 C...Indexed Char(12)
46794 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
46796 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
46798 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
46799 C...Write Decay Table
46800 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
46801 7510 FORMAT(4x,I5,1x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),
46807 C*********************************************************************
46810 C...Uses approximate analytical formulae to determine the full set of
46811 C...MSSM parameters from SUGRA input.
46812 C...See M. Drees and S.P. Martin, hep-ph/9504124
46816 C...Double precision and integer declarations.
46817 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46818 IMPLICIT INTEGER(I-N)
46819 INTEGER PYK,PYCHGE,PYCOMP
46820 C...Parameter statement to help give large particle numbers.
46821 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46822 &KEXCIT=4000000,KDIMEN=5000000)
46824 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46825 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46826 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46827 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
46829 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
46830 &' not intended for serious physics studies'
46843 C...Temporary sign change for AT. Others unchanged.
46847 SINB=TANB/SQRT(TANB**2+1D0)
46850 DTERM=XMZ2*COS(2D0*BETA)
46851 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
46852 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
46855 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
46856 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
46857 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
46858 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
46860 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
46861 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
46862 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
46863 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
46865 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
46866 IF(XARG.LT.0D0) THEN
46867 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
46868 & ' FROM THE SUM RULE. '
46869 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
46875 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
46876 PMAS(PYCOMP(KSUSY2+I),1)=XMER
46877 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
46878 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
46880 RMT=PYMRUN(6,PMAS(6,1)**2)
46881 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
46882 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
46883 RMB=PYMRUN(5,PMAS(6,1)**2)
46884 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
46885 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
46886 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
46887 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
46890 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
46891 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
46892 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
46893 XMU=SIGN(SQRT(XMU2),RMSS(4))
46895 IF(XMA2.GT.0D0) THEN
46896 RMSS(19)=SQRT(XMA2)
46898 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
46901 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
46902 IF(ARG.GT.0D0) THEN
46905 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
46908 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
46909 IF(ARG.GT.0D0) THEN
46912 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
46915 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
46916 IF(ARG.GT.0D0) THEN
46919 RMSS(10)=-SQRT(-ARG)
46921 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
46922 IF(ARG.GT.0D0) THEN
46925 RMSS(12)=-SQRT(-ARG)
46927 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
46928 IF(ARG.GT.0D0) THEN
46931 RMSS(11)=-SQRT(-ARG)
46937 C*********************************************************************
46940 C...Interface to ISASUSY version 7.71.
46941 C...Warning: this interface should not be used with earlier versions
46942 C...of ISASUSY, since common block incompatibilities may then arise.
46943 C...Calls SUGRA (in ISAJET) to perform RGE evolution.
46944 C...Then converts to Gunion-Haber conventions.
46947 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46949 INTEGER PYK,PYCHGE,PYCOMP
46950 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46951 &KEXCIT=4000000,KDIMEN=5000000)
46955 PARAMETER (DOC='01 May 2006')
46957 C...ISASUGRA Input:
46958 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
46959 C...XISAIN contains the MSSMi inputs in natural order.
46960 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
46962 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
46964 C...ISASUGRA Output
46965 CHARACTER*40 ISAVER,VISAJE
46967 COMMON /SSPAR/ SUPER(72)
46968 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
46969 $FBGUT,FTAGUT,FNGUT
46970 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
46971 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46972 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46973 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
46974 $VUMT,VDMT,ASMTP,ASMSS,M3Q
46975 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46976 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46977 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
46978 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
46980 SAVE /SUGMG/,/SSPAR/
46981 C SUPER: Filled by ISASUGRA.
46982 C SUPER(1) = mass of ~g
46983 C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
46984 C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
46985 C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
46987 C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
46988 C SUPER(29) = Higgsino mass = - mu
46989 C SUPER(30) = ratio v2/v1 of vev's
46990 C SUPER(31:34) = Signed neutralino masses
46991 C SUPER(35:50) = Neutralino mixing matrix
46992 C SUPER(51:52) = Signed chargino masses
46993 C SUPER(53:54) = Chargino left, right mixing angles
46994 C SUPER(55:58) = mass of h0, H0, A0, H+
46995 C SUPER(59) = Higgs mixing angle alpha
46996 C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
46997 C SUPER(66) = Gravitino mass
46998 C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
46999 C SUPER(70) = b-Yukawa at mA scale (not used)
47000 C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
47001 C GSS: Filled by ISASUGRA
47002 C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
47003 C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
47004 C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
47005 C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
47006 C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
47007 C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
47008 C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
47009 C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
47010 C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
47011 C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
47012 C GSS(31) = log(vuq)
47013 C MSS: Filled by ISASUGRA
47014 C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
47015 C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
47016 C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
47017 C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
47018 C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
47019 C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
47020 C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
47021 C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
47022 C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
47023 C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
47024 C MSS(31) = ha0 MSS(32) = h+
47025 C Unification, filled by ISASUGRA if applicable.
47026 C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
47028 C...SPYTHIA Input/Output
47030 DOUBLE PRECISION RMSS
47031 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47032 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47033 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47034 C...SLHA Input/Output
47035 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47036 & AU(3,3),AD(3,3),AE(3,3)
47037 C...PYTHIA common blocks
47038 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47039 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47040 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47042 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
47043 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47046 CHARACTER*20 CHMOD(5)
47049 COMMON /SUGNU/ XNUSUG(18)
47053 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
47054 & 'truly unified SUGRA', 'non-minimal GMSB'/
47056 C...Start by checking for incompatibilities/inconsistencies:
47058 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
47059 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
47060 & ,' option not used by PYSUGI'
47063 C...ISAJET works with REAL numbers.
47064 MZERO=REAL(RMSS(8))
47066 AZERO=REAL(RMSS(16))
47068 SGNMU=REAL(RMSS(4))
47069 MTOP=REAL(PMAS(6,1))
47071 IF (IMSS(1).EQ.12) THEN
47074 ELSEIF(IMSS(1).EQ.13) THEN
47075 C...Read from isajet par file in IMSS(20)
47077 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
47079 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
47082 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
47083 CMrenna change to allow any susy model
47084 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
47085 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
47086 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
47087 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
47088 & ' gauge couplings:'
47089 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
47091 IF (IMODEL.EQ.4) THEN
47095 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
47096 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
47097 & //' sgn(mu), M_t:'
47098 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
47099 IF (IMODEL.EQ.3) THEN
47101 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
47102 & //' 0 to continue:'
47103 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
47104 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
47105 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
47106 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
47107 & //' generation masses'
47109 & ' NUSUG5 = GUT scale 3rd generation masses'
47111 IF (INUSUG.EQ.0) THEN
47113 ELSEIF (INUSUG.EQ.1) THEN
47114 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
47115 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
47116 IF (XNUSUG(3).LE.0.) THEN
47117 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
47120 ELSEIF (INUSUG.EQ.2) THEN
47121 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
47122 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
47123 ELSEIF (INUSUG.EQ.3) THEN
47124 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
47125 READ(LFN,*) XNUSUG(7),XNUSUG(8)
47126 ELSEIF (INUSUG.EQ.4) THEN
47127 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
47128 & //' M(ur), M(el), M(er):'
47129 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
47130 & XNUSUG(10),XNUSUG(9)
47131 ELSEIF (INUSUG.EQ.5) THEN
47132 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
47133 & //' M(Ll), M(Lr):'
47134 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
47135 & XNUSUG(15),XNUSUG(14)
47139 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
47141 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
47142 & ,' sgn(mu), M_t, C_gv:'
47143 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
47146 C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
47148 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
47149 IF (IMODEL.EQ.5) THEN
47151 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
47152 & ,' masses at M_mes'
47153 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
47154 & ,' shifts at M_mes'
47155 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
47157 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
47159 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
47161 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
47162 $ XGMIN(13),XGMIN(14)
47165 WRITE(MSTU(11),*) 'Invalid model choice.'
47173 C TANB=REAL(RMSS(5))
47174 C SGNMU=REAL(RMSS(4))
47177 C...Initialize MSSM parameter array
47178 130 DO 140 IPAR=1,72
47182 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
47183 C...Check whether ISASUSY thought the model was OK.
47184 IF (NOGOOD.NE.0) THEN
47185 IF (NOGOOD.EQ.1) CALL PYERRM(26
47186 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
47187 IF (NOGOOD.EQ.2) CALL PYERRM(26
47188 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
47189 IF (NOGOOD.EQ.3) CALL PYERRM(26
47190 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
47191 IF (NOGOOD.EQ.4) CALL PYERRM(26
47192 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
47193 IF (NOGOOD.EQ.7) CALL PYERRM(26
47194 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
47195 IF (NOGOOD.EQ.8) CALL PYERRM(26
47196 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
47197 C...Give warning, but don't stop, if LSP not ~chi_10.
47198 IF (NOGOOD.EQ.5) CALL PYERRM(16
47199 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
47201 C...Warn about possible GUT scale tachyons.
47202 IF (ITACHY.NE.0) CALL PYERRM(16,
47203 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
47204 C...Finalize spectrum (last iteration)
47205 C...(Thanks to A. Raklev for pointing this out.)
47206 C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
47207 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
47208 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
47209 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
47210 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
47211 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
47215 RMSS(1)=dble(GSS(7))
47216 RMSS(2)=dble(GSS(8))
47217 RMSS(3)=dble(GSS(9))
47218 RMSOFT(1)=dble(GSS(7))
47219 RMSOFT(2)=dble(GSS(8))
47220 RMSOFT(3)=dble(GSS(9))
47221 C...Mu = - Higgsino mass.
47224 C...Slepton and squark masses. 2 first generations.
47225 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
47226 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
47227 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
47228 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
47229 C...Third generation.
47230 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
47235 C...SLHA: store exact soft spectrum in RMSOFT
47236 RMSOFT(31)=SUPER(18)
47237 RMSOFT(32)=SUPER(20)
47238 RMSOFT(33)=SUPER(22)
47239 RMSOFT(34)=SUPER(19)
47240 RMSOFT(35)=SUPER(21)
47241 RMSOFT(36)=SUPER(23)
47242 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
47243 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
47244 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
47245 RMSOFT(44)=SUPER(3)
47246 RMSOFT(45)=SUPER(9)
47247 RMSOFT(46)=SUPER(15)
47248 RMSOFT(47)=SUPER(5)
47249 RMSOFT(48)=SUPER(7)
47250 RMSOFT(49)=SUPER(11)
47252 C...~b, ~t, and ~tau trilinear couplings and mixing angles.
47259 C...SLHA trilinears
47270 C...Higgs mixing angle alpha (Gunion-Haber convention).
47271 RMSS(18)=-SUPER(59)
47274 C...GUT scale coupling
47276 C...Gravitino mass (for future compatibility)
47277 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
47279 C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
47281 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
47282 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
47283 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
47284 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
47286 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
47287 C...Squarks and Sleptons.
47290 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
47291 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
47292 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
47293 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
47294 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
47295 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
47296 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
47297 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
47298 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
47300 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
47301 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
47302 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
47304 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
47305 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
47306 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
47307 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
47308 C...Signed masses (extra minus from going to G-H convention).
47314 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
47315 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
47316 C...Signed masses (extra minus from going to G-H convention).
47320 C... Neutralino Mixing.
47322 ZMIX(IN,1)= SUPER(38+4*(IN-1))
47323 ZMIX(IN,2)= SUPER(37+4*(IN-1))
47324 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
47325 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
47327 C...Chargino Mixing (PYTHIA same angle as HERWIG).
47330 IF (SUPER(53).GT.0) THX=-1D0
47331 IF (SUPER(54).GT.0) THY=-1D0
47332 UMIX(1,1) = -SIN(SUPER(53))
47333 UMIX(1,2) = -COS(SUPER(53))
47334 UMIX(2,1) = -THX*COS(SUPER(53))
47335 UMIX(2,2) = THX*SIN(SUPER(53))
47336 VMIX(1,1) = -SIN(SUPER(54))
47337 VMIX(1,2) = -COS(SUPER(54))
47338 VMIX(2,1) = -THY*COS(SUPER(54))
47339 VMIX(2,2) = THY*SIN(SUPER(54))
47340 C...Sfermion mixing (PYTHIA same angle as ISAJET)
47341 SFMIX(5,1)=COS(SUPER(63))
47342 SFMIX(5,2)=SIN(SUPER(63))
47343 SFMIX(5,3)=-SIN(SUPER(63))
47344 SFMIX(5,4)=COS(SUPER(63))
47345 SFMIX(6,1)=COS(SUPER(61))
47346 SFMIX(6,2)=SIN(SUPER(61))
47347 SFMIX(6,3)=-SIN(SUPER(61))
47348 SFMIX(6,4)=COS(SUPER(61))
47349 SFMIX(15,1)=COS(SUPER(65))
47350 SFMIX(15,2)=SIN(SUPER(65))
47351 SFMIX(15,3)=-SIN(SUPER(65))
47352 SFMIX(15,4)=COS(SUPER(65))
47354 IF (MSTP(122).NE.0) THEN
47355 C...Print a few lines to make the user know what's happening
47357 WRITE(MSTU(11),5000) DOC, ISAVER
47358 WRITE(MSTU(11),5100)
47359 IF (IMODEL.EQ.1) THEN
47360 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
47362 WRITE(MSTU(11),5300)
47364 WRITE(MSTU(11),5500) 'Pole masses'
47365 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
47366 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
47367 & ,(SUPER(IP),IP=19,25,2)
47368 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
47370 WRITE(MSTU(11),5400)
47371 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
47372 WRITE(MSTU(11),5400)
47373 WRITE(MSTU(11),5500) 'EW scale mixing structure'
47374 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
47375 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
47376 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
47377 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
47378 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
47379 & ),(SFMIX(15,J),J=3,4)
47380 WRITE(MSTU(11),5400)
47381 WRITE(MSTU(11),6450) RMSS(18)
47382 WRITE(MSTU(11),5400)
47383 WRITE(MSTU(11),5500) 'Couplings'
47384 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
47385 WRITE(MSTU(11),5400)
47388 C...Call FeynHiggs to improve Higgs sector if requested
47389 IF (IMSS(4).EQ.3) THEN
47390 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
47391 & ' (PYSUGI:) Now calling FeynHiggs.'
47393 IF (IERR.EQ.0) THEN
47395 IF (MSTP(122).NE.0) THEN
47396 WRITE(MSTU(11),5400)
47397 WRITE(MSTU(11),5500)
47398 & 'Corrected Higgs masses and mixing'
47399 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
47401 WRITE(MSTU(11),6450) RMSS(18)
47402 WRITE(MSTU(11),5400)
47407 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
47409 C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
47410 C...output by ISASUSY.
47411 IMSS(4)=MAX(2,IMSS(4))
47413 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
47414 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
47415 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
47416 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
47417 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
47418 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
47419 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
47420 & ,'----------------')
47421 5400 FORMAT(1x,'*',1x,A)
47422 5500 FORMAT(1x,'*',1x,A,':')
47423 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
47424 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
47425 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
47426 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
47427 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
47429 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
47430 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
47431 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
47433 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
47434 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
47435 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
47436 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47437 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
47438 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47439 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
47440 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
47441 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
47442 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
47443 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
47444 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
47445 & ,1x,F6.3,1x),'|')
47446 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
47447 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
47448 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
47449 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
47450 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
47451 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
47452 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
47453 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
47454 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
47455 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
47456 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
47457 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
47458 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
47459 & ,4x,'Alpha_GUT = ',F8.2)
47460 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
47461 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
47466 C*********************************************************************
47469 C...Interface to FeynHiggs for MSSM Higgs sector.
47470 C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
47473 SUBROUTINE PYFEYN(IERR)
47475 C...Double precision and integer declarations.
47476 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47477 IMPLICIT INTEGER(I-N)
47478 INTEGER PYK,PYCHGE,PYCOMP
47480 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47481 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47483 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47484 C...FeynHiggs variables
47485 DOUBLE PRECISION RMHIGG(4)
47486 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
47487 DOUBLE COMPLEX DMU,
47488 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47490 C...SLHA Common Block
47491 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47492 & AU(3,3),AD(3,3),AE(3,3)
47493 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
47496 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
47497 IF (IERR.NE.0) THEN
47498 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
47499 & //'Will not use FeynHiggs for this run.')
47537 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
47538 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
47539 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
47540 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
47541 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47542 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
47543 IF (IERR.NE.0) THEN
47544 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
47545 & //' Will not use FeynHiggs for this run.')
47548 C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
47550 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
47551 IF (IERR.NE.0) THEN
47552 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
47553 & 'GSCORR. Will not use FeynHiggs for this run.')
47556 ALPHA = ASIN(DBLE(SAEFF))
47558 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
47559 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
47560 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
47561 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
47563 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
47564 & 1.15D0*PMAS(25,1)) THEN
47565 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
47566 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
47567 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
47570 PMAS(25,1)=RMHIGG(1)
47571 PMAS(35,1)=RMHIGG(2)
47572 PMAS(36,1)=RMHIGG(3)
47573 PMAS(37,1)=RMHIGG(4)
47578 C*********************************************************************
47581 C...Determines the running mass of Squarks.
47583 FUNCTION PYRNMQ(ID,DTERM)
47585 C...Double precision and integer declarations.
47586 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47587 IMPLICIT INTEGER(I-N)
47588 INTEGER PYK,PYCHGE,PYCOMP
47590 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47593 C...Local variables.
47594 DOUBLE PRECISION PI,R
47595 DOUBLE PRECISION TOL
47596 DOUBLE PRECISION CI(3)
47598 DOUBLE PRECISION PYALPS
47600 DATA PI,R/3.141592654D0,.61803399D0/
47601 DATA CI/0.47D0,0.07D0,0.02D0/
47605 AG=(0.71D0)**2/4D0/PI
47612 AS=PYALPS(XM02+6D0*XMG2)
47613 CG=8D0/9D0*((AS/AG)**2-1D0)
47614 BX=XM02+(CA+CG)*XMG2+DTERM
47615 AX=MIN(50D0**2,0.5D0*BX)
47616 CX=MAX(2000D0**2,2D0*BX)
47620 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
47628 CG=8D0/9D0*((AS1/AG)**2-1D0)
47629 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
47631 CG=8D0/9D0*((AS2/AG)**2-1D0)
47632 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
47633 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
47640 CG=8D0/9D0*((AS2/AG)**2-1D0)
47641 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
47648 CG=8D0/9D0*((AS1/AG)**2-1D0)
47649 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
47664 C*********************************************************************
47667 C...Calculates the mass eigenstates of the third generation sfermions.
47668 C...Created: 5-31-96
47672 C...Double precision and integer declarations.
47673 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47674 IMPLICIT INTEGER(I-N)
47675 INTEGER PYK,PYCHGE,PYCOMP
47676 C...Parameter statement to help give large particle numbers.
47677 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47678 &KEXCIT=4000000,KDIMEN=5000000)
47680 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47681 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47682 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47683 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47684 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47685 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47687 C...Local variables.
47688 DOUBLE PRECISION BETA
47689 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
47690 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
47691 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
47692 DOUBLE PRECISION ATR,AMQR,AMQL
47693 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
47694 INTEGER IF,I,J,II,JJ,IT,L
47708 COS2B=COS(2D0*BETA)
47710 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
47720 XMQL2=CTT2*XM12+STT2*XM22
47721 XMQR2=STT2*XM12+CTT2*XM22
47722 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
47723 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47725 C......SUBTRACT OUT D-TERM AND FERMION MASS
47726 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
47727 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
47728 IF(XMQL2.GE.0D0) THEN
47729 RMSS(10)=SQRT(XMQL2)
47731 RMSS(10)=-SQRT(-XMQL2)
47733 IF(XMQR2.GE.0D0) THEN
47734 RMSS(12)=SQRT(XMQR2)
47736 RMSS(12)=-SQRT(-XMQR2)
47739 C SAME FOR BOTTOM SQUARK
47745 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
47746 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
47747 IF(ABS(CTT).GE..9999D0) THEN
47750 ELSEIF(ABS(CTT).LE.1D-4) THEN
47754 XM12=(XMQL2-STT2*XM22)/CTT2
47755 XMQR2=STT2*XM12+CTT2*XM22
47756 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47759 C......SUBTRACT OUT D-TERM AND FERMION MASS
47760 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
47761 IF(XMQR2.GE.0D0) THEN
47762 RMSS(11)=SQRT(XMQR2)
47764 RMSS(11)=-SQRT(-XMQR2)
47766 C SAME FOR TAU SLEPTON
47773 XMQL2=CTT2*XM12+STT2*XM22
47774 XMQR2=STT2*XM12+CTT2*XM22
47777 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47779 C......SUBTRACT OUT D-TERM AND FERMION MASS
47780 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
47781 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
47782 IF(XMQL2.GE.0D0) THEN
47783 RMSS(13)=SQRT(XMQL2)
47785 RMSS(13)=-SQRT(-XMQL2)
47787 IF(XMQR2.GE.0D0) THEN
47788 RMSS(14)=SQRT(XMQR2)
47790 RMSS(14)=-SQRT(-XMQR2)
47795 IF(AMQL.LT.0D0) THEN
47802 IF(AMQR.LT.0D0) THEN
47808 XMF=PYMRUN(IF,PMAS(6,1)**2)
47810 AM2(1,1)=XMQL2+XMF2
47811 AM2(2,2)=XMQR2+XMF2
47812 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
47815 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
47816 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
47817 AM2(1,2)=XMF*(ATR+XMU*TANB)
47818 ELSEIF(L.EQ.2) THEN
47819 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
47820 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
47821 AM2(1,2)=XMF*(ATR+XMU/TANB)
47822 ELSEIF(L.EQ.3) THEN
47823 IF(IMSS(8).EQ.1) THEN
47824 AM2(1,1)=RMSS(6)**2
47825 AM2(2,2)=RMSS(7)**2
47830 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
47831 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
47832 AM2(1,2)=XMF*(ATR+XMU*TANB)
47837 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
47838 IF(DETM.LT.0D0) THEN
47839 WRITE(MSTU(11),*) ID2(L),DETM,AM2
47840 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
47842 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
47843 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
47847 IF(XMF22-XMF12.GT.0D0) THEN
47848 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
47850 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
47851 & AM2(1,2)/(XMF22-XMF12))
47867 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
47873 IF(DI(1,1).GT.DI(2,2)) THEN
47874 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
47875 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
47876 WRITE(MSTU(11),*) AM2
47877 WRITE(MSTU(11),*) DI
47878 WRITE(MSTU(11),*) RT
47889 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
47890 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
47891 & ' OFF DIAGONAL ELEMENTS '
47892 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
47893 WRITE(MSTU(11),*) DI
47894 WRITE(MSTU(11),*) ' ROTATION = ',RT
47896 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
47897 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
47898 & ' NEGATIVE MASSES '
47901 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
47902 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
47903 SFMIX(IF,1)=RT(1,1)
47904 SFMIX(IF,2)=RT(1,2)
47905 SFMIX(IF,3)=RT(2,1)
47906 SFMIX(IF,4)=RT(2,2)
47909 C.....TAU SNEUTRINO MASS...L=3
47911 XARG=AM2(1,1)+XMW2*COS2B
47912 IF(XARG.LT.0D0) THEN
47913 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
47914 & ' FROM THE SUM RULE. '
47915 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
47918 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
47923 C*********************************************************************
47926 C...Finds the mass eigenstates and mixing matrices for neutralinos
47931 C...Double precision and integer declarations.
47932 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47933 IMPLICIT INTEGER(I-N)
47935 C...Parameter statement to help give large particle numbers.
47936 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47937 &KEXCIT=4000000,KDIMEN=5000000)
47939 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47940 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47941 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47942 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47943 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47944 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47946 C...Local variables.
47947 DOUBLE PRECISION XMW,XMZ,XM(4)
47948 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
47949 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
47950 DOUBLE PRECISION COSW,SINW
47951 DOUBLE PRECISION XMU
47952 DOUBLE PRECISION TANB,COSB,SINB
47953 DOUBLE PRECISION XM1,XM2,XM3,BETA
47954 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
47955 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
47956 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
47957 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
47958 DOUBLE PRECISION PYALPS,PYALEM
47959 DOUBLE PRECISION PYRNM3
47960 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
47961 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
47962 DATA KFNCHI/1000022,1000023,1000025,1000035/
47965 IF(IMSS(1).EQ.2) THEN
47968 C...M1, M2, AND M3 ARE INDEPENDENT
47973 ELSEIF(IOPT.GE.1) THEN
47977 A1=AEM/(1D0-PARU(102))
47980 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
47982 XM2=XM1*A2/A1*3D0/5D0
47984 ELSEIF(IOPT.EQ.3) THEN
47985 XM1=XM2*5D0/3D0*A1/A2
47990 IF(XM3.LE.0D0) THEN
47991 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
47997 IF(IMSS(3).EQ.1) THEN
47998 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
48003 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48004 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
48005 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
48011 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48012 RM2=PMAS(I,1)**2/XM3**2
48013 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
48014 IF(ARG.GE.0D0) THEN
48015 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
48017 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
48022 ELSEIF(X0.EQ.0D0) THEN
48026 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
48027 & 0.5D0*X0**2*LOG(AX0)
48028 BT=(-1D0-2D0*X0)/4D0
48033 ELSEIF(X1.EQ.0D0) THEN
48037 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
48038 & X1**2*LOG(AX1)+AT
48039 BT=(-1D0-2D0*X1)/4D0+BT
48043 X0=0.5D0*(1D0+RM2-RM1)
48044 Y0=-0.5D0*SQRT(-ARG)
48045 AMGX0=SQRT(X0**2+Y0**2)
48046 AM1X0=SQRT((1D0-X0)**2+Y0**2)
48047 ARGX0=ATAN2(-X0,-Y0)
48048 AR1X0=ATAN2(1D0-X0,Y0)
48053 ARGX1=ATAN2(-X1,-Y1)
48054 AR1X1=ATAN2(1D0-X1,Y1)
48055 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
48056 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
48057 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
48058 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
48059 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
48060 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
48065 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
48066 & /(2D0*PARU(2))*(15D0+AQ))
48069 C...NEUTRALINO MASSES
48075 XMZ=PMAS(23,1)/100D0
48076 XMW=PMAS(24,1)/100D0
48078 SINW=SQRT(PARU(102))
48079 COSW=SQRT(1D0-PARU(102))
48090 C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
48091 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
48092 AR(1,1) = XM1*COS(RMSS(30))
48093 AI(1,1) = XM1*SIN(RMSS(30))
48094 AR(2,2) = XM2*COS(RMSS(31))
48095 AI(2,2) = XM2*SIN(RMSS(31))
48100 AR(1,3) = -XMZ*SINW*COSB
48102 AR(1,4) = XMZ*SINW*SINB
48104 AR(2,3) = XMZ*COSW*COSB
48106 AR(2,4) = -XMZ*COSW*SINB
48108 AR(3,4) = -XMU*COS(RMSS(33))
48109 AI(3,4) = -XMU*SIN(RMSS(33))
48110 AR(4,3) = -XMU*COS(RMSS(33))
48111 AI(4,3) = -XMU*SIN(RMSS(33))
48112 C CALL PYEIG4(AR,WR,ZR)
48113 CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48114 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48115 & 'PROBLEM WITH PYEICG IN PYINOM ')
48123 IF(XM(K).LT.XM(J)) THEN
48141 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
48144 S=S+ZR(J,K)**2+ZI(J,K)**2
48147 ZMIX(I,J)=ZR(J,K)/SQRT(S)
48148 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
48149 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
48150 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
48154 C...CHARGINO MASSES
48155 C.....Find eigenvectors of X X^*
48164 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
48165 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
48166 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48167 &XMU*COS(RMSS(33))*SINB)
48168 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
48169 &XMU*SIN(RMSS(33))*SINB)
48170 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48171 &XMU*COS(RMSS(33))*SINB)
48172 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
48173 &XMU*SIN(RMSS(33))*SINB)
48174 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48175 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48176 & 'PROBLEM WITH PYEICG IN PYINOM ')
48179 IF(WR(2).LT.WR(1)) THEN
48187 SMW(I)=SQRT(WR(K))*100D0
48190 S=S+ZR(J,K)**2+ZI(J,K)**2
48193 UMIX(I,J)=ZR(J,K)/SQRT(S)
48194 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
48195 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
48196 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
48199 C...Force chargino mass > neutralino mass
48201 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
48202 CALL PYERRM(8,'(PYINOM:) '//
48203 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
48204 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
48207 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
48208 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
48210 C.....Find eigenvectors of X^* X
48221 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
48222 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
48223 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
48224 &XMU*COS(RMSS(33))*COSB)
48225 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
48226 &XMU*SIN(RMSS(33))*COSB)
48227 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
48228 &XMU*COS(RMSS(33))*COSB)
48229 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
48230 &XMU*SIN(RMSS(33))*COSB)
48231 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48232 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48233 & 'PROBLEM WITH PYEICG IN PYINOM ')
48236 IF(WR(2).LT.WR(1)) THEN
48246 S=S+ZR(J,K)**2+ZI(J,K)**2
48247 SIMAG=SIMAG+ZI(J,K)**2
48250 VMIX(I,J)=ZR(J,K)/SQRT(S)
48251 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
48252 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
48253 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
48257 C.....Simplify if no phases
48258 IF(SIMAG.LT.1D-6) THEN
48259 AR(1,1) = XM2*COS(RMSS(31))
48260 AR(2,2) = XMU*COS(RMSS(33))
48261 AR(1,2) = SQRT(2D0)*XMW*SINB
48262 AR(2,1) = SQRT(2D0)*XMW*COSB
48275 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
48280 VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
48281 VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
48282 VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
48283 VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
48284 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
48285 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
48286 ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
48290 C.....Must deal with phases
48292 CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
48293 CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
48294 CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
48295 CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
48301 CAI(I,J)=CMPLX(0D0,0D0)
48309 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
48310 & CMPLX(VMIX(J,L),VMIXI(J,L))
48316 CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
48317 CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
48320 VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
48321 VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
48324 VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
48325 VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
48328 VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
48329 VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
48332 VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
48333 VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
48334 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
48335 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
48336 ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
48337 & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
48345 C*********************************************************************
48348 C...Calculates the running of M3, the SU(3) gluino mass parameter.
48350 FUNCTION PYRNM3(RGUT)
48352 C...Double precision and integer declarations.
48353 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48354 IMPLICIT INTEGER(I-N)
48355 INTEGER PYK,PYCHGE,PYCOMP
48357 C...Local variables.
48359 DOUBLE PRECISION TOL
48361 DOUBLE PRECISION PYALPS
48363 DATA R/0.61803399D0/
48367 BX=RGUT*PYALPS(RGUT**2)
48368 AX=MIN(50D0,BX*0.5D0)
48369 CX=MAX(2000D0,2D0*BX)
48373 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
48381 F1=ABS(X1-RGUT*AS1)
48383 F2=ABS(X2-RGUT*AS2)
48384 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
48391 F2=ABS(X2-RGUT*AS2)
48398 F1=ABS(X1-RGUT*AS1)
48413 C*********************************************************************
48416 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
48417 C...Specific application: mixing in neutralino sector.
48419 SUBROUTINE PYEIG4(A,W,Z)
48421 C...Double precision and integer declarations.
48422 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48423 IMPLICIT INTEGER(I-N)
48424 INTEGER PYK,PYCHGE,PYCOMP
48426 C...Arrays: in call and local.
48427 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
48429 C...Coefficients of fourth-degree equation from matrix.
48430 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
48431 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
48435 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
48444 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
48445 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
48446 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
48447 B0=B0+(-1D0)**(I+1)*A(1,I)*(
48448 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
48449 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
48450 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
48453 C...Coefficients of third-degree equation needed for
48454 C...separation into two second-degree equations.
48455 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
48458 C0=-B1**2-B0*B3**2+4D0*B0*B2
48459 CQ=C1/3D0-C2**2/9D0
48460 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
48463 C...Cases with one or three real roots.
48464 IF(CQR.GE.0D0) THEN
48465 S1=(CR+SQRT(CQR))**(1D0/3D0)
48466 S2=(CR-SQRT(CQR))**(1D0/3D0)
48470 THE=ACOS(CR/SABS**3)/3D0
48475 C...Find and solve two second-degree equations.
48476 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
48477 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
48478 Q1=U/2D0+SQRT(U**2/4D0-B0)
48479 Q2=U/2D0-SQRT(U**2/4D0-B0)
48480 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
48485 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
48486 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
48487 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
48488 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
48490 C...Order eigenvalues in asceding mass.
48493 DO 130 I2=I1-1,1,-1
48494 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
48500 C...Find equation system for eigenvectors.
48503 D(J1,J1)=A(J1,J1)-W(I)
48510 C...Find largest element in matrix.
48514 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
48517 DAMAX=ABS(D(J1,J2))
48521 C...Subtract others by multiple of row selected above.
48523 DO 210 J3=JA+1,JA+3
48525 RL=D(J1,JB)/D(JA,JB)
48527 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
48528 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
48531 DAMAX=ABS(D(J1,J2))
48535 C...Do one more subtraction of a row.
48537 DO 230 J3=JC+1,JC+3
48539 IF(J1.EQ.JA) GOTO 230
48540 RL=D(J1,JD)/D(JC,JD)
48542 IF(J2.EQ.JB) GOTO 220
48543 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
48544 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
48546 DAMAX=ABS(D(J1,J2))
48550 C...Construct unnormalized eigenvector.
48552 JF2=JD+2-4*((JD+1)/4)
48553 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
48554 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
48557 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
48558 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
48561 C...Normalize and fill in final array.
48562 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
48563 SGN=(-1D0)**INT(PYR(0)+0.5D0)
48572 C*********************************************************************
48575 C...Determines the Higgs boson mass spectrum using several inputs.
48577 SUBROUTINE PYHGGM(ALPHA)
48579 C...Double precision and integer declarations.
48580 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48581 IMPLICIT INTEGER(I-N)
48582 INTEGER PYK,PYCHGE,PYCOMP
48583 C...Parameter statement to help give large particle numbers.
48584 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48585 &KEXCIT=4000000,KDIMEN=5000000)
48587 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48588 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48589 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
48590 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48591 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
48593 C...Local variables.
48594 DOUBLE PRECISION AT,AB,XMU,TANB
48595 DOUBLE PRECISION ALPHA
48597 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
48598 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
48599 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
48600 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
48603 IF(IHOPT.EQ.2) THEN
48619 DMC=PMAS(PYCOMP(KSUSY1+37),1)
48626 IF(IHOPT.EQ.0) THEN
48627 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
48628 & DMHCH,DSA,DCA,DTANBA)
48629 ELSEIF(IHOPT.EQ.1) THEN
48630 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
48631 & DMHCH,DSA,DCA,DTANBA)
48632 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
48633 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
48634 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
48640 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
48641 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
48642 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
48643 & PMAS(PYCOMP(1000006),1),DSTOP2
48645 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
48646 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
48647 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
48648 & PMAS(PYCOMP(2000006),1),DSTOP1
48650 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
48651 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
48652 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
48653 & PMAS(PYCOMP(1000005),1),DSBOT2
48655 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
48656 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
48657 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
48658 & PMAS(PYCOMP(2000005),1),DSBOT1
48661 ELSEIF (IHOPT.EQ.3) THEN
48662 c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
48663 C...Currently only available for SLHA spectrum read-in.
48664 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
48665 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
48666 & //' spectrum, change IMSS(1) or IMSS(4) option.')
48682 C*********************************************************************
48685 C...This routine computes the renormalization group improved
48686 C...values of Higgs masses and couplings in the MSSM.
48688 C...Program based on the work by M. Carena, J.R. Espinosa,
48689 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
48691 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
48692 C...All masses in GeV units. MA is the CP-odd Higgs mass,
48693 C...MTOP is the physical top mass, MQ and MUR are the soft
48694 C...supersymmetry breaking mass parameters of left handed
48695 C...and right handed stops respectively, AU and AD are the
48696 C...stop and sbottom trilinear soft breaking terms,
48697 C...respectively, and MU is the supersymmetric
48698 C...Higgs mass parameter. We use the conventions from
48699 C...the physics report of Haber and Kane: left right
48700 C...stop mixing term proportional to (AU - MU/TANB)
48701 C...We use as input TANB defined at the scale MTOP
48703 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
48704 C...where MH and HM are the lightest and heaviest CP-even
48705 C...Higgs masses, MHCH is the charged Higgs mass and
48706 C...ALPHA is the Higgs mixing angle
48707 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
48709 C...Range of validity:
48710 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
48711 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
48712 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
48713 C...are the sbottom mass eigenvalues, respectively. This
48714 C...range automatically excludes the existence of tachyons.
48715 C...For the charged Higgs mass computation, the method is
48717 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
48718 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
48719 C...where M_SUSY**2 is the average of the squared stop mass
48720 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
48721 C...masses have been assumed to be of order of the stop ones
48722 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
48724 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
48725 &XMHCH,SA,CA,TANBA)
48727 C...Double precision and integer declarations.
48728 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48729 IMPLICIT INTEGER(I-N)
48730 INTEGER PYK,PYCHGE,PYCOMP
48731 C...Parameter statement to help give large particle numbers.
48732 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48733 &KEXCIT=4000000,KDIMEN=5000000)
48735 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48736 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48737 COMMON/PYHTRI/HHH(7)
48738 SAVE /PYDAT1/,/PYDAT2/
48740 C...Local variables.
48741 DOUBLE PRECISION PYALEM,PYALPS
48742 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
48743 DOUBLE PRECISION XMHCH,SA,CA
48744 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
48745 DOUBLE PRECISION Q02
48746 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
48747 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
48748 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
48749 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
48750 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
48751 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
48752 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
48753 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
48758 ALP1=AEM/(1D0-PARU(102))
48771 C...MBOTTOM(MTOP) = 3. GEV
48772 XMB = PYMRUN(5,XMTOP**2)
48773 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
48774 &LOG(XMTOP**2/XMZ**2))
48776 C...RMTOP= RUNNING TOP QUARK MASS
48777 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
48778 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
48779 T = LOG(XMS**2/XMTOP**2)
48780 SINB = TANB/((1D0 + TANB**2)**0.5D0)
48782 C...IF(MA.LE.XMTOP) TANBA = TANBT
48784 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
48785 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
48786 &LOG(XMA**2/XMTOP**2))
48788 SINBT = TANBT/SQRT(1D0 + TANBT**2)
48789 COSBT = 1D0/SQRT(1D0 + TANBT**2)
48790 C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
48791 G1 = SQRT(ALP1*4D0*PI)
48792 G2 = SQRT(ALP2*4D0*PI)
48793 G3 = SQRT(ALP3*4D0*PI)
48808 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
48809 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
48810 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
48811 &+ 3D0*(AU + AD)**2/XMS2)/6D0
48812 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
48813 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
48814 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
48815 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
48816 &- 16D0*G3**2) *T/16D0/PI2)
48817 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
48818 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
48819 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
48820 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
48821 &- 16D0*G3**2) *T/16D0/PI2)
48822 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
48823 &(HU2 + HD2)*T/16D0/PI2)
48824 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
48825 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
48826 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
48827 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
48828 &- 16D0*G3**2) *T/16D0/PI2)
48829 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
48830 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
48831 &- 16D0*G3**2) *T/16D0/PI2)
48832 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
48833 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
48834 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
48835 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
48837 &(1+ (6D0*HU2 -2D0* HD2
48838 &- 16D0*G3**2) *T/16D0/PI2)
48839 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
48841 &(1+ (6D0*HD2 -2D0* HU2/2D0
48842 &- 16D0*G3**2) *T/16D0/PI2)
48843 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
48844 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
48845 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
48846 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
48847 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
48848 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48849 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
48850 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48851 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
48852 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48853 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
48854 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48862 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
48863 &2D0* XLAM6*SINBT*COSBT
48864 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
48866 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
48868 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
48869 &2D0* XLAM6* COSBT*SINBT
48870 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48871 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
48872 &((XLAM1* COSBT**2 +2D0*
48873 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
48874 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
48876 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
48877 &+ XLAM4) + XLAM6*COSBT**2
48878 &+ XLAM7* SINBT**2))
48880 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
48881 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
48884 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
48885 XMHCH = SQRT(XMHCH2)
48887 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
48888 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
48889 &XLAM6* COSBT*SINBT
48890 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
48891 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48892 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
48893 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
48895 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
48896 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
48897 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
48898 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
48899 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
48900 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
48901 &XLAM6* COSBT*SINBT
48902 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
48903 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48904 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
48914 C*********************************************************************
48917 C...This subroutine computes the CP-even higgs and CP-odd pole
48918 c...Higgs masses and mixing angles.
48920 C...Program based on the work by M. Carena, M. Quiros
48921 C...and C.E.M. Wagner, "Effective potential methods and
48922 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
48924 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
48926 C...where MCHI is the largest chargino mass, MA is the running
48927 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
48928 C...expectaion values at the scale MTOP, MQ is the third generation
48929 C...left handed squark mass parameter, MUR is the third generation
48930 C...right handed stop mass parameter, MDR is the third generation
48931 C...right handed sbottom mass parameter, MTOP is the pole top quark
48932 C...mass; AT,AB are the soft supersymmetry breaking trilinear
48933 C...couplings of the stop and sbottoms, respectively, and MU is the
48934 C...supersymmetric mass parameter
48936 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
48937 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
48938 C...masses are given, what makes the running of the program
48939 c...much faster and it is quite generally a good approximation
48940 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
48941 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
48942 c...and if IHIGGS=3, then h,H,A polarizations are computed
48944 C...Output: MH and MHP which are the lightest CP-even Higgs running
48945 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
48946 C...Higgs running and pole masses, repectively; SA and CA are the
48947 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
48948 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
48949 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
48950 C...the value of TANB at the CP-odd Higgs mass scale
48952 C...This subroutine makes use of CERN library subroutine
48953 C...integration package, which makes the computation of the
48954 C...pole Higgs masses somewhat faster. We thank P. Janot for this
48955 C...improvement. Those who are not able to call the CERN
48956 C...libraries, please use the subroutine SUBHPOLE2.F, which
48957 C...although somewhat slower, gives identical results
48959 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
48960 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
48962 C...Double precision and integer declarations.
48963 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48964 IMPLICIT INTEGER(I-N)
48967 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48969 INTEGER PYK,PYCHGE,PYCOMP
48971 C...Local variables.
48972 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
48973 &SSBOT2(2),B(2,2),COUPB(2,2),
48974 &HCOUPT(2,2),HCOUPB(2,2),
48975 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
48984 RXMT=PYMRUN(6,XMT**2)
48985 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
48986 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
48988 SINB = TANB/(TANB**2+1D0)**0.5D0
48989 COSB = 1D0/(TANB**2+1D0)**0.5D0
48990 COS2B = SINB**2 - COSB**2
48991 SINBPA = SINB*CA + COSB*SA
48992 COSBPA = COSB*CA - SINB*SA
48993 RMBOT = PYMRUN(5,XMT**2)
48996 IF(XMUR.LT.0D0) XMUR2=-XMUR2
48998 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
48999 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
49000 IF(XMST11.LT.0D0) GOTO 500
49001 IF(XMST22.LT.0D0) GOTO 500
49002 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
49003 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
49004 IF(XMSB11.LT.0D0) GOTO 500
49005 IF(XMSB22.LT.0D0) GOTO 500
49006 C WMST11 = RXMT**2 + XMQ2
49007 C WMST22 = RXMT**2 + XMUR2
49008 XMST12 = RXMT*(AT - XMU/TANB)
49009 XMSB12 = RMBOT*(AB - XMU*TANB)
49011 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49012 C...STOP EIGENVALUES CALCULATION
49013 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49015 STOP12 = 0.5D0*(XMST11+XMST22) +
49016 &0.5D0*((XMST11+XMST22)**2 -
49017 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
49018 STOP22 = 0.5D0*(XMST11+XMST22) -
49019 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
49020 &XMST12**2))**0.5D0
49022 IF(STOP22.LT.0D0) GOTO 500
49025 STOP1 = STOP12**0.5D0
49026 STOP2 = STOP22**0.5D0
49030 IF(XMST12.EQ.0D0) XST11 = 1D0
49031 IF(XMST12.EQ.0D0) XST12 = 0D0
49032 IF(XMST12.EQ.0D0) XST21 = 0D0
49033 IF(XMST12.EQ.0D0) XST22 = 1D0
49035 IF(XMST12.EQ.0D0) GOTO 110
49037 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49038 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49039 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49040 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49047 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
49048 &0.5D0*((XMSB11+XMSB22)**2 -
49049 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
49050 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
49051 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
49052 &XMSB12**2))**0.5D0
49053 IF(SBOT22.LT.0D0) GOTO 500
49054 SBOT1 = SBOT12**0.5D0
49055 SBOT2 = SBOT22**0.5D0
49060 IF(XMSB12.EQ.0D0) XSB11 = 1D0
49061 IF(XMSB12.EQ.0D0) XSB12 = 0D0
49062 IF(XMSB12.EQ.0D0) XSB21 = 0D0
49063 IF(XMSB12.EQ.0D0) XSB22 = 1D0
49065 IF(XMSB12.EQ.0D0) GOTO 130
49067 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49068 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49069 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49070 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49082 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49083 C...STARTING OF LIGHT HIGGS
49084 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49086 IF(IHIGGS.EQ.0) GOTO 490
49091 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
49092 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49093 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
49094 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
49103 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
49104 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49105 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
49106 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
49114 180 ITER = ITER + 1
49117 PR(I3)=PRUN+(I3-2)*EPS/2
49122 POLT = POLT + COUPT(I,J)**2*3D0*
49123 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49130 POLB = POLB + COUPB(I,J)**2*3D0*
49131 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49138 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49140 & (-2D0*XMT**2+0.5D0*P2)*
49141 & PYFINT(P2,XMT2,XMT2)
49143 POL = POLT + POLB + POLTT
49144 POLAR(I3) = P2 - XMH**2 - POL
49146 DERIV = (POLAR(3)-POLAR(1))/EPS
49147 DRUN = - POLAR(2)/DERIV
49150 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
49156 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49157 C...END OF LIGHT HIGGS
49158 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49160 250 IF(IHIGGS.EQ.1) GOTO 490
49162 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49163 C... STARTING OF HEAVY HIGGS
49164 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49169 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
49170 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49171 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
49172 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
49180 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
49181 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49182 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
49183 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
49192 300 ITER = ITER + 1
49194 PR(I3)=PRUN+(I3-2)*EPS/2
49200 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
49201 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49208 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
49209 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49217 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49219 & (-2D0*XMT**2+0.5D0*HP2)*
49220 & PYFINT(HP2,XMT2,XMT2)
49222 HPOL = HPOLT + HPOLB + HPOLTT
49223 POLAR(I3) =HP2-HM**2-HPOL
49225 DERIV = (POLAR(3)-POLAR(1))/EPS
49226 DRUN = - POLAR(2)/DERIV
49229 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
49237 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49238 C... END OF HEAVY HIGGS
49239 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49241 IF(IHIGGS.EQ.2) GOTO 490
49243 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49244 C...BEGINNING OF PSEUDOSCALAR HIGGS
49245 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49250 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
49251 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
49257 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
49258 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
49265 420 ITER = ITER + 1
49267 PR(I3)=PRUN+(I3-2)*EPS/2
49272 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
49273 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49279 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
49280 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49286 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49287 & COSB**2/SINB**2 *
49289 & PYFINT(AP2,XMT2,XMT2)
49290 APOL = APOLT + APOLB + APOLTT
49291 POLAR(I3) = AP2 - XMA**2 -APOL
49293 DERIV = (POLAR(3)-POLAR(1))/EPS
49294 DRUN = - POLAR(2)/DERIV
49297 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
49303 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49304 C...END OF PSEUDOSCALAR HIGGS
49305 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49307 IF(IHIGGS.EQ.3) GOTO 490
49312 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
49313 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
49314 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
49315 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
49319 C*********************************************************************
49322 C...Auxiliary to PYPOLE.
49324 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
49325 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
49326 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
49327 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
49330 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49341 C MBOTTOM(MTOP) = 3. GEV
49342 MB = PYMRUN(5,MTOP**2)
49343 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
49344 *LOG(MTOP**2/MZ**2))
49345 C RMTOP= RUNNING TOP QUARK MASS
49346 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
49347 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
49348 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
49349 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
49350 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49352 C NEW DEFINITION, TGLU.
49354 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49355 TGLU = LOG(MGLU**2/MTOP**2)
49356 SINB = TANB/DSQRT(1D0 + TANB**2)
49359 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
49360 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
49361 *LOG(MA**2/MTOP**2))
49362 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
49363 SINB = TANBT/SQRT(1D0 + TANBT**2)
49364 COSB = 1D0/DSQRT(1D0 + TANBT**2)
49365 G1 = SQRT(ALPHA1*4D0*PI)
49366 G2 = SQRT(ALPHA2*4D0*PI)
49367 G3 = SQRT(ALPHA3*4D0*PI)
49370 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
49371 *SBOT1,SBOT2,DELTAMT,DELTAMB)
49372 IF(MQ.GT.MUR) TP = TQ - TU
49373 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
49374 IF(MQ.GT.MUR) TDP = TU
49375 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
49376 IF(MQ.GT.MD) TPD = TQ - TD
49377 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
49378 IF(MQ.GT.MD) TDPD = TD
49379 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
49381 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
49382 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
49383 * HD**2*(G1**2/3D0+G2**2)*TPD
49385 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
49386 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
49387 * HU**2*(-G1**2/3D0+G2**2)*TP
49389 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49391 C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
49392 C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
49393 C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
49397 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49400 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
49401 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
49402 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
49405 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
49406 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
49409 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
49410 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
49413 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
49414 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
49417 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
49418 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
49421 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
49422 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
49427 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
49428 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
49429 *(G2**2-G1**2/3D0)*TPD
49430 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
49431 *1D0/16D0/PI**2*G1**2*HU**2*TP
49432 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
49433 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
49434 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
49435 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
49437 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
49438 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
49439 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
49440 *+ (3D0*HD**2/2D0 + HU**2/2D0
49441 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
49442 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
49443 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
49444 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
49445 *(TP + TDP)/8D0/PI**2)
49446 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
49447 *+ (3D0*HU**2/2D0 + HD**2/2D0
49448 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
49449 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
49450 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
49451 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
49452 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
49453 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
49454 LAMBDA4 = (- G2**2/2D0)*(1D0
49455 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
49456 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
49462 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
49463 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
49465 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
49466 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
49467 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
49468 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
49471 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49472 CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
49473 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49475 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
49477 IF(MCHI.GT.MSSUSY) GOTO 100
49478 IF(MCHI.LT.MTOP) MCHI=MTOP
49480 TCHAR=LOG(MSSUSY**2/MCHI**2)
49482 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
49483 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
49484 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
49486 DELTAM112=2D0*DELTAL12*V**2*COSB**2
49487 DELTAM222=2D0*DELTAL12*V**2*SINB**2
49488 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
49490 M2(1,1)=M2(1,1)+DELTAM112
49491 M2(2,2)=M2(2,2)+DELTAM222
49492 M2(1,2)=M2(1,2)+DELTAM122
49493 M2(2,1)=M2(2,1)+DELTAM122
49497 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49498 CCC END OF CHARGINOS/NEUTRALINOS
49499 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49503 M2P(I,J) = M2(I,J) + VH(I,J)
49506 TRM2P = M2P(1,1) + M2P(2,2)
49507 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
49508 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
49509 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
49511 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
49513 IF(MH2P.LT.0.) GOTO 130
49515 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
49516 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
49517 IF(COS2ALPHA.GE.0.) THEN
49518 ALPHA = ASIN(SIN2ALPHA)/2D0
49520 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
49524 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49526 C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
49527 C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
49528 C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
49531 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49532 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
49533 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
49538 C*********************************************************************
49541 C...Auxiliary to PYRGHM.
49543 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
49544 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
49545 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
49546 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
49548 INTEGER MSTU,MSTJ,KCHG
49549 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49550 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49551 SAVE /PYDAT1/,/PYDAT2/
49553 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
49555 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
49556 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
49558 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
49563 SINBA = TANBA/DSQRT(TANBA**2+1D0)
49564 COSBA = SINBA/TANBA
49566 SINB = TANB/DSQRT(TANB**2+1D0)
49572 SW = 1D0-MW**2/MZ**2
49575 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
49576 G2 = DSQRT(0.0336D0*4D0*PI)
49577 G1 = DSQRT(0.0101D0*4D0*PI)
49579 IF(MQ.GT.MUR) MST = MQ
49580 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
49582 MSUSYT = DSQRT(MST**2 + MTOP**2)
49584 IF(MQ.GT.MD) MSB = MQ
49585 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
49587 MB = PYMRUN(5,MSB**2)
49588 MSUSYB = DSQRT(MSB**2 + MB**2)
49589 TT = LOG(MSUSYT**2/MTOP**2)
49590 TB = LOG(MSUSYB**2/MTOP**2)
49592 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
49593 HT = RMTOP/(V*SINB)
49596 G32 = ALPHA3*4D0*PI
49597 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
49598 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
49599 AL2 = 3D0/8D0/PI**2*HT**2
49600 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
49601 C ALST = 3./8./PI**2*HTST**2
49602 AL1 = 3D0/8D0/PI**2*HB**2
49605 AL(1,2) = (AL2+AL1)/2D0
49606 AL(2,1) = (AL2+AL1)/2D0
49609 IF(MA.GT.MTOP) THEN
49610 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
49611 * LOG(MTOP**2/MA**2))
49614 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
49615 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
49616 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
49617 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
49622 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
49623 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
49624 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
49625 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
49629 SINBT = TANBST/DSQRT(1D0+TANBST**2)
49632 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
49633 COSBB = SINBB/TANBSB
49638 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
49639 MTOP2 = DSQRT(MTOP4)
49640 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
49641 * /(1D0+DELTAMB)**4
49642 MBOT2 = DSQRT(MBOT4)
49644 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
49645 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49646 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49647 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
49648 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
49649 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49650 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49651 * MQ2 - MUR2)**2*0.25D0
49652 * + MTOP2*(AT-XMU/TANBST)**2)
49653 IF(STOP22.LT.0.) GOTO 120
49654 SBOT12 = (MQ2 + MD2)*.5D0
49655 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49656 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49657 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49658 SBOT22 = (MQ2 + MD2)*.5D0
49659 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49660 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49661 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49662 IF(SBOT22.LT.0.) SBOT22 = 10000D0
49664 STOP1 = DSQRT(STOP12)
49665 STOP2 = DSQRT(STOP22)
49666 SBOT1 = DSQRT(SBOT12)
49667 SBOT2 = DSQRT(SBOT22)
49669 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49671 C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
49672 C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
49673 C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
49674 C INDUCED CORRECTIONS.
49676 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49681 IF(X.EQ.Y) X = X - 0.00001D0
49682 IF(X.EQ.Z) X = X - 0.00002D0
49683 IF(Y.EQ.Z) Y = Y - 0.00003D0
49689 IF(X.EQ.Y) X = X - 0.00001D0
49690 IF(X.EQ.Z) X = X - 0.00002D0
49691 IF(Y.EQ.Z) Y = Y - 0.00003D0
49693 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
49694 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
49698 IF(X.EQ.Y) X = X - 0.00001D0
49699 IF(X.EQ.Z) X = X - 0.00002D0
49700 IF(Y.EQ.Z) Y = Y - 0.00003D0
49702 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
49704 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49706 C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
49707 C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
49708 C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
49709 C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
49710 C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
49711 C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
49712 C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
49713 C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
49714 C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
49715 C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
49716 C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
49719 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49721 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
49722 MTOP2 = DSQRT(MTOP4)
49723 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
49724 * /(1D0+DELTAMB)**4
49725 MBOT2 = DSQRT(MBOT4)
49727 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
49728 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49729 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49730 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
49731 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
49732 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49733 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49734 * MQ2 - MUR2)**2*0.25D0
49735 * + MTOP2*(AT-XMU/TANBST)**2)
49737 IF(STOP22.LT.0.) GOTO 120
49738 SBOT12 = (MQ2 + MD2)*.5D0
49739 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49740 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49741 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49742 SBOT22 = (MQ2 + MD2)*.5D0
49743 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49744 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49745 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49746 IF(SBOT22.LT.0.) GOTO 120
49749 STOP1 = DSQRT(STOP12)
49750 STOP2 = DSQRT(STOP22)
49751 SBOT1 = DSQRT(SBOT12)
49752 SBOT2 = DSQRT(SBOT22)
49754 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49756 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49759 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
49761 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
49762 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
49764 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
49766 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
49767 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
49769 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
49770 * (-.5D0*LOG(STOP12/STOP22)
49771 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
49772 * G(STOP12,STOP22))
49774 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
49775 * (.5D0*LOG(SBOT12/SBOT22)
49776 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
49777 * G(SBOT12,SBOT22))
49779 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
49780 * (MQ2+MBOT2)/(MD2+MBOT2))
49781 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
49782 * LOG(SBOT1**2/SBOT2**2)) +
49783 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
49784 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
49787 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
49788 * -STOP2**2))**2*G(STOP12,STOP22)
49790 VH3B(1,1)=VH3B(1,1)+
49791 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
49793 VH3T(1,1) = VH3T(1,1) +
49794 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
49796 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
49797 * (MQ2+MTOP2)/(MUR2+MTOP2))
49798 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
49799 * LOG(STOP1**2/STOP2**2)) +
49800 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
49801 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
49804 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
49805 * -SBOT2**2))**2*G(SBOT12,SBOT22)
49807 VH3T(2,2)=VH3T(2,2)+
49808 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
49809 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
49811 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
49812 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
49813 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
49816 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
49817 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
49818 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
49821 VH3T(1,2)=VH3T(1,2) +
49822 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
49824 VH3B(1,2)=VH3B(1,2) +
49825 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
49827 VH3T(2,1) = VH3T(1,2)
49828 VH3B(2,1) = VH3B(1,2)
49830 C TQ = LOG((MQ2 + MTOP2)/MTOP2)
49831 C TU = LOG((MUR2+MTOP2)/MTOP2)
49832 C TQD = LOG((MQ2 + MB**2)/MB**2)
49833 C TD = LOG((MD2+MB**2)/MB**2)
49838 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
49839 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
49840 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
49841 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
49860 C*********************************************************************
49863 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
49865 FUNCTION PYFINT(A,B,C)
49867 C...Double precision and integer declarations.
49868 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49869 IMPLICIT INTEGER(I-N)
49870 INTEGER PYK,PYCHGE,PYCOMP
49872 COMMON/PYINTS/XXM(20)
49875 C...Local variables.
49877 DOUBLE PRECISION PYFISB
49884 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
49889 C*********************************************************************
49892 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
49896 C...Double precision and integer declarations.
49897 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49898 IMPLICIT INTEGER(I-N)
49899 INTEGER PYK,PYCHGE,PYCOMP
49901 COMMON/PYINTS/XXM(20)
49904 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
49905 &(X*(XXM(2)-XXM(3))+XXM(3)))
49910 C*********************************************************************
49913 C...Calculates decays of sfermions.
49915 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
49917 C...Double precision and integer declarations.
49918 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49919 IMPLICIT INTEGER(I-N)
49920 INTEGER PYK,PYCHGE,PYCOMP
49921 C...Parameter statement to help give large particle numbers.
49922 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49923 &KEXCIT=4000000,KDIMEN=5000000)
49925 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49926 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49927 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49928 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49929 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49930 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
49932 C...Local variables.
49933 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
49934 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
49936 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
49937 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
49938 DOUBLE PRECISION PYLAMF,XL
49939 DOUBLE PRECISION TANW,XW,AEM,C1,AS
49940 DOUBLE PRECISION AL,AR,BL,BR
49941 DOUBLE PRECISION CH1,CH2,CH3,CH4
49942 DOUBLE PRECISION XMBOT,XMTOP
49943 DOUBLE PRECISION XLAM(0:400)
49944 INTEGER IDLAM(400,3)
49945 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
49946 DOUBLE PRECISION SR2
49947 DOUBLE PRECISION CBETA,SBETA
49948 DOUBLE PRECISION CW
49949 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
49950 DOUBLE PRECISION COSA,SINA,TANB
49951 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
49952 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
49954 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
49955 DATA IGG/23,25,35,36/
49956 DATA PI/3.141592654D0/
49957 DATA SR2/1.4142136D0/
49958 DATA KFNCHI/1000022,1000023,1000025,1000035/
49959 DATA KFCCHI/1000024,1000037/
49961 C...COUNT THE NUMBER OF DECAY MODES
49965 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
49966 &KFIN.EQ.KSUSY2+16) RETURN
49972 TANW = SQRT(XW/(1D0-XW))
49977 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
49982 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
49983 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
49989 C...ILR is 1 for left and 2 for right.
49991 C...IFL is matching non-SUSY flavour.
49992 IFL=MOD(KFIN,KSUSY1)
49993 C...IDU is weak isospin, 1 for down and 2 for up.
50004 XMBOT=PYMRUN(5,XMI2)
50005 XMTOP=PYMRUN(6,XMI2)
50019 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
50021 IF(IMSS(11).EQ.1) THEN
50024 XMGR=PMAS(PYCOMP(IDG),1)
50025 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
50028 ELSEIF(IFL.EQ.6) THEN
50033 IF(XMI.GT.XMGR+XMF) THEN
50038 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
50042 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
50044 C...CHARGED DECAYS:
50046 C...DI -> U CHI1-,CHI2-
50050 C...UI -> D CHI1+,CHI2+
50057 IF(XMI.GE.AXMJ+XMFP) THEN
50064 ELSEIF(IFL.LT.6) THEN
50069 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
50070 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
50076 ELSEIF(IFL.LT.5) THEN
50081 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
50082 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
50086 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50087 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50088 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50089 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50105 XL=PYLAMF(XMI2,XMA2,XMB2)
50106 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50107 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50108 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
50111 IDLAM(LKNT,1)=-KFCCHI(IX)
50112 IDLAM(LKNT,2)=IFL+1
50114 IDLAM(LKNT,1)=KFCCHI(IX)
50115 IDLAM(LKNT,2)=IFL-1
50126 IF(XMI.GE.AXMJ+XMF) THEN
50132 ELSEIF(IFL.LT.5) THEN
50135 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
50136 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
50137 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50142 ELSEIF(IFL.LT.5) THEN
50145 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
50146 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
50147 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50151 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50152 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50153 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50154 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50170 XL=PYLAMF(XMI2,XMA2,XMB2)
50171 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50172 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50173 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
50174 IDLAM(LKNT,1)=KFNCHI(IX)
50180 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
50184 IF(ILR.EQ.1) GOTO 160
50186 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
50187 IF(XMI.LT.XMSF1+XMB) GOTO 160
50189 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
50192 ELSEIF(IG.EQ.25) THEN
50195 ELSEIF(IFL.EQ.6) THEN
50197 ELSEIF(IFL.LT.5) THEN
50203 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
50204 & XMF**2/XMW*COSA/SBETA
50205 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
50206 & XMF**2/XMW*COSA/SBETA
50208 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
50209 & XMF**2/XMW*(-SINA)/CBETA
50210 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
50211 & XMF**2/XMW*(-SINA)/CBETA
50215 ELSEIF(IFL.EQ.6) THEN
50217 ELSEIF(IFL.EQ.15) THEN
50222 C.........need to complexify
50224 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
50227 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
50233 ELSEIF(IG.EQ.35) THEN
50236 ELSEIF(IFL.EQ.6) THEN
50238 ELSEIF(IFL.LT.5) THEN
50244 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
50245 & XMF**2/XMW*SINA/SBETA
50246 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
50247 & XMF**2/XMW*SINA/SBETA
50249 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
50250 & XMF**2/XMW*COSA/CBETA
50251 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
50252 & XMF**2/XMW*COSA/CBETA
50256 ELSEIF(IFL.EQ.6) THEN
50258 ELSEIF(IFL.EQ.15) THEN
50263 C.........Need to complexify
50265 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
50268 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
50274 ELSEIF(IG.EQ.36) THEN
50279 ELSEIF(IFL.EQ.6) THEN
50281 ELSEIF(IFL.LT.5) THEN
50288 ELSEIF(IFL.EQ.6) THEN
50290 ELSEIF(IFL.EQ.15) THEN
50295 C.........Need to complexify
50297 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
50299 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
50305 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
50306 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
50307 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
50308 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50311 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50313 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
50316 IDLAM(LKNT,1)=KFIN-KSUSY1
50322 IF(MOD(IFL,2).EQ.0) THEN
50328 XMSF1=PMAS(PYCOMP(KF1),1)
50329 XMSF2=PMAS(PYCOMP(KF2),1)
50330 IF(XMI.GT.XMB+XMSF1) THEN
50331 IF(MOD(IFL,2).EQ.0) THEN
50333 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
50335 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
50339 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
50341 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
50344 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50346 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50349 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
50351 IF(XMI.GT.XMB+XMSF2) THEN
50352 IF(MOD(IFL,2).EQ.0) THEN
50354 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
50356 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
50360 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
50362 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
50365 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
50367 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50370 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
50375 IF(MOD(IFL,2).EQ.0) THEN
50381 XMSF1=PMAS(PYCOMP(KF1),1)
50382 XMSF2=PMAS(PYCOMP(KF2),1)
50383 IF(XMI.GT.XMB+XMSF1) THEN
50388 IF(MOD(IFL,2).EQ.0) THEN
50391 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
50392 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
50393 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
50394 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
50397 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
50398 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
50399 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
50400 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
50411 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
50412 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
50413 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
50414 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
50417 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
50418 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
50419 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
50420 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
50429 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50431 C.......Need to complexify
50432 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
50433 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
50434 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
50435 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
50438 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
50440 IF(XMI.GT.XMB+XMSF2) THEN
50445 IF(MOD(IFL,2).EQ.0) THEN
50448 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
50449 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
50450 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
50451 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
50454 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
50455 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
50456 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
50457 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
50468 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
50469 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
50470 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
50471 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
50474 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
50475 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
50476 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
50477 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
50486 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50488 C.......Need to complexify
50489 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
50490 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
50491 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
50492 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
50495 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
50498 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
50503 IF(IFL.EQ.6) XMF=PMAS(6,1)
50504 IF(IFL.EQ.5) XMF=PMAS(5,1)
50505 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
50507 IF(XMI.GE.AXMJ+XMF) THEN
50524 XL=PYLAMF(XMI2,XMA2,XMB2)
50525 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50526 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
50527 IDLAM(LKNT,1)=KSUSY1+21
50533 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
50534 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
50535 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
50536 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
50537 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
50538 C...M*M = C1**2 * G**2/(16PI**2)
50539 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
50541 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
50542 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
50543 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
50544 IDLAM(LKNT,1)=KSUSY1+22
50549 C...R-violating sfermion decays (SKANDS).
50550 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
50555 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50556 XLAM(0)=XLAM(0)+XLAM(I)
50558 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
50563 C*********************************************************************
50566 C...Calculates gluino decay modes.
50568 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
50570 C...Double precision and integer declarations.
50571 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50572 IMPLICIT INTEGER(I-N)
50573 INTEGER PYK,PYCHGE,PYCOMP
50574 C...Parameter statement to help give large particle numbers.
50575 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50576 &KEXCIT=4000000,KDIMEN=5000000)
50578 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50579 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50580 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50581 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50582 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50584 C COMMON/PYINTS/XXM(20)
50586 COMMON/PYINTC/XXC(10),CXC(8)
50587 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50589 C...Local variables
50590 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
50591 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
50592 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
50593 DOUBLE PRECISION PYLAMF,XL
50594 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
50595 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
50596 DOUBLE PRECISION XLAM(0:400)
50597 INTEGER IDLAM(400,3)
50598 INTEGER LKNT,IX,ILR,I,IKNT,IFL
50599 DOUBLE PRECISION SR2
50600 DOUBLE PRECISION GAM
50601 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
50602 EXTERNAL PYGAUS,PYXXZ6
50603 DOUBLE PRECISION PYGAUS,PYXXZ6
50604 DOUBLE PRECISION PREC
50605 INTEGER KFNCHI(4),KFCCHI(2)
50606 DATA PI/3.141592654D0/
50607 DATA SR2/1.4142136D0/
50609 DATA KFNCHI/1000022,1000023,1000025,1000035/
50610 DATA KFCCHI/1000024,1000037/
50612 C...COUNT THE NUMBER OF DECAY MODES
50614 IF(KFIN.NE.KSUSY1+21) RETURN
50618 TANW = SQRT(XW/(1D0-XW))
50628 XMI=SIGN(XMI,RMSS(3))
50630 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
50632 IF(IMSS(11).EQ.1) THEN
50635 XMGR=PMAS(PYCOMP(IDG),1)
50636 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
50637 IF(AXMI.GT.XMGR) THEN
50646 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
50650 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
50653 IF(AXMI.GE.AXMJ+XMF) THEN
50654 C...Minus sign difference from gluino-quark-squark feynman rules
50671 XL=PYLAMF(XMI2,XMA2,XMB2)
50672 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
50673 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
50674 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
50678 XLAM(LKNT)=XLAM(LKNT-1)
50679 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50680 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50686 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
50687 C...GLUINO -> NI Q QBAR
50691 IF(AXMI.GE.AXMJ) THEN
50693 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
50695 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
50702 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
50703 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
50709 T3I=SIGN(1D0,EI+1D-6)/2D0
50710 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50711 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50715 CXC(4)=DCONJG(GLIJ)
50719 CXC(8)=-DCONJG(GRIJ)
50721 S12MAX=(AXMI-AXMJ)**2
50722 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
50723 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50725 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
50726 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
50727 IDLAM(LKNT,1)=KFNCHI(IX)
50731 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50733 XLAM(LKNT)=XLAM(LKNT-1)
50734 IDLAM(LKNT,1)=KFNCHI(IX)
50739 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50740 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
50741 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
50743 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
50744 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
50746 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
50749 IDLAM(LKNT,1)=KFNCHI(IX)
50752 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
50757 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
50758 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
50759 C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
50763 T3I=SIGN(1D0,EI+1D-6)/2D0
50764 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50765 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50767 CXC(4)=DCONJG(GLIJ)
50769 CXC(8)=-DCONJG(GRIJ)
50770 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
50771 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50773 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
50774 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
50775 IDLAM(LKNT,1)=KFNCHI(IX)
50779 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50781 XLAM(LKNT)=XLAM(LKNT-1)
50782 IDLAM(LKNT,1)=KFNCHI(IX)
50787 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
50788 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
50790 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
50791 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
50792 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
50794 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
50795 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
50797 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
50800 IDLAM(LKNT,1)=KFNCHI(IX)
50803 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
50809 C...GLUINO -> CI Q QBAR'
50813 IF(AXMI.GE.AXMJ) THEN
50815 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
50816 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
50819 S12MAX=(AXMI-AXMJ)**2
50824 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
50825 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
50828 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
50830 CXC(1)=DCMPLX(0D0,0D0)
50831 CXC(3)=DCMPLX(0D0,0D0)
50832 CXC(5)=DCMPLX(0D0,0D0)
50833 CXC(7)=DCMPLX(0D0,0D0)
50834 CXC(2)=UMIXC(IX,1)*OLPP/SR2
50835 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
50836 CXC(6)=DCMPLX(0D0,0D0)
50837 CXC(8)=DCMPLX(0D0,0D0)
50838 IF(XXC(5).LT.AXMI) THEN
50840 ELSEIF(XXC(6).LT.AXMI) THEN
50845 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
50846 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
50848 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
50849 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50850 IDLAM(LKNT,1)=KFCCHI(IX)
50854 XLAM(LKNT)=XLAM(LKNT-1)
50855 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50856 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50857 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50859 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
50861 XLAM(LKNT)=XLAM(LKNT-1)
50862 IDLAM(LKNT,1)=KFCCHI(IX)
50866 XLAM(LKNT)=XLAM(LKNT-1)
50867 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50868 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50869 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50875 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
50876 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
50877 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
50878 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
50879 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
50880 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
50881 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
50882 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
50883 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
50884 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
50885 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
50886 CALL PYTBBC(IX,100,XMI,GAM)
50889 IDLAM(LKNT,1)=KFCCHI(IX)
50893 XLAM(LKNT)=XLAM(LKNT-1)
50894 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50895 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50896 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50897 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
50898 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
50899 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
50900 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
50906 C...R-parity violating (3-body) decays.
50907 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
50912 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50913 XLAM(0)=XLAM(0)+XLAM(I)
50915 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
50921 C*********************************************************************
50924 C...Calculates the three-body decay of gluinos into
50925 C...neutralinos and third generation fermions.
50927 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
50929 C...Double precision and integer declarations.
50930 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50931 IMPLICIT INTEGER(I-N)
50932 INTEGER PYK,PYCHGE,PYCOMP
50933 C...Parameter statement to help give large particle numbers.
50934 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50935 &KEXCIT=4000000,KDIMEN=5000000)
50937 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50938 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50939 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50940 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50941 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50942 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50944 C...Local variables.
50945 EXTERNAL PYSIMP,PYLAMF
50946 DOUBLE PRECISION PYSIMP,PYLAMF
50948 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
50949 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
50950 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
50951 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
50952 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
50953 DOUBLE PRECISION XLN1,XLN2,B1,B2
50954 DOUBLE PRECISION E,XMGLU,GAM
50955 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
50956 SAVE HRB,HLB,FLB,FRB
50957 DOUBLE PRECISION ALPHAW,ALPHAS
50958 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
50959 SAVE HLT,HRT,FLT,FRT
50960 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
50962 DOUBLE PRECISION AMBOT,SINC,COSC
50963 DOUBLE PRECISION AMTOP,SINA,COSA
50964 DOUBLE PRECISION SINW,COSW,TANW
50965 DOUBLE PRECISION ROT1(4,4)
50968 DATA IFIRST/.TRUE./
50971 SINB=TANB/SQRT(1D0+TANB**2)
50982 AMBOT=PYMRUN(5,XMGLU**2)
50983 AMTOP=PYMRUN(6,XMGLU**2)
50985 FAKT1=AMBOT/W2/AMW/COSB
50986 FAKT2=AMTOP/W2/AMW/SINB
50997 ROT1(2,1)=-ROT1(1,2)
50998 ROT1(2,2)=ROT1(1,1)
51001 ROT1(4,3)=-ROT1(3,4)
51002 ROT1(4,4)=ROT1(3,3)
51006 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
51011 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
51012 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51013 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
51015 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
51016 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
51017 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
51018 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
51021 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
51022 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51023 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
51024 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
51025 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
51026 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
51027 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
51031 C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51032 C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51033 C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51034 C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51038 IF(NINT(3D0*E).EQ.2) THEN
51045 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
51046 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
51055 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
51056 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
51062 SIN2D=SIND*COSD*2D0
51076 ALPHAW=PYALEM(XMG2)
51077 ALPHAS=PYALPS(XMG2)
51081 XM24=(XMG2+XM2)*(XM2+XMR2)
51083 SMAX=(XMG-ABS(XMR))**2
51084 XMQA=XMG2+2D0*XM2+XMR2
51086 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51088 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
51090 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
51091 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
51092 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
51093 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
51094 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
51095 & +2D0*(FF*SIND2-HH*COSD2))*W
51096 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
51097 & +4D0*HFL*XM*XMR)*XLN1
51098 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
51099 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
51100 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
51101 & +8D0*HFL*XMQ4*SIN2D)*B1
51102 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
51103 & +4D0*HFR*XMR*XM)*XLN2
51104 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
51105 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
51106 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
51107 & -8D0*HFR*XMQ4*SIN2D)*B2
51108 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
51109 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
51110 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
51111 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
51112 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
51113 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
51114 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
51115 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
51116 G(5)=(2D0*(HH*COSD2-FF*SIND2)
51117 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
51118 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
51119 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
51120 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
51121 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
51122 & +COS2D*XM*(SBAR+XMG2-XMR2))
51123 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
51124 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
51125 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
51126 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
51127 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
51128 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
51129 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
51132 SUMME(LIN)=SUMME(LIN)+G(J)
51137 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51138 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51143 C*********************************************************************
51146 C...Calculates the three-body decay of gluinos into
51147 C...charginos and third generation fermions.
51149 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
51151 C...Double precision and integer declarations.
51152 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51153 IMPLICIT INTEGER(I-N)
51154 INTEGER PYK,PYCHGE,PYCOMP
51155 C...Parameter statement to help give large particle numbers.
51156 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51157 &KEXCIT=4000000,KDIMEN=5000000)
51159 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51160 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51161 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51162 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51163 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51164 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
51166 C...Local variables.
51167 EXTERNAL PYSIMP,PYLAMF
51168 DOUBLE PRECISION PYSIMP,PYLAMF
51170 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
51171 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
51172 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
51173 DOUBLE PRECISION SUMME(0:100),A(4,8)
51174 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
51175 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
51176 DOUBLE PRECISION XMGLU,GAM
51177 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
51178 &DDD(2),EEE(2),FFF(2)
51179 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
51180 DOUBLE PRECISION ALPHAW,ALPHAS
51181 DOUBLE PRECISION AMC(2)
51183 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
51184 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
51188 DATA IFIRST/.TRUE./
51191 SINB=TANB/SQRT(1D0+TANB**2)
51199 AMBOT=PYMRUN(5,XMGLU**2)
51200 AMTOP=PYMRUN(6,XMGLU**2)
51203 FAKT1=AMBOT/W2/AMW/COSB
51204 FAKT2=AMTOP/W2/AMW/SINB
51209 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
51210 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
51211 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
51212 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
51213 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
51214 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
51215 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
51216 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
51218 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51219 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51220 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51221 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51225 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
51226 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
51227 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
51228 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
51230 COS2A=COSA**2-SINA**2
51231 SIN2A=SINA*COSA*2D0
51232 COS2C=COSC**2-SINC**2
51233 SIN2C=SINC*COSC*2D0
51240 ALPHAW=PYALEM(XMG2)
51241 ALPHAS=PYALPS(XMG2)
51245 XMQ2=XMG2+XMT2+XMB2+XMR2
51246 XMQ4=XMG*XMT*XMB*XMR
51247 XMQ3=XMG2*XMR2+XMT2*XMB2
51248 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
51249 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
51251 XMST(1)=AMST(1)*AMST(1)
51252 XMST(2)=AMST(1)*AMST(1)
51253 XMST(3)=AMST(2)*AMST(2)
51254 XMST(4)=AMST(2)*AMST(2)
51255 XMSB(1)=AMSB(1)*AMSB(1)
51256 XMSB(2)=AMSB(2)*AMSB(2)
51257 XMSB(3)=AMSB(1)*AMSB(1)
51258 XMSB(4)=AMSB(2)*AMSB(2)
51260 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
51261 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
51262 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
51263 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
51264 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
51265 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
51266 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
51267 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
51269 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
51270 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
51271 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
51272 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
51273 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
51274 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
51275 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
51276 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
51278 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
51279 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
51280 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
51281 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
51282 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
51283 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
51284 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
51285 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
51287 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
51288 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
51289 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
51290 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
51291 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
51292 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
51293 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
51294 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
51296 SMAX=(XMG-ABS(XMR))**2
51297 SMIN=(XMB+XMT)**2+0.1D0
51300 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51301 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
51303 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
51304 W=DSQRT(W)/2D0/SBAR
51305 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
51306 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
51307 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
51308 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
51309 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
51310 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
51311 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
51312 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
51313 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
51314 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
51315 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
51316 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
51317 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
51318 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
51319 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
51320 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
51321 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
51322 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
51323 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
51324 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
51325 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
51326 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
51327 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
51328 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
51329 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
51330 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
51331 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
51332 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
51333 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
51334 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
51335 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
51336 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
51337 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
51338 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
51339 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
51340 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
51341 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
51342 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
51343 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
51344 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
51345 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
51346 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
51347 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
51349 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
51350 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
51351 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
51352 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
51353 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
51354 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
51355 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
51356 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
51357 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
51358 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
51359 & -A(J,6)*(XMG2+XMR2-SBAR)
51360 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
51361 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
51362 & /(GRS+XMSB(J)+XMST(J))
51366 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51367 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51372 C*********************************************************************
51375 C...Calculates decay widths for the neutralinos (admixtures of
51376 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
51378 C...Input: KCIN = KF code for particle
51379 C...Output: XLAM = widths
51380 C... IDLAM = KF codes for decay particles
51381 C... IKNT = number of decay channels defined
51382 C...AUTHOR: STEPHEN MRENNA
51384 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
51385 C...when CHIGAMMA .NE. 0
51386 C...10 FEB 96: Calculate this decay for small tan(beta)
51388 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
51390 C...Double precision and integer declarations.
51391 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51392 IMPLICIT INTEGER(I-N)
51393 INTEGER PYK,PYCHGE,PYCOMP
51394 C...Parameter statement to help give large particle numbers.
51395 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51396 &KEXCIT=4000000,KDIMEN=5000000)
51398 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51399 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51400 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51401 c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51403 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51404 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51405 C COMMON/PYINTS/XXM(20)
51407 COMMON/PYINTC/XXC(10),CXC(8)
51408 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51410 C...Local variables.
51411 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
51412 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
51414 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
51415 &XMZ,XMZ2,AXMJ,AXMI
51416 DOUBLE PRECISION S12MIN,S12MAX
51417 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
51418 DOUBLE PRECISION PYLAMF,XL
51419 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
51420 DOUBLE PRECISION PYX2XH,PYX2XG
51421 DOUBLE PRECISION XLAM(0:400)
51422 INTEGER IDLAM(400,3)
51423 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
51424 INTEGER ITH(3),KF1,KF2
51426 DOUBLE PRECISION DH(3),EH(3)
51427 DOUBLE PRECISION SR2
51428 DOUBLE PRECISION CBETA,SBETA
51429 DOUBLE PRECISION GAMCON,XMT1,XMT2
51430 DOUBLE PRECISION PYALEM,PI,PYALPS
51431 DOUBLE PRECISION RAT1,RAT2
51432 DOUBLE PRECISION T3T,FCOL
51433 DOUBLE PRECISION ALFA,BETA,TANB
51434 DOUBLE PRECISION PYXXGA
51435 EXTERNAL PYGAUS,PYXXZ6
51436 DOUBLE PRECISION PYGAUS,PYXXZ6
51437 DOUBLE PRECISION PREC
51438 INTEGER KFNCHI(4),KFCCHI(2)
51442 DATA PI/3.141592654D0/
51443 DATA SR2/1.4142136D0/
51444 DATA KFNCHI/1000022,1000023,1000025,1000035/
51445 DATA KFCCHI/1000024,1000037/
51447 C...COUNT THE NUMBER OF DECAY MODES
51456 TANW = SQRT(XW/XW1)
51458 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
51460 IF(KFIN.EQ.KFNCHI(2)) IX=2
51461 IF(KFIN.EQ.KFNCHI(3)) IX=3
51462 IF(KFIN.EQ.KFNCHI(4)) IX=4
51482 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
51487 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
51488 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
51492 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51493 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
51495 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
51496 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
51500 GAMCON=AEM**3/8D0/PI/XMW2/XW
51501 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
51502 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
51503 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
51504 IDLAM(LKNT,1)=KSUSY1+22
51507 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
51511 C...GRAVITINO DECAY MODES
51513 IF(IMSS(11).EQ.1) THEN
51516 XMGR=PMAS(PYCOMP(IDG),1)
51519 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51520 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
51525 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
51527 IF(AXMI.GT.XMGR+XMZ) THEN
51532 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
51533 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
51534 & (1D0-XMZ2/XMI2)**4
51536 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
51541 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
51542 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
51544 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
51549 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
51550 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
51552 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
51557 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
51558 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
51560 IF(IX.EQ.1) GOTO 300
51568 C...CHI0_I -> CHI0_J + GAMMA
51569 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
51570 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
51571 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
51572 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
51573 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
51574 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
51575 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
51577 IDLAM(LKNT,1)=KFNCHI(IJ)
51580 GAMCON=AEM**3/8D0/PI/XMW2/XW
51581 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
51582 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
51583 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
51587 C...CHI0_I -> CHI0_J + Z0
51588 IF(AXMI.GE.AXMJ+XMZ) THEN
51590 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
51591 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
51593 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51594 GLR=DBLE(OLPP*DCONJG(ORPP))
51595 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
51596 IDLAM(LKNT,1)=KFNCHI(IJ)
51599 ELSEIF(AXMI.GE.AXMJ) THEN
51606 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
51607 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
51609 C...CHARGED LEPTONS
51611 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51612 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51614 T3I=SIGN(1D0,EI+1D-6)/2D0
51615 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51616 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51617 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51618 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51620 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51621 CXC(4)=DCONJG(GLIJ)
51622 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51624 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51625 CXC(8)=-DCONJG(GRIJ)
51627 S12MAX=(AXMI-AXMJ)**2
51628 IF( XXC(5).LT.AXMI ) THEN
51631 IF(XXC(6).LT.AXMI ) THEN
51637 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
51639 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51640 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51641 IDLAM(LKNT,1)=KFNCHI(IJ)
51644 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
51646 XLAM(LKNT)=XLAM(LKNT-1)
51647 IDLAM(LKNT,1)=KFNCHI(IJ)
51653 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51654 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51655 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
51657 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
51658 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51660 IF( XXC(5).LT.AXMI ) THEN
51663 IF(XXC(6).LT.AXMI ) THEN
51669 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
51671 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51672 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51673 IDLAM(LKNT,1)=KFNCHI(IJ)
51681 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51682 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51684 T3I=SIGN(1D0,EI+1D-6)/2D0
51685 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51686 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51687 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51688 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51690 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51691 CXC(4)=DCONJG(GLIJ)
51692 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51694 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51695 CXC(8)=-DCONJG(GRIJ)
51697 S12MAX=(AXMI-AXMJ)**2
51698 IF( XXC(5).LT.AXMI ) THEN
51701 IF( XXC(6).LT.AXMI ) THEN
51708 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51709 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51710 IDLAM(LKNT,1)=KFNCHI(IJ)
51714 XLAM(LKNT)=XLAM(LKNT-1)
51715 IDLAM(LKNT,1)=KFNCHI(IJ)
51720 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
51722 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
51723 IF( XXC(5).LT.AXMI ) THEN
51728 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51729 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51732 XLAM(LKNT)=XLAM(LKNT-1)
51734 IDLAM(LKNT,1)=KFNCHI(IJ)
51740 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51741 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51743 T3I=SIGN(1D0,EI+1D-6)/2D0
51744 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51745 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51746 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51747 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51749 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51750 CXC(4)=DCONJG(GLIJ)
51751 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51753 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51754 CXC(8)=-DCONJG(GRIJ)
51756 S12MAX=(AXMI-AXMJ)**2
51757 IF( XXC(5).LT.AXMI ) THEN
51760 IF( XXC(6).LT.AXMI ) THEN
51766 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51768 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51769 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51770 IDLAM(LKNT,1)=KFNCHI(IJ)
51773 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51775 XLAM(LKNT)=XLAM(LKNT-1)
51776 IDLAM(LKNT,1)=KFNCHI(IJ)
51782 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51783 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51784 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
51786 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
51787 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51789 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
51790 IF(XXC(5).LT.AXMI) THEN
51792 ELSEIF(XXC(6).LT.AXMI) THEN
51797 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51799 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51800 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51801 IDLAM(LKNT,1)=KFNCHI(IJ)
51809 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51810 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51812 T3I=SIGN(1D0,EI+1D-6)/2D0
51813 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51814 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51815 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51816 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51818 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51819 CXC(4)=DCONJG(GLIJ)
51820 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51822 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51823 CXC(8)=-DCONJG(GRIJ)
51825 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
51826 IF(XXC(5).LT.AXMI) THEN
51828 ELSEIF(XXC(6).LT.AXMI) THEN
51834 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51836 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51837 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51838 IDLAM(LKNT,1)=KFNCHI(IJ)
51841 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51843 XLAM(LKNT)=XLAM(LKNT-1)
51844 IDLAM(LKNT,1)=KFNCHI(IJ)
51852 C...CHI0_I -> CHI0_J + H0_K
51859 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
51860 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
51861 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
51862 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
51863 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
51864 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
51865 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
51866 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
51868 XMH=PMAS(ITH(IH),1)
51870 IF(AXMI.GE.AXMJ+XMH) THEN
51872 XL=PYLAMF(XMI2,XMJ2,XMH2)
51873 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
51875 C...SIGN OF MASSES I,J
51877 IF(IH.EQ.3) XMK=-XMK
51878 GX2=ABS(F21K)**2+ABS(F12K)**2
51879 GLR=DBLE(F21K*DCONJG(F12K))
51880 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
51881 IDLAM(LKNT,1)=KFNCHI(IJ)
51882 IDLAM(LKNT,2)=ITH(IH)
51888 C...CHI0_I -> CHI+_J + W-
51893 IF(AXMI.GE.AXMJ+XMW) THEN
51895 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
51896 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
51897 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
51898 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
51899 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
51900 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
51901 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
51902 IDLAM(LKNT,1)=KFCCHI(IJ)
51906 XLAM(LKNT)=XLAM(LKNT-1)
51907 IDLAM(LKNT,1)=-KFCCHI(IJ)
51910 ELSEIF(AXMI.GE.AXMJ) THEN
51912 S12MAX=(AXMI-AXMJ)**2
51913 RT2I = 1D0/SQRT(2D0)
51914 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
51915 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
51916 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
51917 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
51918 CXC(5)=DCMPLX(0D0,0D0)
51919 CXC(7)=DCMPLX(0D0,0D0)
51923 T3I=SIGN(1D0,EI+1D-6)/2D0
51925 T3J=SIGN(1D0,EJ+1D-6)/2D0
51926 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
51927 & TANW+ZMIXC(IX,2)*T3J)*RT2I
51928 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
51929 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
51930 CXC(6)=DCMPLX(0D0,0D0)
51931 CXC(8)=DCMPLX(0D0,0D0)
51936 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51937 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51940 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
51941 IF(XXC(5).LT.AXMI) THEN
51943 ELSEIF(XXC(6).LT.AXMI) THEN
51948 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
51950 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51951 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51952 IDLAM(LKNT,1)=KFCCHI(IJ)
51956 XLAM(LKNT)=XLAM(LKNT-1)
51957 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51958 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51959 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51960 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
51962 XLAM(LKNT)=XLAM(LKNT-1)
51963 IDLAM(LKNT,1)=KFCCHI(IJ)
51967 XLAM(LKNT)=XLAM(LKNT-1)
51968 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51969 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51970 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51974 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51975 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51976 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51978 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51979 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51981 IF(XXC(5).LT.AXMI) THEN
51984 IF(XXC(6).LT.AXMI) THEN
51989 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51991 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51992 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51993 XLAM(LKNT)=XLAM(LKNT-1)
51994 IDLAM(LKNT,1)=KFCCHI(IJ)
51998 XLAM(LKNT)=XLAM(LKNT-1)
51999 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52000 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52001 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52004 C...NOW, DO THE QUARKS
52009 T3I=SIGN(1D0,EI+1D-6)/2D0
52011 T3J=SIGN(1D0,EJ+1D-6)/2D0
52012 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
52013 & TANW+ZMIXC(IX,2)*T3J)
52014 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
52015 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
52016 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
52017 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
52018 IF(XXC(5).LT.AXMI) THEN
52021 IF(XXC(6).LT.AXMI) THEN
52026 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
52028 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52029 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52030 IDLAM(LKNT,1)=KFCCHI(IJ)
52034 XLAM(LKNT)=XLAM(LKNT-1)
52035 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52036 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52037 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52038 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52040 XLAM(LKNT)=XLAM(LKNT-1)
52041 IDLAM(LKNT,1)=KFCCHI(IJ)
52045 XLAM(LKNT)=XLAM(LKNT-1)
52046 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52047 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52048 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52056 C...CHI0_I -> CHI+_I + H-
52062 IF(AXMI.GE.AXMJ+XMHP) THEN
52064 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
52065 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
52066 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
52067 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
52069 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52070 GLR=DBLE(OLPP*DCONJG(ORPP))
52071 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52072 IDLAM(LKNT,1)=KFCCHI(IJ)
52073 IDLAM(LKNT,2)=-ITHC
52076 XLAM(LKNT)=XLAM(LKNT-1)
52077 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52078 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52079 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52085 C...2-BODY DECAYS TO FERMION SFERMION
52087 IF(J.GE.7.AND.J.LE.10) GOTO 290
52090 XMSF1=PMAS(PYCOMP(KF1),1)
52091 XMSF2=PMAS(PYCOMP(KF2),1)
52101 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
52102 IF(MOD(J,2).EQ.0) THEN
52103 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52104 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
52105 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52108 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52109 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
52110 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52115 IF(AXMI.GE.XMF+XMSF1) THEN
52119 XL=PYLAMF(XMI2,XMA2,XMB2)
52120 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
52121 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
52122 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52123 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52128 XLAM(LKNT)=XLAM(LKNT-1)
52129 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52130 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52135 IF(AXMI.GE.XMF+XMSF2) THEN
52139 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
52140 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
52141 XL=PYLAMF(XMI2,XMA2,XMB2)
52142 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52143 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52148 XLAM(LKNT)=XLAM(LKNT-1)
52149 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52150 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52155 C...3-BODY DECAY TO Q Q~ GLUINO
52156 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52157 IF(AXMI.GE.XMJ) THEN
52158 RT2I = 1D0/SQRT(2D0)
52159 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
52167 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52168 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52174 T3I=SIGN(1D0,EI+1D-6)/2D0
52175 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52176 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52180 CXC(4)=DCONJG(GLIJ)
52184 CXC(8)=-DCONJG(GRIJ)
52186 S12MAX=(AXMI-AXMJ)**2
52187 CMRENNA.This statement must be here to define S12MAX
52188 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
52189 C...ALL QUARKS BUT T
52190 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52192 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
52193 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52194 IDLAM(LKNT,1)=KSUSY1+21
52197 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52199 XLAM(LKNT)=XLAM(LKNT-1)
52200 IDLAM(LKNT,1)=KSUSY1+21
52206 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52207 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52208 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
52210 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
52211 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52213 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
52216 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52218 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
52219 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52220 IDLAM(LKNT,1)=KSUSY1+21
52227 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52228 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52229 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
52233 T3I=SIGN(1D0,EI+1D-6)/2D0
52234 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52235 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52237 CXC(4)=DCONJG(GLIJ)
52239 CXC(8)=-DCONJG(GRIJ)
52240 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52242 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
52243 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52244 IDLAM(LKNT,1)=KSUSY1+21
52247 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52249 XLAM(LKNT)=XLAM(LKNT-1)
52250 IDLAM(LKNT,1)=KSUSY1+21
52258 C...R-violating decay modes (SKANDS).
52259 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
52264 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
52265 XLAM(0)=XLAM(0)+XLAM(I)
52267 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
52272 C*********************************************************************
52275 C...Calculate decay widths for the charginos (admixtures of
52276 C...charged Wino and charged Higgsino.
52278 C...Input: KCIN = KF code for particle
52279 C...Output: XLAM = widths
52280 C... IDLAM = KF codes for decay particles
52281 C... IKNT = number of decay channels defined
52282 C...AUTHOR: STEPHEN MRENNA
52284 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
52285 C...when CHIENU .NE. 0
52287 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
52289 C...Double precision and integer declarations.
52290 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52291 IMPLICIT INTEGER(I-N)
52292 INTEGER PYK,PYCHGE,PYCOMP
52293 C...Parameter statement to help give large particle numbers.
52294 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52295 &KEXCIT=4000000,KDIMEN=5000000)
52297 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52298 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52299 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52300 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52301 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52303 C COMMON/PYINTS/XXM(20)
52305 COMMON/PYINTC/XXC(10),CXC(8)
52306 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
52308 C...Local variables
52309 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
52310 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
52312 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
52313 &XMZ,XMZ2,AXMJ,AXMI
52314 DOUBLE PRECISION S12MIN,S12MAX
52315 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
52316 DOUBLE PRECISION PYLAMF,XL
52317 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
52318 DOUBLE PRECISION PYX2XH,PYX2XG
52319 DOUBLE PRECISION XLAM(0:400)
52320 INTEGER IDLAM(400,3)
52321 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
52324 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
52325 DOUBLE PRECISION SR2
52326 DOUBLE PRECISION CBETA,SBETA,TANB
52328 DOUBLE PRECISION PYALEM,PI,PYALPS
52329 DOUBLE PRECISION FCOL
52330 INTEGER KF1,KF2,ISF
52331 INTEGER KFNCHI(4),KFCCHI(2)
52333 DOUBLE PRECISION TEMP
52334 EXTERNAL PYGAUS,PYXXZ6
52335 DOUBLE PRECISION PYGAUS,PYXXZ6
52336 DOUBLE PRECISION PREC
52339 DATA ETAH/1D0,1D0,-1D0/
52340 DATA SR2/1.4142136D0/
52341 DATA PI/3.141592654D0/
52343 DATA KFNCHI/1000022,1000023,1000025,1000035/
52344 DATA KFCCHI/1000024,1000037/
52346 C...COUNT THE NUMBER OF DECAY MODES
52354 TANW = SQRT(XW/XW1)
52356 C...1 OR 2 DEPENDING ON CHARGINO TYPE
52358 IF(KFIN.EQ.KFCCHI(2)) IX=2
52376 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52377 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52381 C...GRAVITINO DECAY MODES
52383 IF(IMSS(11).EQ.1) THEN
52386 XMGR=PMAS(PYCOMP(IDG),1)
52388 C COSW=SQRT(1D0-XW)
52389 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
52390 IF(AXMI.GT.XMGR+XMW) THEN
52396 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
52397 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
52398 & (1D0-XMW2/XMI2)**4
52400 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
52405 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
52406 & (ABS(UMIXC(IX,2))*SBETA)**2))
52407 & *(1D0-PMAS(37,1)**2/XMI2)**4
52411 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52412 IF(IX.EQ.1) GOTO 170
52417 C...CHI_2+ -> CHI_1+ + Z0
52418 IF(AXMI.GE.AXMJ+XMZ) THEN
52421 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
52422 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
52423 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
52424 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
52425 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52426 GLR=DBLE(OLPP*DCONJG(ORPP))
52427 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
52428 IDLAM(LKNT,1)=KFCCHI(1)
52432 C...CHARGED LEPTONS
52433 ELSEIF(AXMI.GE.AXMJ) THEN
52435 S12MAX=(AXMI-AXMJ)**2
52438 EI=KCHG(IABS(IA),1)/3D0
52439 T3I=SIGN(1D0,EI+1D-6)/2D0
52444 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52449 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
52450 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
52451 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
52452 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
52453 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52454 CXC(2)=DCMPLX(0D0,0D0)
52455 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52456 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
52457 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52458 CXC(6)=DCMPLX(0D0,0D0)
52459 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52460 CXC(8)=DCMPLX(0D0,0D0)
52461 IF( XXC(5).LT.AXMI ) THEN
52466 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
52468 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52469 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52470 IDLAM(LKNT,1)=KFCCHI(1)
52473 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
52475 XLAM(LKNT)=XLAM(LKNT-1)
52476 IDLAM(LKNT,1)=KFCCHI(1)
52480 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
52482 XLAM(LKNT)=XLAM(LKNT-1)
52483 IDLAM(LKNT,1)=KFCCHI(1)
52493 EI=KCHG(IABS(IA),1)/3D0
52494 T3I=SIGN(1D0,EI+1D-6)/2D0
52495 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52497 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52498 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52499 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
52500 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52501 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52502 IF( XXC(5).LT.AXMI ) THEN
52507 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
52509 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52510 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52511 IDLAM(LKNT,1)=KFCCHI(1)
52515 XLAM(LKNT)=XLAM(LKNT-1)
52516 IDLAM(LKNT,1)=KFCCHI(1)
52520 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
52521 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52522 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
52524 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
52526 IF( XXC(5).LT.AXMI ) THEN
52531 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52532 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52533 IDLAM(LKNT,1)=KFCCHI(1)
52542 EI=KCHG(IABS(IA),1)/3D0
52543 T3I=SIGN(1D0,EI+1D-6)/2D0
52544 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52546 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52547 CXC(2)=DCMPLX(0D0,0D0)
52548 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52549 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
52550 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52551 CXC(6)=DCMPLX(0D0,0D0)
52552 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52553 CXC(8)=DCMPLX(0D0,0D0)
52554 IF( XXC(5).LT.AXMI ) THEN
52559 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52561 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52562 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52563 IDLAM(LKNT,1)=KFCCHI(1)
52566 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52568 XLAM(LKNT)=XLAM(LKNT-1)
52569 IDLAM(LKNT,1)=KFCCHI(1)
52574 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52575 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52576 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52578 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52580 IF( XXC(5).LT.AXMI ) THEN
52585 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52586 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52587 IDLAM(LKNT,1)=KFCCHI(1)
52596 EI=KCHG(IABS(IA),1)/3D0
52597 T3I=SIGN(1D0,EI+1D-6)/2D0
52598 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52600 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52601 CXC(2)=DCMPLX(0D0,0D0)
52602 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52603 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
52604 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52605 CXC(6)=DCMPLX(0D0,0D0)
52606 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52607 CXC(8)=DCMPLX(0D0,0D0)
52608 IF( XXC(5).LT.AXMI ) THEN
52613 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52615 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52616 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52617 IDLAM(LKNT,1)=KFCCHI(1)
52620 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52622 XLAM(LKNT)=XLAM(LKNT-1)
52623 IDLAM(LKNT,1)=KFCCHI(1)
52631 C...CHI_2+ -> CHI_1+ + H0_K
52639 XMH=PMAS(ITH(IH),1)
52641 C...NO 3-BODY OPTION
52642 IF(AXMI.GE.AXMJ+XMH) THEN
52644 XL=PYLAMF(XMI2,XMJ2,XMH2)
52645 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
52646 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
52647 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
52648 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
52650 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52651 GLR=DBLE(OLPP*DCONJG(ORPP))
52652 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
52653 IDLAM(LKNT,1)=KFCCHI(1)
52654 IDLAM(LKNT,2)=ITH(IH)
52659 C...CHI1 JUMPS TO HERE
52662 C...CHI+_I -> CHI0_J + W+
52667 IF(AXMI.GE.AXMJ+XMW) THEN
52670 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
52672 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
52673 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
52674 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
52675 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
52676 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
52677 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
52678 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
52679 IDLAM(LKNT,1)=KFNCHI(IJ)
52683 ELSEIF(AXMI.GE.AXMJ) THEN
52685 S12MAX=(AXMI-AXMJ)**2
52687 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
52689 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
52690 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
52691 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
52692 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
52693 CXC(5)=DCMPLX(0D0,0D0)
52694 CXC(7)=DCMPLX(0D0,0D0)
52698 T3I=SIGN(1D0,EI+1D-6)/2D0
52700 T3J=SIGN(1D0,EJ+1D-6)/2D0
52701 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
52702 & TANW+ZMIXC(IJ,2)*T3J)/SR2
52703 CXC(4)=-DCONJG(UMIXC(IX,1))*(
52704 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
52705 CXC(6)=DCMPLX(0D0,0D0)
52706 CXC(8)=DCMPLX(0D0,0D0)
52711 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52712 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52715 CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
52716 IF(XXC(5).LT.AXMI) THEN
52718 ELSEIF(XXC(6).LT.AXMI) THEN
52723 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
52724 C...--> 1/(16PI)/M**3*(AEM/XW)**2
52725 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
52727 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52728 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
52729 IDLAM(LKNT,1)=KFNCHI(IJ)
52732 C...ONLY DECAY CHI+1 -> E+ NU_E
52733 IF( IMSS(12).NE. 0 ) GOTO 260
52734 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
52736 XLAM(LKNT)=XLAM(LKNT-1)
52737 IDLAM(LKNT,1)=KFNCHI(IJ)
52742 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
52744 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52745 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
52747 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
52749 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
52750 IF(XXC(5).LT.AXMI) THEN
52752 ELSEIF(XXC(6).LT.AXMI) THEN
52757 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52758 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
52759 IDLAM(LKNT,1)=KFNCHI(IJ)
52764 C...NOW, DO THE QUARKS
52769 T3I=SIGN(1D0,EI+1D-6)/2D0
52771 T3J=SIGN(1D0,EJ+1D-6)/2D0
52772 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
52773 & TANW+ZMIXC(IJ,2)*T3J)
52774 CXC(4)=-DCONJG(UMIXC(IX,1))*(
52775 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
52776 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52777 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52778 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
52779 IF(XXC(5).LT.AXMI) THEN
52782 IF(XXC(6).LT.AXMI) THEN
52787 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
52789 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52790 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52791 IDLAM(LKNT,1)=KFNCHI(IJ)
52794 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52796 XLAM(LKNT)=XLAM(LKNT-1)
52797 IDLAM(LKNT,1)=KFNCHI(IJ)
52806 C...CHI+_I -> CHI0_J + H+
52812 IF(AXMI.GE.AXMJ+XMHP) THEN
52814 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
52815 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
52816 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
52817 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
52819 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52820 GLR=DBLE(OLPP*DCONJG(ORPP))
52821 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52822 IDLAM(LKNT,1)=KFNCHI(IJ)
52830 C...2-BODY DECAYS TO FERMION SFERMION
52832 IF(J.GE.7.AND.J.LE.10) GOTO 240
52833 IF(MOD(J,2).EQ.0) THEN
52839 XMSF1=PMAS(PYCOMP(KF1),1)
52840 XMSF2=PMAS(PYCOMP(KF2),1)
52849 IF(MOD(J,2).EQ.0) THEN
52852 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
52853 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
52859 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
52861 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
52866 IF(AXMI.GE.XMF+XMSF1) THEN
52870 XL=PYLAMF(XMI2,XMA2,XMB2)
52871 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
52872 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
52873 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52874 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52876 IF(MOD(J,2).EQ.0) THEN
52886 IF(AXMI.GE.XMF+XMSF2) THEN
52890 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
52891 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
52892 XL=PYLAMF(XMI2,XMA2,XMB2)
52893 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52894 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52896 IF(MOD(J,2).EQ.0) THEN
52906 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
52907 C...A 2-BODY -- 2-BODY CHAIN
52908 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52909 IF(AXMI.GE.XMJ) THEN
52912 S12MAX=(AXMI-AXMJ)**2
52917 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
52918 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
52921 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
52923 CXC(1)=DCMPLX(0D0,0D0)
52924 CXC(3)=DCMPLX(0D0,0D0)
52925 CXC(5)=DCMPLX(0D0,0D0)
52926 CXC(7)=DCMPLX(0D0,0D0)
52927 CXC(2)=UMIXC(IX,1)*OLPP/SR2
52928 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
52929 CXC(6)=DCMPLX(0D0,0D0)
52930 CXC(8)=DCMPLX(0D0,0D0)
52931 IF(XXC(5).LT.AXMI) THEN
52933 ELSEIF(XXC(6).LT.AXMI) THEN
52938 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
52939 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
52941 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
52942 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52943 IDLAM(LKNT,1)=KSUSY1+21
52946 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52948 XLAM(LKNT)=XLAM(LKNT-1)
52949 IDLAM(LKNT,1)=KSUSY1+21
52957 C...R-violating decay modes (SKANDS).
52958 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
52963 XLAM(0)=XLAM(0)+XLAM(I)
52964 IF(XLAM(I).LT.0D0) THEN
52965 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
52966 & (IDLAM(I,J),J=1,3)
52970 IF(XLAM(0).EQ.0D0) THEN
52972 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
52973 WRITE(MSTU(11),*) LKNT
52974 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
52980 C*********************************************************************
52983 C...Used in the calculation of inoi -> inoj + f + ~f.
52987 C...Double precision and integer declarations.
52988 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52989 IMPLICIT INTEGER(I-N)
52990 INTEGER PYK,PYCHGE,PYCOMP
52991 C...Parameter statement to help give large particle numbers.
52992 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52993 &KEXCIT=4000000,KDIMEN=5000000)
52995 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52996 C COMMON/PYINTS/XXM(20)
52998 COMMON/PYINTC/XXC(10),CXC(8)
52999 SAVE /PYDAT1/,/PYINTC/
53001 C...Local variables.
53002 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
53003 DOUBLE PRECISION PYXXZ6,X
53004 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
53005 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
53006 DOUBLE PRECISION SIJ
53007 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
53008 DOUBLE PRECISION OL2
53009 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
53012 C...Statement functions.
53013 C...Integral from x to y of (t-a)(b-t) dt.
53014 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
53015 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
53016 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
53017 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
53018 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
53019 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
53020 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
53021 C...Integral from x to y of (t-a)/(b-t) dt.
53022 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
53023 C...Integral from x to y of 1/(t-a) dt.
53024 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
53032 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
53033 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
53034 &( (X-XM22-S)**2 -4D0*XM22*S ) )
53036 S23MIN=(S23AVE-S23DEL)
53037 S23MAX=(S23AVE+S23DEL)
53054 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
53055 SIJ=2D0*XXC(2)*XXC(4)*S13
53056 IF(XMV.LE.1000D0) THEN
53057 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
53058 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
53059 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
53060 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
53061 IF(XXC(5).LE.10000D0) THEN
53062 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
53063 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
53064 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
53065 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
53066 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
53067 & *(S13-XMV**2)/WPROP2
53072 IF(XXC(6).LE.10000D0) THEN
53073 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
53074 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
53075 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
53076 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
53077 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
53078 & *(S13-XMV**2)/WPROP2
53087 IF(XXC(5).LE.10000D0) THEN
53088 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
53089 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
53090 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
53091 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
53095 IF(XXC(6).LE.10000D0) THEN
53096 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
53097 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
53098 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
53099 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
53104 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
53106 IF(PYXXZ6.LT.0D0) THEN
53107 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
53108 WRITE(MSTU(11),*) (XXC(I),I=1,5)
53109 WRITE(MSTU(11),*) (XXC(I),I=6,10)
53110 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
53111 WRITE(MSTU(11),*) S23MIN,S23MAX
53119 C*********************************************************************
53122 C...Calculates chi0_i -> chi0_j + gamma.
53124 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
53126 C...Double precision and integer declarations.
53127 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53128 IMPLICIT INTEGER(I-N)
53129 INTEGER PYK,PYCHGE,PYCOMP
53131 C...Local variables.
53132 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
53133 DOUBLE PRECISION F1,F2
53135 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
53136 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
53137 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
53138 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
53143 C*********************************************************************
53146 C...Calculates the decay rate for ino -> ino + gauge boson.
53148 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
53150 C...Double precision and integer declarations.
53151 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53152 IMPLICIT INTEGER(I-N)
53153 INTEGER PYK,PYCHGE,PYCOMP
53155 C...Local variables.
53156 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
53157 DOUBLE PRECISION XL,PYLAMF,C1
53158 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53164 XL=PYLAMF(XMI2,XMJ2,XMV2)
53165 PYX2XG=C1/8D0/XMI3*SQRT(XL)
53166 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
53167 &12D0*GLR*XM1*XM2*XMV2)
53172 C*********************************************************************
53175 C...Calculates the decay rate for ino -> ino + H.
53177 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
53179 C...Double precision and integer declarations.
53180 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53181 IMPLICIT INTEGER(I-N)
53182 INTEGER PYK,PYCHGE,PYCOMP
53184 C...Local variables.
53185 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
53186 DOUBLE PRECISION XL,PYLAMF,C1
53187 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53193 XL=PYLAMF(XMI2,XMJ2,XMV2)
53194 PYX2XH=C1/8D0/XMI3*SQRT(XL)
53195 &*(GX2*(XMI2+XMJ2-XMV2)+
53201 C*********************************************************************
53204 C...Calculates the non-standard decay modes of the Higgs boson.
53206 C...Author: Stephen Mrenna
53207 C...Last Update: April 2001
53208 C......Allow complex values for Z,U, and V
53210 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
53212 C...Double precision and integer declarations.
53213 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53214 IMPLICIT INTEGER(I-N)
53215 INTEGER PYK,PYCHGE,PYCOMP
53216 C...Parameter statement to help give large particle numbers.
53217 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53218 &KEXCIT=4000000,KDIMEN=5000000)
53220 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53221 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53222 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53223 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
53224 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53225 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53226 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
53228 C...Local variables.
53229 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
53230 COMPLEX*16 QIJ,RIJ,F21K,F12K
53232 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
53233 DOUBLE PRECISION XMI2,XMI3,XMJ2
53234 DOUBLE PRECISION PYLAMF,XL,CF,EI
53236 DOUBLE PRECISION TANW,XW,AEM,C1,AS
53237 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
53238 DOUBLE PRECISION XLAM(0:400)
53239 INTEGER IDLAM(400,3)
53240 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
53242 INTEGER KFNCHI(4),KFCCHI(2)
53243 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
53244 DOUBLE PRECISION SR2
53245 DOUBLE PRECISION BETA,ALFA
53246 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
53247 DOUBLE PRECISION PYALEM
53248 DOUBLE PRECISION AL,AR,ALR
53249 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
53250 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
53251 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
53252 DATA ITH/25,35,36,37/
53253 DATA ETAH/1D0,1D0,-1D0/
53254 DATA SR2/1.4142136D0/
53255 DATA KFNCHI/1000022,1000023,1000025,1000035/
53256 DATA KFCCHI/1000024,1000037/
53258 C...COUNT THE NUMBER OF DECAY MODES
53265 TANW = SQRT(XW/(1D0-XW))
53268 C...1 - 4 DEPENDING ON Higgs species.
53270 IF(KFIN.EQ.ITH(2)) IH=2
53271 IF(KFIN.EQ.ITH(3)) IH=3
53272 IF(KFIN.EQ.ITH(4)) IH=4
53295 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
53300 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
53301 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
53306 IF(IH.EQ.4) GOTO 220
53308 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
53309 C...H0_K -> CHI0_I + CHI0_J
53322 IF(AXMI.GE.AXMJ+AXMK) THEN
53324 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
53325 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
53326 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
53327 & ZMIXC(IJ,3)*ZMIXC(IK,1))
53328 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
53329 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
53330 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
53331 & ZMIXC(IJ,4)*ZMIXC(IK,1))
53332 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
53333 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
53334 C...SIGN OF MASSES I,J
53336 GX2=ABS(F12K)**2+ABS(F21K)**2
53337 GLR=DBLE(F12K*DCONJG(F21K))
53338 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
53339 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
53340 IDLAM(LKNT,1)=KFNCHI(IJ)
53341 IDLAM(LKNT,2)=KFNCHI(IK)
53347 C...H0_K -> CHI+_I CHI-_J
53354 IF(AXMI.GE.AXMJ+AXMK) THEN
53356 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
53357 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
53358 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
53359 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
53360 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53361 GLR=DBLE(OLPP*DCONJG(ORPP))
53363 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
53364 IDLAM(LKNT,1)=KFCCHI(IJ)
53365 IDLAM(LKNT,2)=-KFCCHI(IK)
53371 C...HIGGS TO SFERMION SFERMION
53373 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
53375 XMJL=PMAS(PYCOMP(IJ),1)
53376 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
53377 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
53380 XL=PYLAMF(XMI2,XMJ2,XMJ2)
53387 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
53388 & XMF**2/XMW*SINA/CBETA
53389 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
53390 & XMF**2/XMW*SINA/CBETA
53392 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
53394 ELSEIF(IFL.EQ.15) THEN
53395 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
53401 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
53402 & XMF**2/XMW*COSA/SBETA
53403 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
53404 & XMF**2/XMW*COSA/SBETA
53406 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
53413 ELSEIF(IH.EQ.2) THEN
53415 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
53416 & XMF**2/XMW*COSA/CBETA
53417 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
53418 & XMF**2/XMW*COSA/CBETA
53420 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
53422 ELSEIF(IFL.EQ.15) THEN
53423 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
53429 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
53430 & XMF**2/XMW*SINA/SBETA
53431 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
53432 & XMF**2/XMW*SINA/SBETA
53434 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
53441 ELSEIF(IH.EQ.3) THEN
53447 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
53448 ELSEIF(IFL.EQ.15) THEN
53449 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
53453 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
53457 IF(IH.EQ.3) GOTO 180
53461 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
53468 IF(AXMI.GE.2D0*XMJ) THEN
53470 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53472 & +2D0*GHLR*ALR)**2
53478 IF(AXMI.GE.2D0*XMJR) THEN
53482 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
53485 XL=PYLAMF(XMI2,XMJ2,XMJ2)
53486 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53488 & +2D0*GHLR*ALR)**2
53489 IDLAM(LKNT,1)=IJ+KSUSY1
53490 IDLAM(LKNT,2)=-(IJ+KSUSY1)
53495 IF(AXMI.GE.XMJL+XMJR) THEN
53497 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
53498 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
53499 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
53502 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
53503 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53504 & (GHLL*AL+GHRR*AR)**2
53506 IDLAM(LKNT,2)=-(IJ+KSUSY1)
53510 IDLAM(LKNT,2)=IJ+KSUSY1
53512 XLAM(LKNT)=XLAM(LKNT-1)
53522 C...H+ -> CHI+_I + CHI0_J
53530 IF(AXMI.GE.AXMJ+AXMK) THEN
53532 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
53533 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
53534 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
53535 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
53536 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53537 GLR=DBLE(OLPP*DCONJG(ORPP))
53538 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
53539 IDLAM(LKNT,1)=KFNCHI(IJ)
53540 IDLAM(LKNT,2)=KFCCHI(IK)
53546 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
53547 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
53553 XM1=PMAS(PYCOMP(KSUSY1+6),1)
53554 XM2=PMAS(PYCOMP(KSUSY1+5),1)
53555 IF(XMI.GE.XM1+XM2) THEN
53556 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53558 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53559 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
53560 IDLAM(LKNT,1)=KSUSY1+6
53561 IDLAM(LKNT,2)=-(KSUSY1+5)
53566 XM1=PMAS(PYCOMP(KSUSY2+6),1)
53567 XM2=PMAS(PYCOMP(KSUSY1+5),1)
53568 IF(XMI.GE.XM1+XM2) THEN
53569 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53571 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53572 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
53573 IDLAM(LKNT,1)=KSUSY2+6
53574 IDLAM(LKNT,2)=-(KSUSY1+5)
53579 XM1=PMAS(PYCOMP(KSUSY1+6),1)
53580 XM2=PMAS(PYCOMP(KSUSY2+5),1)
53581 IF(XMI.GE.XM1+XM2) THEN
53582 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53584 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53585 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
53586 IDLAM(LKNT,1)=KSUSY1+6
53587 IDLAM(LKNT,2)=-(KSUSY2+5)
53592 XM1=PMAS(PYCOMP(KSUSY2+6),1)
53593 XM2=PMAS(PYCOMP(KSUSY2+5),1)
53594 IF(XMI.GE.XM1+XM2) THEN
53595 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53597 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53598 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
53599 IDLAM(LKNT,1)=KSUSY2+6
53600 IDLAM(LKNT,2)=-(KSUSY2+5)
53605 GL=-XMW/SR2*SIN(2D0*BETA)
53607 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
53608 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
53609 IF(XMI.GE.XM1+XM2) THEN
53610 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53612 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
53613 IDLAM(LKNT,1)=-(KSUSY1+IJ)
53614 IDLAM(LKNT,2)=KSUSY1+IJ+1
53622 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
53623 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
53624 IF(XMI.GE.XM1+XM2) THEN
53625 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53627 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
53628 IDLAM(LKNT,1)=-(KSUSY1+IJ)
53629 IDLAM(LKNT,2)=KSUSY1+IJ+1
53634 C...H+ -> TAU1 NUTAUL
53635 XM1=PMAS(PYCOMP(KSUSY1+15),1)
53636 XM2=PMAS(PYCOMP(KSUSY1+16),1)
53637 IF(XMI.GE.XM1+XM2) THEN
53638 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53640 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
53641 IDLAM(LKNT,1)=-(KSUSY1+15)
53642 IDLAM(LKNT,2)= KSUSY1+16
53646 C...H+ -> TAU2 NUTAUL
53647 XM1=PMAS(PYCOMP(KSUSY2+15),1)
53648 XM2=PMAS(PYCOMP(KSUSY1+16),1)
53649 IF(XMI.GE.XM1+XM2) THEN
53650 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53652 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
53653 IDLAM(LKNT,1)=-(KSUSY2+15)
53654 IDLAM(LKNT,2)= KSUSY1+16
53662 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
53663 XLAM(0)=XLAM(0)+XLAM(I)
53665 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
53670 C*********************************************************************
53673 C...Calculates the decay rate for a Higgs to an ino pair.
53675 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
53677 C...Double precision and integer declarations.
53678 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53679 IMPLICIT INTEGER(I-N)
53680 INTEGER PYK,PYCHGE,PYCOMP
53682 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53685 C...Local variables.
53686 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
53687 DOUBLE PRECISION XL,PYLAMF,C1
53688 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
53694 XL=PYLAMF(XMI2,XMJ2,XMK2)
53695 PYH2XX=C1/4D0/XMI3*SQRT(XL)
53696 &*(GX2*(XMI2-XMJ2-XMK2)-
53698 IF(PYH2XX.LT.0D0) PYH2XX=0D0
53703 C*********************************************************************
53706 C...Integration by adaptive Gaussian quadrature.
53707 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53709 FUNCTION PYGAUS(F, A, B, EPS)
53711 C...Double precision and integer declarations.
53712 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53713 IMPLICIT INTEGER(I-N)
53714 INTEGER PYK,PYCHGE,PYCOMP
53716 C...Local declarations.
53718 DOUBLE PRECISION F,W(12), X(12)
53719 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53720 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53721 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
53722 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
53723 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
53724 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
53725 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
53726 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
53727 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
53728 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
53729 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
53730 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
53732 C...The Gaussian quadrature algorithm.
53734 IF(B .EQ. A) GOTO 140
53735 CONST = 5D-3 / ABS(B-A)
53746 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
53751 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
53754 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
53756 IF(BB .NE. B) GOTO 100
53759 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
53761 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
53770 C*********************************************************************
53773 C...Integration by adaptive Gaussian quadrature.
53774 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53775 C...Carbon copy of PYGAUS, but avoids having to use it recursively.
53777 FUNCTION PYGAU2(F, A, B, EPS)
53779 C...Double precision and integer declarations.
53780 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53781 IMPLICIT INTEGER(I-N)
53782 INTEGER PYK,PYCHGE,PYCOMP
53784 C...Local declarations.
53786 DOUBLE PRECISION F,W(12), X(12)
53787 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53788 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53789 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
53790 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
53791 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
53792 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
53793 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
53794 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
53795 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
53796 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
53797 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
53798 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
53800 C...The Gaussian quadrature algorithm.
53802 IF(B .EQ. A) GOTO 140
53803 CONST = 5D-3 / ABS(B-A)
53814 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
53819 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
53822 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
53824 IF(BB .NE. B) GOTO 100
53827 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
53829 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
53838 C*********************************************************************
53841 C...Simpson formula for an integral.
53843 FUNCTION PYSIMP(Y,X0,X1,N)
53845 C...Double precision and integer declarations.
53846 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53847 IMPLICIT INTEGER(I-N)
53848 INTEGER PYK,PYCHGE,PYCOMP
53850 C...Local variables.
53851 DOUBLE PRECISION Y,X0,X1,H,S
53857 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
53864 C*********************************************************************
53867 C...The standard lambda function.
53869 FUNCTION PYLAMF(X,Y,Z)
53871 C...Double precision and integer declarations.
53872 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53873 IMPLICIT INTEGER(I-N)
53874 INTEGER PYK,PYCHGE,PYCOMP
53876 C...Local variables.
53877 DOUBLE PRECISION PYLAMF,X,Y,Z
53879 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
53880 IF(PYLAMF.LT.0D0) PYLAMF=0D0
53885 C*********************************************************************
53888 C...Generates 3-body decays of gauginos.
53890 SUBROUTINE PYTBDY(IDIN)
53892 C...Double precision and integer declarations.
53893 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53894 IMPLICIT INTEGER(I-N)
53895 INTEGER PYK,PYCHGE,PYCOMP
53896 C...Parameter statement to help give large particle numbers.
53897 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53898 &KEXCIT=4000000,KDIMEN=5000000)
53900 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53901 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53902 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53903 C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
53904 C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53905 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53906 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53907 C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
53908 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
53910 C...Local variables.
53911 DOUBLE PRECISION XM(5)
53912 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
53913 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
53914 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
53915 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
53916 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
53917 DOUBLE PRECISION CPHI1,SPHI1
53918 DOUBLE PRECISION S23DEL,EPS
53919 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
53920 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
53921 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
53923 DATA INOID/22,23,25,35/
53934 S12MIN=(XM(1)+XM(2))**2
53935 S12MAX=(XM(5)-XM(3))**2
53936 YJACO1=S12MAX-S12MIN
53938 C...Initialize some parameters
53950 C...Mrenna: check that we are indeed decaying a SUSY particle
53951 IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
53955 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
53956 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
53958 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
53959 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
53960 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
53961 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
53964 EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
53965 T3I=SIGN(1D0,EI+1D-6)/2D0
53968 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
53970 ELSEIF(IZID1*IZID2.NE.0) THEN
53972 GMMZ=PMAS(23,1)*PMAS(23,2)
53974 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
53975 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
53977 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
53978 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
53980 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
53982 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
53984 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
53985 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
53986 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
53987 XM1M2=SMZ(IZID1)*SMZ(IZID2)
53988 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
53990 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
53992 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
53994 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
53996 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
53997 IF(IZID1.NE.0) THEN
53998 XM1M2=SMZ(IZID1)*SMW(IWID2)
54002 XM1M2=SMZ(IZID2)*SMW(IWID1)
54005 RT2I = 1D0/SQRT(2D0)
54007 GMMZ=PMAS(24,1)*PMAS(24,2)
54009 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54010 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54013 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
54015 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
54016 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
54017 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
54018 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
54019 EJ=KCHG(IABS(JA),1)/3D0
54020 T3J=SIGN(1D0,EJ+1D-6)/2D0
54021 QRLS=DCMPLX(0D0,0D0)
54027 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
54028 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
54029 IF(MOD(IA,2).EQ.0) THEN
54030 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
54031 & TANW+ZMIXC(IZID2,2)*T3I)
54032 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54033 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
54035 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
54036 & TANW+ZMIXC(IZID2,2)*T3J)
54037 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54038 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
54040 ELSEIF(IWID1*IWID2.NE.0) THEN
54043 XM1M2=SMW(IWID1)*SMW(IWID2)
54045 GMMZ=PMAS(23,1)*PMAS(23,2)
54047 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54048 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54049 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
54050 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
54052 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
54053 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
54054 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
54055 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
54056 QRLS=-DCMPLX(EI/XW1)*ORPP
54057 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
54058 QRRS=-DCMPLX(EI/XW1)*OLPP
54059 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
54060 IF(MOD(IA,2).EQ.0) THEN
54061 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
54062 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
54064 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
54065 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
54067 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
54074 IF(ISKIP.NE.0) THEN
54077 S12=S12MIN+YJACO1*(KT-1)/99
54078 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54079 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54080 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54081 & -(2D0*XM(1)*XM(2))**2
54082 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54083 & -(2D0*XM(3)*XM(5))**2
54086 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54088 S23MIN=S23AVE-S23DEL
54089 S23MAX=S23AVE+S23DEL
54090 YJACO2=S23MAX-S23MIN
54093 S23=S23MIN+YJACO2*(KS-1)/99
54096 WU2 = (UH-ZM12)*(UH-ZM22)
54097 WT2 = (TH-ZM12)*(TH-ZM22)
54099 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54100 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54101 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54102 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54103 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54104 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54105 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54106 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
54107 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54108 IF(WT0.GT.WTMAX) WTMAX=WT0
54118 BX=S12MIN+0.5D0*YJACO1
54121 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
54129 C...SOLVE FOR F1 AND F2
54130 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54131 &-(2D0*XM(1)*XM(2))**2
54132 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54133 &-(2D0*XM(3)*XM(5))**2
54136 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54138 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54139 &-(2D0*XM(1)*XM(2))**2
54140 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54141 &-(2D0*XM(3)*XM(5))**2
54144 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54147 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
54148 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
54154 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54155 & -(2D0*XM(1)*XM(2))**2
54156 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54157 & -(2D0*XM(3)*XM(5))**2
54160 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54167 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54168 & -(2D0*XM(1)*XM(2))**2
54169 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54170 & -(2D0*XM(3)*XM(5))**2
54173 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54178 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
54188 180 S12=S12MIN+PYR(0)*YJACO1
54191 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54192 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54193 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54194 &-(2D0*XM(1)*XM(2))**2
54195 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54196 &-(2D0*XM(3)*XM(5))**2
54199 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54201 S23MIN=S23AVE-S23DEL
54202 S23MAX=S23AVE+S23DEL
54203 YJACO2=S23MAX-S23MIN
54204 S23=S23MIN+PYR(0)*YJACO2
54206 C...CHECK THE SAMPLING
54207 IF(IKNT.GT.100) THEN
54208 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
54211 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
54213 IF(ISKIP.EQ.0) GOTO 190
54219 WU2 = (UH-ZM12)*(UH-ZM22)
54220 WT2 = (TH-ZM12)*(TH-ZM22)
54222 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54223 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54225 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54226 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54227 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54228 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54229 c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
54230 c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
54231 c &/DCMPLX(TH-XML2)
54232 c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
54233 c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
54234 c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
54235 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54236 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
54237 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54239 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
54240 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
54242 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
54243 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
54245 P1=SQRT(D1*D1-XM(1)**2)
54246 P2=SQRT(D2*D2-XM(2)**2)
54247 P3=SQRT(D3*D3-XM(3)**2)
54248 CTHE1=2D0*PYR(0)-1D0
54249 ANG1=2D0*PYR(0)*PARU(1)
54253 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
54255 P(N+1,1)=P1*STHE1*CPHI1
54256 P(N+1,2)=P1*STHE1*SPHI1
54261 ANG3=2D0*PYR(0)*PARU(1)
54264 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
54266 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
54268 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
54269 &+P3*STHE3*SPHI3*SPHI1
54270 &+P3*CTHE3*STHE1*CPHI1
54271 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
54272 &-P3*STHE3*SPHI3*CPHI1
54273 &+P3*CTHE3*STHE1*SPHI1
54274 P(N+3,3)=P3*STHE3*CPHI3*STHE1
54279 P(N+2,I)=-P(N+1,I)-P(N+3,I)
54287 C*********************************************************************
54290 C...Finds the s-hat dependent eigenvalues of the inverse propagator
54291 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
54292 C...phase space generation. Extended to include techni-a meson, and
54293 C...to return the width.
54295 SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
54297 C...Double precision and integer declarations.
54298 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54299 IMPLICIT INTEGER(I-N)
54300 INTEGER PYK,PYCHGE,PYCOMP
54301 C...Parameter statement to help give large particle numbers.
54302 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54303 &KEXCIT=4000000,KDIMEN=5000000)
54305 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54306 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54307 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54308 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
54309 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
54311 C...Local variables.
54312 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
54313 &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
54314 &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
54321 SINW=MIN(SQRT(PARU(102)),1D0)
54322 COSW=SQRT(1D0-SINW**2)
54324 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
54325 QUPD=2D0*RTCM(2)-1D0
54327 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
54328 FAR=SQRT(AEM/ALPRHT)
54332 FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
54345 AR(2,2) = SH-PMAS(23,1)**2
54346 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
54347 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
54348 AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
54369 CALL PYWIDT(23,SH,WDTP,WDTE)
54370 AT(2,2) = WDTP(0)*SHR
54371 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
54372 AT(3,3) = WDTP(0)*SHR
54373 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
54374 AT(4,4) = WDTP(0)*SHR
54375 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
54376 AT(5,5) = WDTP(0)*SHR
54380 AR(1,1) = SH-PMAS(24,1)**2
54381 AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
54382 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
54389 CALL PYWIDT(24,SH,WDTP,WDTE)
54390 AT(1,1) = WDTP(0)*SHR
54391 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
54392 AT(2,2) = WDTP(0)*SHR
54393 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
54394 AT(3,3) = WDTP(0)*SHR
54397 CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
54402 WX(I)=SQRT(ABS(SH-WR(I)))
54404 IF(WR(I).LT.SXMN) THEN
54414 C*********************************************************************
54417 C...Universal Extra Dimensions Model (UED)
54418 C...Initialize the xd masses and widths
54419 C...M. ELKACIMI 4/03/2006
54420 C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands
54424 C...Double precision and integer declarations.
54425 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54426 IMPLICIT INTEGER(I-N)
54427 INTEGER PYK,PYCHGE,PYCOMP
54429 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54430 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54431 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
54432 C...UED Pythia common
54433 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54435 C...SAVE statements
54436 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPUED/
54438 C...Print out some info about the UED model
54439 WRITE(MSTU(11),7000)
54441 & '********** PYXDIN: initialization of UED ******************',
54443 & 'Universal Extra Dimensions (UED) switched on ',
54445 & 'This implementation is courtesy of',
54446 & ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ',
54447 & ' see [hep-ph/0602198] (Les Houches 2005) ',
54449 & 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ',
54450 & 'Dobrescu), with gravity-mediated decay widths calculated in',
54451 & '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
54452 & 'radiative corrections to the KK masses from [hep/ph0204342]',
54453 & '(Cheng, Matchev, Schmaltz).'
54454 WRITE(MSTU(11),7000)
54456 & 'SM particles can propagate into one small extra dimension ',
54457 & 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
54458 & 'graviton is further allowed to propagate into N = IUED(4)',
54459 & 'large (eV^-1) extra dimensions.'
54460 WRITE(MSTU(11),7000)
54462 & 'The switches and parameters for UED are:',
54463 & ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
54464 & ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
54465 & ' IUED(3): (D=5) number of quark flavours',
54466 & ' IUED(4): (D=6) number of large extra dimensions into',
54467 & ' which the graviton propagates',
54468 & ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
54469 & ' IUED(6): (D=1) With/without rad.corrs. (=1/0)',
54471 & ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
54472 & ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
54473 & ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
54474 & ' when IUED(5)=0',
54475 & ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
54476 WRITE(MSTU(11),7000)
54478 & 'N.B.: the Higgs mass is also a free parameter of the UED ',
54479 & 'model, but is set through pmas(25,1).',
54482 C...Hardcoded switch, required by current implementation
54483 CALL PYGIVE('MSTP(42)=0')
54485 C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
54486 IF(IUED(2).EQ.0) CALL PYGIVE('MDCY(C5100022,1)=0')
54488 C...Calculated the radiative corrections to the KK particle masses
54491 C...Initialize the graviton mass
54492 C...only if the KK particles decays gravitationally
54493 IF(IUED(2).EQ.1) CALL PYGRAM(0)
54495 WRITE(MSTU(11),7000)
54496 & '********** PYXDIN: UED initialization completed ***********'
54498 C...Format to use for comments
54499 7000 FORMAT(' * ',A)
54503 C*********************************************************************
54506 C...Auxiliary to PYXDIN
54507 C...Mass kk states radiative corrections
54508 C...Radiative corrections are included (hep/ph0204342)
54512 C...Double precision and integer declarations.
54513 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54514 IMPLICIT INTEGER(I-N)
54515 INTEGER PYK,PYCHGE,PYCOMP
54517 PARAMETER(KKPART=25,KKFLA=450)
54519 C...UED Pythia common
54520 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54521 C...Pythia common: particles properties
54522 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54524 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54525 C...Decay information.
54526 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54527 C...Resonance width and secondary decay treatment.
54528 COMMON/PYINT4/MWID(500),WIDS(500,5)
54529 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54531 C...Local variables
54532 DOUBLE PRECISION PI,QUP,QDW
54533 DOUBLE PRECISION WDTP,WDTE
54534 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
54535 DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3
54536 DOUBLE PRECISION DSMG2,LOGLAM,DBMG2
54537 DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE
54538 DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2
54539 DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2
54540 DOUBLE PRECISION SWW1,CWW1
54541 DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST
54542 DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE
54543 DOUBLE PRECISION SW21,CW21,SW021,CW021
54544 COMMON/SW1/SW021,CW021
54545 C...UED related declarations:
54546 C...equivalences between ordered particles (451->475)
54547 C...and UED particle code (5 000 000 + id)
54548 DIMENSION IUEDEQ(475)
54549 DATA (IUEDEQ(I),I=451,475)/
54551 & 6100001,6100002,6100003,6100004,6100005,6100006,
54553 & 5100001,5100002,5100003,5100004,5100005,5100006,
54554 C...Singlet leptons
54555 & 6100011,6100013,6100015,
54556 C...Doublet leptons
54557 & 5100012,5100011,5100014,5100013,5100016,5100015,
54558 C...Gauge boson KK excitations
54559 & 5100021,5100022,5100023,5100024/
54561 C...N.B. rinv=rued(1)
54562 IF(RUED(1).LE.0.)THEN
54563 WRITE(MSTU(11),*) 'PYUEDC: RINV < 0 : ',RUED(1)
54564 WRITE(MSTU(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
54577 c...qt is q-tilde, qs is q-star
54578 c...strong coupling value
54582 c...weak mixing angle
54586 c...for the mass corrections
54591 C... Either fix the cutoff scale LAMUED
54592 IF(IUED(5).EQ.0)THEN
54593 LOGLAM = DLOG((RUED(3)*(1./RUED(1)))**2)
54594 C... or the ratio LAMUED/RINV (=product Lambda*R)
54595 ELSEIF(IUED(5).EQ.1)THEN
54596 LOGLAM = DLOG(RUED(4)**2)
54598 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
54602 C...Calculate the radiative corrections for the UED KK masses
54603 IF(IUED(6).EQ.1)THEN
54605 C...or induce a minute mass difference
54606 C...keeping the UED KK mass values nearly equal to 1/R
54607 ELSEIF(IUED(6).EQ.0)THEN
54610 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
54614 c...Take into account only the strong interactions:
54616 c...The space bulk corrections :
54617 DSMG2 = RMKK2*(-1.5)*(ALPHS/4./PI)*ZETA3/PI**2
54618 c...The boundary terms:
54619 DBMG2 = RMKK2*(23./2.)*(ALPHS/4./PI)*LOGLAM
54621 c...Mass corrections for fermions are extracted from
54622 c...Phys. Rev. D66 036005(2002)9
54623 DBMQDO=RMKK*(3.*(ALPHS/4./PI)+27./16.*(ALPHEM/4./PI/SW2)
54624 . +1./16.*(ALPHEM/4./PI/CW2))*LOGLAM
54625 DBMQU=RMKK*(3.*(ALPHS/4./PI)
54626 . +(ALPHEM/4./PI/CW2))*LOGLAM
54627 DBMQD=RMKK*(3.*(ALPHS/4./PI)
54628 . +0.25*(ALPHEM/4./PI/CW2))*LOGLAM
54630 DBMLDO=RMKK *((27./16.)*(ALPHEM/4./PI/SW2)+9./16.*
54631 . (ALPHEM/4./PI/CW2))*LOGLAM
54632 DBMLE=RMKK *(9./4.*(ALPHEM/4./PI/CW2))*LOGLAM
54634 c...Vector boson masss matrix diagonalization
54635 DBMB2 = RMKK2*(-1./6.)*(ALPHEM/4./PI/CW2)*LOGLAM
54636 DSMB2 = RMKK2*(-39./2.)*(ALPHEM/4./PI**3/CW2)*ZETA3
54637 DBMA2 = RMKK2*(15./2.)*(ALPHEM/4./PI/SW2)*LOGLAM
54638 DSMA2 = RMKK2*(-5./2.)*(ALPHEM/4./PI**3/SW2)*ZETA3
54640 c...Elements of the mass matrix
54641 A = RMZ2*SW2 + DBMB2 + DSMB2
54642 B = RMZ2*CW2 + DBMA2 + DSMA2
54643 C = RMZ2*DSQRT(SW2*CW2)
54644 SQRDEL = DSQRT( (A-B)**2 + 4*C**2 )
54646 c...Eigenvalues: corrections to X1 and Z1 masses
54647 DMB2 = (A+B-SQRDEL)/2.
54648 DMA2 = (A+B+SQRDEL)/2.
54650 c...Rotation angles
54654 SW21= SWW1**2/(SWW1**2 + CWW1**2)
54661 RMGST = RMKK+RFACT*(DSQRT(RMKK2 + DSMG2 + DBMG2)-RMKK)
54663 RMDQST=RMKK+RFACT*DBMQDO
54664 RMSQUS=RMKK+RFACT*DBMQU
54665 RMSQDS=RMKK+RFACT*DBMQD
54667 C...Note: MZ mass is included in ma2
54668 RMPHST= RMKK+RFACT*(DSQRT(RMKK2 + DMB2)-RMKK)
54669 RMZST = RMKK+RFACT*(DSQRT(RMKK2 + DMA2)-RMKK)
54670 RMWST = RMKK+RFACT*(DSQRT(RMKK2 + DBMA2 + DSMA2 + RMW**2)-RMKK)
54672 RMLSLD=RMKK+RFACT*DBMLDO
54673 RMLSLE=RMKK+RFACT*DBMLE
54676 PMAS(KKFLA+IPART,1)=RMSQDS
54679 PMAS(KKFLA+IPART,1)=RMSQUS
54682 PMAS(KKFLA+IPART,1)=RMDQST
54685 PMAS(KKFLA+IPART,1)=RMLSLE
54688 PMAS(KKFLA+IPART,1)=RMLSLD
54690 PMAS(KKFLA+22,1)=RMGST
54691 PMAS(KKFLA+23,1)=RMPHST
54692 PMAS(KKFLA+24,1)=RMZST
54693 PMAS(KKFLA+25,1)=RMWST
54695 WRITE(MSTU(11),7000) ' PYUEDC: ',
54696 & 'UED Mass Spectrum (GeV) :'
54697 WRITE(MSTU(11),7100) ' m(d*_S,s*_S,b*_S) = ',RMSQDS
54698 WRITE(MSTU(11),7100) ' m(u*_S,c*_S,t*_S) = ',RMSQUS
54699 WRITE(MSTU(11),7100) ' m(q*_D) = ',RMDQST
54700 WRITE(MSTU(11),7100) ' m(l*_S) = ',RMLSLE
54701 WRITE(MSTU(11),7100) ' m(l*_D) = ',RMLSLD
54702 WRITE(MSTU(11),7100) ' m(g*) = ',RMGST
54703 WRITE(MSTU(11),7100) ' m(gamma*) = ',RMPHST
54704 WRITE(MSTU(11),7100) ' m(Z*) = ',RMZST
54705 WRITE(MSTU(11),7100) ' m(W*) = ',RMWST
54706 WRITE(MSTU(11),7000) ' '
54708 C...Initialize widths, branching ratios and life time
54711 IF(MWID(KC).EQ.1.AND.MDCY(KC,1).EQ.1)THEN
54712 CALL PYWIDT(IUEDEQ(KC),PMAS(KC,1)**2,WDTP,WDTE)
54713 IF(WDTP(0).LE.0)THEN
54715 + 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', KC
54716 WRITE(MSTU(11),*) 'INITIAL VALUE IS TAKEN',PMAS(KC,2)
54719 DO 180 IDC=1,MDCY(KC,3)
54720 IC=IDC+MDCY(KC,2)-1
54721 IF(MDME(IC,1).EQ.1.AND.WDTP(IDC).GT.0.)THEN
54722 C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm
54723 PMAS(KC,4)=PARU(3)/WDTP(IDC)*1.D-12
54724 BRAT(IC)=WDTP(IDC)/WDTP(0)
54731 C...Format to use for comments
54732 7000 FORMAT(' * ',A)
54733 7100 FORMAT(' * ',A,F12.3)
54736 C********************************************************************
54739 C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
54740 C... Original version:
54743 C Universal Extra Dimensions Subprocess cross sections
54744 C The expressions used are from atl-com-phys-2005-003
54745 C What is coded here is shat**2/pi * dsigma/dt = |M|**2
54746 C For each UED subprocess, the color flow used is the same
54747 C as the equivalent QCD subprocess. Different configuration
54748 C color flows are considered to have the same probability.
54750 C The Xsection is calculated following ATL-PHYS-PUB-2005-003
54751 C by G.Azuelos and P.H.Beauchemin.
54753 C This routine is called from pysigh.
54755 SUBROUTINE PYXUED(NCHN,SIGS)
54757 C...Double precision and integer declarations
54758 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54759 IMPLICIT INTEGER(I-N)
54762 COMMON/DECMOD/NGRDEC
54764 PARAMETER(KKPART=25,KKFLA=450)
54766 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54767 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54768 COMMON/PYINT1/MINT(400),VINT(400)
54769 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
54770 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
54771 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
54772 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
54773 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
54774 SAVE /PYDAT2/,/PYINT1/,/PYINT3/,/PYPARS/
54775 C...UED Pythia common
54776 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54777 C...Local arrays and complex variables
54778 DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS
54779 + ,FAC1,XMNKK,XMUED,SIGS
54782 C...Return if UED not switched on
54783 IF (IUED(1).LE.0) THEN
54787 C...Energy scale of the parton processus
54788 C...taken equal to the mass of the final state kk
54791 C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
54792 XMNKK=PMAS(KKFLA+23,1)
54794 C...To compare the cross section with phys-pub-2005-03
54795 C...(no radiative corrections),
54796 C...take xmnkk=rinv and q2=rinv**2
54798 C...n.b. (rinv=rued(1))
54799 c IF(NGRDEC.EQ.1)XMNKK=RUED(0)
54800 IF(NGRDEC.EQ.1)XMNKK=RUED(1)
54809 BETA34=DSQRT(1.D0-4.D0*XMNKK**2/SHAT)
54812 c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
54813 Q2=RUED(1)**2+(TP*UP-RUED(1)**4)/SP
54815 c IF(NGRDEC.EQ.1)Q2=RUED(0)**2
54816 IF(NGRDEC.EQ.1)Q2=RUED(1)**2
54819 C...Strong coupling value
54822 IF(ISUB.EQ.311)THEN
54824 FAC1=9./8.*ALPHAS**2/(SP*TP*UP)**2
54825 XMUED=FAC1*(XMNKK**4*(6.*TP**4+18.*TP**3*UP+
54826 & 24.*TP**2*UP**2+18.*TP*UP**3+6.*UP**4)
54827 & +XMNKK**2*(6.*TP**4*UP+12.*TP**3*UP**2+
54828 & 12.*TP**2*UP**3+6*TP*UP**4)
54829 & +2.*TP**6+6*TP**5*UP+13*TP**4*UP**2+
54830 & 15.*TP**3*UP**3+13*TP**2*UP**4+
54831 & 6.*TP*UP**5+2.*UP**6)
54835 C...Three color flow configurations (qcd g+g->g+g)
54837 IF(XCOL.LE.1./3.)THEN
54839 ELSEIF(XCOL.LE.2./3.)THEN
54844 SIGH(NCHN)=COMFAC*XMUED
54845 ELSEIF(ISUB.EQ.312)THEN
54846 C...q + g -> q*_D + g*, q*_S + g*
54847 C...(the two channels have the same cross section)
54848 FAC1=-1./36.*ALPHAS**2/(SP*TP*UP)**2
54849 XMUED=FAC1*(12.*SP*UP**5+5.*SP**2*UP**4+22.*SP**3*UP**3+
54850 & 5.*SP**4*UP**2+12.*SP**5*UP)
54851 XMUED=COMFAC*2.*XMUED
54853 DO 190 I=MMINA,MMAXA
54854 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
54857 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
54858 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
54861 ISIG(NCHN,3-ISDE)=21
54864 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
54868 ELSEIF(ISUB.EQ.313)THEN
54869 C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj
54870 C...(the two channels have the same cross section)
54871 C...qi and qj have the same charge sign
54872 DO 100 I=MMIN1,MMAX1
54874 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 100
54875 DO 101 J=MMIN2,MMAX2
54877 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).
54879 IF(J*I.LE.0)GOTO 101
54884 FAC1=1./72.*ALPHAS**2/(TP*UP)**2
54886 & (XMNKK**2*(8*TP**3+4./3.*TP**2*UP+4./3.*TP*UP**2
54887 & +8.*UP**3)+8.*TP**4+56./3.*TP**3*UP+
54888 & 20.*TP**2*UP**2+56./3.*
54889 & TP*UP**3+8.*UP**4)
54890 SIGH(NCHN)=COMFAC*2.*XMUED
54892 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
54894 FAC1=2./9.*ALPHAS**2/TP**2
54895 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
54896 SIGH(NCHN)=COMFAC*2.*XMUED
54901 ELSEIF(ISUB.EQ.314)THEN
54902 C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
54903 C...(the two channels have the same cross section)
54907 ISIG(NCHN,3)=INT(1.5+PYR(0))
54909 FAC1=5./6.*ALPHAS**2/(SP*TP*UP)**2
54910 XMUED=FAC1*(-XMNKK**4*(8.*TP*UP**3+8.*TP**2*UP**2+8.*TP**3*UP
54911 + +4.*UP**4+4*TP**4)
54912 + -XMNKK**2*(0.5*TP*UP**4+4.*TP**2*UP**3+15./2.*TP**3
54913 + *UP**2+ 4.*TP**4*UP)+TP*UP**5-0.25*TP**2*UP**4+
54914 + 2.*TP**3*UP**3-0.25*TP**4*UP**2+TP**5*UP)
54916 SIGH(NCHN)=COMFAC*XMUED
54917 C...has been multiplied by 5: all possible quark flavors in final state
54919 ELSEIF(ISUB.EQ.315)THEN
54920 C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
54921 C...(the two channels have the same cross section)
54922 DO 141 I=MMIN1,MMAX1
54923 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
54924 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 141
54925 DO 142 J=MMIN2,MMAX2
54926 IF(J.EQ.0.OR.ABS(I).NE.ABS(J).OR.I*J.GE.0) GOTO 142
54927 FAC1=2./9.*ALPHAS**2*1./(SP*TP)**2
54928 XMUED=FAC1*(XMNKK**2*SP*(4.*TP**2-SP*TP-SP**2)+
54929 & 4.*TP**4+3.*SP*TP**3+11./12.*TP**2*SP**2-
54930 & 2./3.*SP**3*TP+SP**4)
54935 SIGH(NCHN)=COMFAC*2.*XMUED
54938 ELSEIF(ISUB.EQ.316)THEN
54939 C...q + qbar' -> q*_D + q*_Sbar'
54940 FAC1=2./9.*ALPHAS**2
54941 DO 300 I=MMIN1,MMAX1
54943 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 300
54944 DO 301 J=MMIN2,MMAX2
54946 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 301
54947 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 301
54952 FAC1=2./9.*ALPHAS**2/TP**2
54953 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
54954 SIGH(NCHN)=COMFAC*XMUED
54958 ELSEIF(ISUB.EQ.317)THEN
54959 C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar'
54960 C...(the two channels have the same cross section)
54961 DO 400 I=MMIN1,MMAX1
54963 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 400
54964 DO 401 J=MMIN1,MMAX1
54966 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 401
54967 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 401
54972 FAC1=1./18.*ALPHAS**2/TP**2
54973 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
54974 SIGH(NCHN)=COMFAC*2.*XMUED
54977 ELSEIF(ISUB.EQ.318)THEN
54978 C...q + q' -> q*_D + q*_S'
54979 DO 500 I=MMIN1,MMAX1
54981 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 500
54982 DO 501 J=MMIN2,MMAX2
54984 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 501
54985 IF(J*I.LE.0)GOTO 501
54990 ISIG(NCHN,3)=INT(1.5+PYR(0))
54991 FAC1=1./36.*ALPHAS**2/(TP*UP)**2
54992 XMUED=FAC1*(-8.*XMNKK**2*(TP**3+TP**2*UP+TP*UP**2+UP**3)
54993 & +8.*TP**4+4.*TP**2*UP**2+8.*UP**4)
54994 SIGH(NCHN)=COMFAC*XMUED
55000 FAC1=1./18.*ALPHAS**2/TP**2
55001 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
55002 SIGH(NCHN)=COMFAC*2.*XMUED
55006 ELSEIF(ISUB.EQ.319)THEN
55007 C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
55008 C...(the two channels have the same cross section)
55009 DO 741 I=MMIN1,MMAX1
55010 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
55011 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 741
55012 DO 742 J=MMIN2,MMAX2
55013 IF(J.EQ.0.OR.IABS(J).NE.IABS(I).OR.J*I.GT.0) GOTO 742
55014 FAC1=16./9.*ALPHAS**2*1./(SP)**2
55015 XMUED=FAC1*(2.*XMNKK**2*SP+SP**2+2.*SP*TP+2.*TP**2)
55020 SIGH(NCHN)=COMFAC*2.*XMUED
55028 C*********************************************************************
55031 C...Universal Extra Dimensions Model (UED)
55032 C...Computation of the Graviton mass.
55034 SUBROUTINE PYGRAM(IN)
55036 C...Double precision and integer declarations
55037 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55038 IMPLICIT INTEGER(I-N)
55040 C...Pythia commonblocks
55041 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55042 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55043 C...UED Pythia common
55044 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55046 C...Local variables
55048 PARAMETER(KCFLA=450,NMAX=5000)
55049 DIMENSION YVEC(5000),RESVEC(5000)
55050 COMMON/INTSAV/YSAV,YMAX,RESMAX
55051 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55052 COMMON/KAPPA/XKAPPA
55054 C...External function (used in call to PYGAUS)
55057 C...SAVE statements
55058 SAVE /PYDAT1/,/PYDAT2/,/PYPUED/,/INTSAV/
55066 C...Initialize for numerical integration
55068 XKAPPA=DSQRT(2.D0)/XMPLNK
55070 C...For NDIM=2, compute graviton mass distribution numerically
55073 C... For first event: tabulate distribution of stepwise integrals:
55074 C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
55079 YSAV = (I-0.5)/DBLE(NMAX)
55081 C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
55082 RESINT = PYGAUS(PYGRAW,0D0,1D0,TOL)
55085 C... Save max of distribution (for accept/reject below)
55086 IF(RESINT.GT.RESMAX)THEN
55093 C... Generate Mg for each graviton (1D0 ensures a minimal open phase space)
55096 XMGAMK=PMAS(KCGAKK,1)
55098 C... Pick random graviton mass, accept according to stored integrals
55099 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55100 110 RMG=AMMAX*PYR(0)
55103 C... Bin enumeration starts at 1, but make sure always in range
55105 IBIN=MIN(IBIN,NMAX)
55106 IF(RESVEC(IBIN)/RESMAX.LT.PYR(0)) GOTO 110
55108 C... For NDIM=4 and 6, the analytical expression for the
55109 C... graviton mass distribution integral is used.
55110 ELSEIF(NDIM.EQ.4.OR.NDIM.EQ.6)THEN
55112 C... Ensure minimal open phase space (max(mG*) < m(gamma*))
55115 C... KK photon (?) compressed code and mass
55117 XMGAMK=PMAS(KCGAKK,1)
55119 C... Find maximum of (dGamma/dMg)
55125 RESINT=Y**(NDIM-3)*(1D0/(1D0-Y**2))*(1D0+DCOS(PI*Y))
55126 IF(RESINT.GE.RESMAX)THEN
55133 C... Pick random graviton mass, accept/reject
55134 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55135 130 RMG=AMMAX*PYR(0)
55137 DGADMG=X**(NDIM-3)*(1./(1.-X**2))*(1.+DCOS(PI*X))
55138 IF(DGADMG/RESMAX.LT.PYR(0)) GOTO 130
55140 C... If the user has not chosen N=2,4 or 6, STOP
55142 WRITE(MSTU(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',NDIM,
55143 & ' (MUST BE 2, 4, OR 6) '
55147 C... Now store the sampled Mg
55153 C*********************************************************************
55156 C...Universal Extra Dimensions Model (UED)
55158 C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
55160 C...Integrand for the KK boson -> SM boson + graviton
55161 C...graviton mass distribution (and gravity mediated total width),
55162 C...which contains (see 0201300 and below for the full product)
55163 C...the gravity mediated partial decay width Gamma(xx, yy)
55164 C... i.e. GRADEN(YY)*PYWDKK(XXA)
55165 C... where xx is exclusive to gravity
55166 C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55167 C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.
55169 DOUBLE PRECISION FUNCTION PYGRAW(YIN)
55171 C...Double precision and integer declarations
55172 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55173 IMPLICIT INTEGER (I-N)
55175 C...Pythia commonblocks
55176 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55178 C...Local UED commonblocks and variables
55179 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55180 COMMON/INTSAV/YSAV,YMAX,RESMAX
55182 C...SAVE statements
55183 SAVE /PYDAT1/,/INTSAV/
55185 C...External: Pythia's Gamma function
55194 XX=DSQRT(1.-YY**2)*YIN
55195 DJAC=(1.-YMIN)*DSQRT(1.-YY**2)
55196 FAC=2.*PI**((NDIM-1.)/2.)*XMPLNK**2*RINV**NDIM/XMD**(NDIM+2)
55200 XXA=DSQRT(XX**2+YY**2)
55201 GRADEN=4./PI2 * (YY**2/(1.-YY**2)**2)*(1.+DCOS(PI*YY))
55204 + FAC*XX**(NDIM-2)*GRADEN*PYWDKK(XXA)
55208 C*********************************************************************
55211 C...Universal Extra Dimensions Model (UED)
55213 C...Multiplied by the square modulus of a form factor
55214 C...(see GRADEN in function PYGRAW)
55215 C...PYWDKK is the KK boson -> SM boson + graviton
55216 C...gravity mediated partial decay width Gamma(xx, yy)
55217 C... where xx is exclusive to gravity
55218 C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55219 C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
55221 C...N.B. The Feynman rules for the couplings of the graviton fields
55222 C...to the UED fields are related to the corresponding couplings of
55223 C...the graviton fields to the SM fields by the form factor.
55225 DOUBLE PRECISION FUNCTION PYWDKK(X)
55227 C...Double precision and integer declarations
55228 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55229 IMPLICIT INTEGER (I-N)
55231 C...Pythia commonblocks
55232 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55233 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55235 C...Local UED commonblocks and variables
55236 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55237 COMMON/KAPPA/XKAPPA
55239 C...SAVE statements
55240 SAVE /PYDAT1/,/PYDAT2/,/UEDGRA/,/KAPPA/
55244 C...gamma* mass 473
55246 XMNKK=PMAS(KCQKK,1)
55248 C...Bosons partial width Macesanu hep-ph/0201300
55249 PYWDKK=XKAPPA**2/(96.*PI)*XMNKK**3/X**4*
55250 + ((1.-X**2)**2*(1.+3.*X**2+6.*X**4))
55255 C*********************************************************************
55258 C...Finds eigenvalues of a general complex matrix
55260 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
55261 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
55262 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
55263 C OF A COMPLEX GENERAL MATRIX.
55267 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
55268 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55269 C DIMENSION STATEMENT.
55271 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
55273 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
55274 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
55276 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
55277 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
55278 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
55282 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55283 C RESPECTIVELY, OF THE EIGENVALUES.
55285 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55286 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
55288 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
55289 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
55290 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
55292 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
55294 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55295 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55297 C THIS VERSION DATED AUGUST 1983.
55300 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
55302 INTEGER N,NM,IS1,IS2,IERR,MATZ
55303 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55304 X FV1(5),FV2(5),FV3(5)
55305 IF (N .LE. NM) GOTO 100
55309 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
55310 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
55311 IF (MATZ .NE. 0) GOTO 110
55312 C .......... FIND EIGENVALUES ONLY ..........
55313 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
55315 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
55316 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
55317 IF (IERR .NE. 0) GOTO 120
55318 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
55322 C*********************************************************************
55325 C...Auxiliary to PYEICG.
55327 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55328 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
55330 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
55331 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55332 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55334 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
55335 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
55339 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55340 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55341 C DIMENSION STATEMENT.
55343 C N IS THE ORDER OF THE MATRIX.
55345 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55346 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55347 C SET LOW=1, IGH=N.
55349 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55350 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55351 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
55352 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
55353 C THE REDUCTION BY CORTH, IF PERFORMED.
55357 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
55358 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
55359 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
55360 C EIGENVECTORS IS TO BE PERFORMED.
55362 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55363 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55364 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55365 C FOR INDICES IERR+1,...,N.
55368 C ZERO FOR NORMAL RETURN,
55369 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55370 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55372 C CALLS PYCDIV FOR COMPLEX DIVISION.
55373 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55374 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55376 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55377 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55379 C THIS VERSION DATED AUGUST 1983.
55382 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
55384 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
55385 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
55386 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55390 IF (LOW .EQ. IGH) GOTO 130
55391 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55396 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
55397 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
55398 YR = HR(I,I-1) / NORM
55399 YI = HI(I,I-1) / NORM
55404 SI = YR * HI(I,J) - YI * HR(I,J)
55405 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
55410 SI = YR * HI(J,I) + YI * HR(J,I)
55411 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
55416 C .......... STORE ROOTS ISOLATED BY CBAL ..........
55417 130 DO 140 I = 1, N
55418 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
55427 C .......... SEARCH FOR NEXT EIGENVALUE ..........
55428 150 IF (EN .LT. LOW) GOTO 320
55431 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55432 C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
55433 160 DO 170 LL = LOW, EN
55435 IF (L .EQ. LOW) GOTO 180
55436 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
55437 X + DABS(HR(L,L)) + DABS(HI(L,L))
55438 TST2 = TST1 + DABS(HR(L,L-1))
55439 IF (TST2 .EQ. TST1) GOTO 180
55441 C .......... FORM SHIFT ..........
55442 180 IF (L .EQ. EN) GOTO 300
55443 IF (ITN .EQ. 0) GOTO 310
55444 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
55447 XR = HR(ENM1,EN) * HR(EN,ENM1)
55448 XI = HI(ENM1,EN) * HR(EN,ENM1)
55449 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
55450 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
55451 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
55452 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
55453 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
55456 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
55460 C .......... FORM EXCEPTIONAL SHIFT ..........
55461 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
55464 210 DO 220 I = LOW, EN
55465 HR(I,I) = HR(I,I) - SR
55466 HI(I,I) = HI(I,I) - SI
55473 C .......... REDUCE TO TRIANGLE (ROWS) ..........
55479 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
55480 XR = HR(I-1,I-1) / NORM
55482 XI = HI(I-1,I-1) / NORM
55485 HI(I-1,I-1) = 0.0D0
55486 HI(I,I-1) = SR / NORM
55493 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
55494 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
55495 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
55496 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
55502 IF (SI .EQ. 0.0D0) GOTO 250
55503 NORM = PYTHAG(HR(EN,EN),SI)
55504 SR = HR(EN,EN) / NORM
55508 C .......... INVERSE OPERATION (COLUMNS) ..........
55509 250 DO 280 J = LP1, EN
55518 IF (I .EQ. J) GOTO 260
55520 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55521 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55522 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55523 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55528 IF (SI .EQ. 0.0D0) GOTO 160
55533 HR(I,EN) = SR * YR - SI * YI
55534 HI(I,EN) = SR * YI + SI * YR
55538 C .......... A ROOT FOUND ..........
55539 300 WR(EN) = HR(EN,EN) + TR
55540 WI(EN) = HI(EN,EN) + TI
55543 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55544 C CONVERGED AFTER 30*N ITERATIONS ..........
55549 C*********************************************************************
55552 C...Auxiliary to PYEICG.
55554 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55555 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
55557 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
55558 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55559 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55561 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
55562 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
55563 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
55564 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
55565 C THIS GENERAL MATRIX TO HESSENBERG FORM.
55569 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55570 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55571 C DIMENSION STATEMENT.
55573 C N IS THE ORDER OF THE MATRIX.
55575 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55576 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55577 C SET LOW=1, IGH=N.
55579 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
55580 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
55581 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
55582 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
55583 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
55585 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55586 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55587 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
55588 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
55589 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
55590 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
55595 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
55596 C HAVE BEEN DESTROYED.
55598 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55599 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55600 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55601 C FOR INDICES IERR+1,...,N.
55603 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55604 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
55605 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
55606 C THE EIGENVECTORS HAS BEEN FOUND.
55609 C ZERO FOR NORMAL RETURN,
55610 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55611 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55613 C CALLS PYCDIV FOR COMPLEX DIVISION.
55614 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55615 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55617 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55618 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55620 C THIS VERSION DATED OCTOBER 1989.
55622 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
55623 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
55626 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
55628 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
55629 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
55630 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55632 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55636 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
55645 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
55646 C FROM THE INFORMATION LEFT BY CORTH ..........
55647 IEND = IGH - LOW - 1
55648 IF (IEND.LT.0) GOTO 220
55649 IF (IEND.EQ.0) GOTO 170
55650 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
55651 DO 160 II = 1, IEND
55653 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
55654 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
55655 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
55656 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
55659 DO 120 K = IP1, IGH
55660 ORTR(K) = HR(K,I-1)
55661 ORTI(K) = HI(K,I-1)
55669 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
55670 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
55677 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
55678 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
55684 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55689 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
55690 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
55691 YR = HR(I,I-1) / NORM
55692 YI = HI(I,I-1) / NORM
55697 SI = YR * HI(I,J) - YI * HR(I,J)
55698 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
55703 SI = YR * HI(J,I) + YI * HR(J,I)
55704 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
55708 DO 200 J = LOW, IGH
55709 SI = YR * ZI(J,I) + YI * ZR(J,I)
55710 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
55715 C .......... STORE ROOTS ISOLATED BY CBAL ..........
55716 220 DO 230 I = 1, N
55717 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
55726 C .......... SEARCH FOR NEXT EIGENVALUE ..........
55727 240 IF (EN .LT. LOW) GOTO 430
55730 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55731 C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
55732 250 DO 260 LL = LOW, EN
55734 IF (L .EQ. LOW) GOTO 270
55735 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
55736 X + DABS(HR(L,L)) + DABS(HI(L,L))
55737 TST2 = TST1 + DABS(HR(L,L-1))
55738 IF (TST2 .EQ. TST1) GOTO 270
55740 C .......... FORM SHIFT ..........
55741 270 IF (L .EQ. EN) GOTO 420
55742 IF (ITN .EQ. 0) GOTO 550
55743 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
55746 XR = HR(ENM1,EN) * HR(EN,ENM1)
55747 XI = HI(ENM1,EN) * HR(EN,ENM1)
55748 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
55749 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
55750 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
55751 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
55752 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
55755 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
55759 C .......... FORM EXCEPTIONAL SHIFT ..........
55760 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
55763 300 DO 310 I = LOW, EN
55764 HR(I,I) = HR(I,I) - SR
55765 HI(I,I) = HI(I,I) - SI
55772 C .......... REDUCE TO TRIANGLE (ROWS) ..........
55778 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
55779 XR = HR(I-1,I-1) / NORM
55781 XI = HI(I-1,I-1) / NORM
55784 HI(I-1,I-1) = 0.0D0
55785 HI(I,I-1) = SR / NORM
55792 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
55793 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
55794 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
55795 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
55801 IF (SI .EQ. 0.0D0) GOTO 350
55802 NORM = PYTHAG(HR(EN,EN),SI)
55803 SR = HR(EN,EN) / NORM
55807 IF (EN .EQ. N) GOTO 350
55813 HR(EN,J) = SR * YR + SI * YI
55814 HI(EN,J) = SR * YI - SI * YR
55816 C .......... INVERSE OPERATION (COLUMNS) ..........
55817 350 DO 390 J = LP1, EN
55826 IF (I .EQ. J) GOTO 360
55828 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55829 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55830 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55831 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55834 DO 380 I = LOW, IGH
55839 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55840 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55841 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55842 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55847 IF (SI .EQ. 0.0D0) GOTO 250
55852 HR(I,EN) = SR * YR - SI * YI
55853 HI(I,EN) = SR * YI + SI * YR
55856 DO 410 I = LOW, IGH
55859 ZR(I,EN) = SR * YR - SI * YI
55860 ZI(I,EN) = SR * YI + SI * YR
55864 C .......... A ROOT FOUND ..........
55865 420 HR(EN,EN) = HR(EN,EN) + TR
55867 HI(EN,EN) = HI(EN,EN) + TI
55871 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
55872 C VECTORS OF UPPER TRIANGULAR FORM ..........
55878 TR = DABS(HR(I,J)) + DABS(HI(I,J))
55879 IF (TR .GT. NORM) NORM = TR
55882 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
55883 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
55891 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
55892 DO 490 II = 1, ENM1
55899 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
55900 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
55905 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
55908 460 YR = 0.01D0 * YR
55910 IF (TST2 .GT. TST1) GOTO 460
55912 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
55913 C .......... OVERFLOW CONTROL ..........
55914 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
55915 IF (TR .EQ. 0.0D0) GOTO 490
55917 TST2 = TST1 + 1.0D0/TST1
55918 IF (TST2 .GT. TST1) GOTO 490
55920 HR(J,EN) = HR(J,EN)/TR
55921 HI(J,EN) = HI(J,EN)/TR
55927 C .......... END BACKSUBSTITUTION ..........
55928 C .......... VECTORS OF ISOLATED ROOTS ..........
55930 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
55938 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
55939 C VECTORS OF ORIGINAL FULL MATRIX.
55940 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
55945 DO 540 I = LOW, IGH
55950 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
55951 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
55959 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55960 C CONVERGED AFTER 30*N ITERATIONS ..........
55965 C*********************************************************************
55968 C...Auxiliary to PYCMQR
55970 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
55973 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
55975 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
55976 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
55978 S = DABS(BR) + DABS(BI)
55983 S = BRS**2 + BIS**2
55984 CR = (ARS*BRS + AIS*BIS)/S
55985 CI = (AIS*BRS - ARS*BIS)/S
55989 C*********************************************************************
55992 C...Auxiliary to PYCMQR
55994 C (YR,YI) = COMPLEX DSQRT(XR,XI)
55995 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
55998 SUBROUTINE PYCSRT(XR,XI,YR,YI)
56000 DOUBLE PRECISION XR,XI,YR,YI
56001 DOUBLE PRECISION S,TR,TI,PYTHAG
56005 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
56006 IF (TR .GE. 0.0D0) YR = S
56007 IF (TI .LT. 0.0D0) S = -S
56008 IF (TR .LE. 0.0D0) YI = S
56009 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
56010 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
56014 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
56015 DOUBLE PRECISION A,B
56017 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
56019 DOUBLE PRECISION P,R,S,T,U
56020 P = DMAX1(DABS(A),DABS(B))
56021 IF (P .EQ. 0.0D0) GOTO 110
56022 R = (DMIN1(DABS(A),DABS(B))/P)**2
56025 IF (T .EQ. 4.0D0) GOTO 110
56027 U = 1.0D0 + 2.0D0*S
56035 C*********************************************************************
56038 C...Auxiliary to PYEICG
56040 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56041 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
56042 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56043 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56045 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
56046 C EIGENVALUES WHENEVER POSSIBLE.
56050 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56051 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56052 C DIMENSION STATEMENT.
56054 C N IS THE ORDER OF THE MATRIX.
56056 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56057 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
56061 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56062 C RESPECTIVELY, OF THE BALANCED MATRIX.
56064 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
56065 C ARE EQUAL TO ZERO IF
56066 C (1) I IS GREATER THAN J AND
56067 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
56069 C SCALE CONTAINS INFORMATION DETERMINING THE
56070 C PERMUTATIONS AND SCALING FACTORS USED.
56072 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
56073 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
56074 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
56075 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
56076 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
56077 C = D(J,J) J = LOW,...,IGH
56078 C = P(J) J = IGH+1,...,N.
56079 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
56082 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
56084 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
56085 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
56086 C K,L HAVE BEEN REVERSED.)
56088 C ARITHMETIC IS REAL THROUGHOUT.
56090 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56091 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56093 C THIS VERSION DATED AUGUST 1983.
56096 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
56098 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
56099 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
56100 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
56109 C .......... IN-LINE PROCEDURE FOR ROW AND
56110 C COLUMN EXCHANGE ..........
56112 IF (J .EQ. M) GOTO 130
56132 130 IF(IEXC.EQ.1) GOTO 140
56133 IF(IEXC.EQ.2) GOTO 180
56134 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
56135 C AND PUSH THEM DOWN ..........
56136 140 IF (L .EQ. 1) GOTO 320
56138 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
56139 150 DO 170 JJ = 1, L
56143 IF (I .EQ. J) GOTO 160
56144 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
56153 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
56154 C AND PUSH THEM LEFT ..........
56157 190 DO 210 J = K, L
56160 IF (I .EQ. J) GOTO 200
56161 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
56168 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
56170 220 SCALE(I) = 1.0D0
56171 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
56172 230 NOCONV = .FALSE.
56179 IF (J .EQ. I) GOTO 240
56180 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
56181 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
56183 C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
56184 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
56188 250 IF (C .GE. G) GOTO 260
56193 270 IF (C .LT. G) GOTO 280
56197 C .......... NOW BALANCE ..........
56198 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
56200 SCALE(I) = SCALE(I) * F
56204 AR(I,J) = AR(I,J) * G
56205 AI(I,J) = AI(I,J) * G
56209 AR(J,I) = AR(J,I) * F
56210 AI(J,I) = AI(J,I) * F
56215 IF (NOCONV) GOTO 230
56222 C*********************************************************************
56225 C...Auxiliary to PYEICG.
56227 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56228 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
56229 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56230 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56232 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
56233 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
56234 C BALANCED MATRIX DETERMINED BY CBAL.
56238 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56239 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56240 C DIMENSION STATEMENT.
56242 C N IS THE ORDER OF THE MATRIX.
56244 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
56246 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
56247 C AND SCALING FACTORS USED BY CBAL.
56249 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
56251 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56252 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
56253 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
56257 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56258 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
56259 C IN THEIR FIRST M COLUMNS.
56261 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56262 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56264 C THIS VERSION DATED AUGUST 1983.
56267 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
56269 INTEGER I,J,K,M,N,II,NM,IGH,LOW
56270 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
56273 IF (M .EQ. 0) GOTO 150
56274 IF (IGH .EQ. LOW) GOTO 120
56276 DO 110 I = LOW, IGH
56278 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
56279 C IF THE FOREGOING STATEMENT IS REPLACED BY
56280 C S=1.0D0/SCALE(I). ..........
56282 ZR(I,J) = ZR(I,J) * S
56283 ZI(I,J) = ZI(I,J) * S
56287 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
56288 C IGH+1 STEP 1 UNTIL N DO -- ..........
56289 120 DO 140 II = 1, N
56291 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
56292 IF (I .LT. LOW) I = LOW - II
56294 IF (K .EQ. I) GOTO 140
56310 C*********************************************************************
56313 C...Auxiliary to PYEICG.
56315 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
56316 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
56317 C BY MARTIN AND WILKINSON.
56318 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
56320 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
56321 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
56322 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
56323 C UNITARY SIMILARITY TRANSFORMATIONS.
56327 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56328 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56329 C DIMENSION STATEMENT.
56331 C N IS THE ORDER OF THE MATRIX.
56333 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56334 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56335 C SET LOW=1, IGH=N.
56337 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56338 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
56342 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56343 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
56344 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
56345 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
56346 C HESSENBERG MATRIX.
56348 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
56349 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
56351 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56353 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56354 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56356 C THIS VERSION DATED AUGUST 1983.
56359 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
56361 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
56362 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
56363 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
56367 IF (LA .LT. KP1) GOTO 210
56374 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
56376 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
56378 IF (SCALE .EQ. 0.0D0) GOTO 200
56380 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56383 ORTR(I) = AR(I,M-1) / SCALE
56384 ORTI(I) = AI(I,M-1) / SCALE
56385 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
56389 F = PYTHAG(ORTR(M),ORTI(M))
56390 IF (F .EQ. 0.0D0) GOTO 120
56393 ORTR(M) = (1.0D0 + G) * ORTR(M)
56394 ORTI(M) = (1.0D0 + G) * ORTI(M)
56399 C .......... FORM (I-(U*UT)/H) * A ..........
56400 130 DO 160 J = M, N
56403 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56406 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
56407 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
56414 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
56415 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
56419 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
56423 C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
56426 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
56427 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
56434 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
56435 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
56440 ORTR(M) = SCALE * ORTR(M)
56441 ORTI(M) = SCALE * ORTI(M)
56442 AR(M,M-1) = -G * AR(M,M-1)
56443 AI(M,M-1) = -G * AI(M,M-1)
56449 C*********************************************************************
56452 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56455 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
56457 INTEGER N,NP,INDX(N)
56459 COMPLEX*16 A(NP,NP)
56460 PARAMETER (TINY=1.0D-20)
56462 REAL*8 AAMAX,VV(6),DUM
56463 COMPLEX*16 SUM,DUMC
56469 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
56471 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
56478 SUM=SUM-A(I,K)*A(K,J)
56486 SUM=SUM-A(I,K)*A(K,J)
56490 IF (DUM.GE.AAMAX) THEN
56505 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
56508 A(I,J)=A(I,J)/A(J,J)
56516 C*********************************************************************
56519 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56522 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
56524 INTEGER N,NP,INDX(N)
56525 COMPLEX*16 A(NP,NP),B(N)
56536 SUM=SUM-A(I,J)*B(J)
56538 ELSE IF (ABS(SUM).NE.0D0) THEN
56546 SUM=SUM-A(I,J)*B(J)
56553 C***********************************************************************
56556 C...Calculates full and partial widths of resonances.
56557 C....copy of PYWIDT, used for techniparticle widths
56559 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
56561 C...Double precision and integer declarations.
56562 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56563 IMPLICIT INTEGER(I-N)
56564 INTEGER PYK,PYCHGE,PYCOMP
56565 C...Parameter statement to help give large particle numbers.
56566 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56567 &KEXCIT=4000000,KDIMEN=5000000)
56569 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56570 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56571 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
56572 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
56573 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
56574 COMMON/PYINT1/MINT(400),VINT(400)
56575 COMMON/PYINT4/MWID(500),WIDS(500,5)
56576 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
56577 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
56578 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
56579 &/PYINT4/,/PYMSSM/,/PYTCSM/
56580 C...Local arrays and saved variables.
56581 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
56583 SAVE MOFSV,WIDWSV,WID2SV
56584 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
56586 C...Compressed code and sign; mass.
56593 C...Reset width information.
56598 C...Common electroweak and strong constants.
56601 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
56604 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
56606 RADC=1D0+AS/PARU(1)
56608 IF(KFLA.EQ.23) THEN
56610 XWC=1D0/(16D0*XW*XW1)
56611 FAC=(AEM*XWC/3D0)*SHR
56613 DO 130 I=1,MDCY(KC,3)
56615 IF(MDME(IDC,1).LT.0) GOTO 130
56616 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
56617 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
56618 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
56622 AF=SIGN(1D0,EF+0.1D0)
56625 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
56626 ELSEIF(I.LE.16) THEN
56627 C...Z0 -> l+ + l-, nu + nubar
56629 AF=SIGN(1D0,EF+0.1D0)
56633 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
56634 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
56636 WDTP(0)=WDTP(0)+WDTP(I)
56640 ELSEIF(KFLA.EQ.24) THEN
56642 FAC=(AEM/(24D0*XW))*SHR
56643 DO 140 I=1,MDCY(KC,3)
56645 IF(MDME(IDC,1).LT.0) GOTO 140
56646 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
56647 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
56648 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
56651 C...W+/- -> q + qbar'
56652 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
56653 ELSEIF(I.LE.20) THEN
56654 C...W+/- -> l+/- + nu
56657 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
56658 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
56659 WDTP(0)=WDTP(0)+WDTP(I)
56662 C.....V8 -> quark anti-quark
56663 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
56666 IF(ITCM(2).EQ.0) THEN
56668 ELSEIF(ITCM(2).EQ.1) THEN
56671 DO 150 I=1,MDCY(KC,3)
56673 IF(MDME(IDC,1).LT.0) GOTO 150
56674 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
56676 IF(RM1.GT.0.25D0) GOTO 150
56678 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
56683 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
56684 IF(I.EQ.6) WID2=WIDS(6,1)
56685 WDTP(0)=WDTP(0)+WDTP(I)
56692 C*********************************************************************
56695 C...Calculates R-violating decays of sfermions.
56698 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
56700 C...Double precision and integer declarations.
56701 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56702 IMPLICIT INTEGER(I-N)
56703 C...Parameter statement to help give large particle numbers.
56704 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56705 &KEXCIT=4000000,KDIMEN=5000000)
56707 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56708 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
56709 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
56710 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
56711 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
56712 C...Local variables.
56713 DOUBLE PRECISION XLAM(0:400)
56714 INTEGER IDLAM(400,3), PYCOMP
56715 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
56717 C...IS R-VIOLATION ON ?
56718 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
56719 C...Mass eigenstate counter
56720 ICNT=INT(KFIN/KSUSY1)
56721 C...SM KF code of SUSY particle
56722 KFSM=KFIN-ICNT*KSUSY1
56723 C...Squared Sparticle Mass
56724 SM=PMAS(PYCOMP(KFIN),1)**2
56725 C... Squared mass of top quark
56726 SMT=PMAS(PYCOMP(6),1)**2
56727 C...IS L-VIOLATION ON ?
56728 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
56729 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
56730 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
56736 C...~e,~mu,~tau -> nu_I + lepton-_J
56738 IDLAM(LKNT,1)= 12 +2*(I-1)
56739 IDLAM(LKNT,2)= 11 +2*(J-1)
56742 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56743 IF (IMSS(51).NE.0) XLAM(LKNT) =
56744 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56745 C...KINEMATICS CHECK
56746 IF (XLAM(LKNT).EQ.0D0) THEN
56752 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
56758 IDLAM(LKNT,1)=-12 -2*(I-1)
56759 IDLAM(LKNT,2)= 11 +2*(K-1)
56762 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56763 IF (IMSS(51).NE.0) XLAM(LKNT) =
56764 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56765 C...KINEMATICS CHECK
56766 IF (XLAM(LKNT).EQ.0D0) THEN
56772 C...~e,~mu,~tau -> u_Jbar + d_K
56777 IDLAM(LKNT,1)=-2 -2*(J-1)
56778 IDLAM(LKNT,2)= 1 +2*(K-1)
56781 IF (IMSS(52).NE.0) THEN
56782 C...Use massive top quark
56783 IF (IDLAM(LKNT,1).EQ.-6) THEN
56784 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
56787 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
56788 C...If no top quark, all decay products massless
56790 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56792 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56794 C...KINEMATICS CHECK
56795 IF (XLAM(LKNT).EQ.0D0) THEN
56802 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
56803 C...No right-handed neutrinos
56805 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
56810 C...~nu_J -> lepton+_I + lepton-_K
56812 IDLAM(LKNT,1)=-11 -2*(I-1)
56813 IDLAM(LKNT,2)= 11 +2*(K-1)
56816 RM2=RVLAM(I,J,K)**2 * SM
56817 IF (IMSS(51).NE.0) XLAM(LKNT) =
56818 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56819 C...KINEMATICS CHECK
56820 IF (XLAM(LKNT).EQ.0D0) THEN
56826 C...~nu_I -> dbar_J + d_K
56831 IDLAM(LKNT,1)=-1 -2*(J-1)
56832 IDLAM(LKNT,2)= 1 +2*(K-1)
56835 RM2=3*RVLAMP(I,J,K)**2 * SM
56836 IF (IMSS(52).NE.0) XLAM(LKNT) =
56837 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56838 C...KINEMATICS CHECK
56839 IF (XLAM(LKNT).EQ.0D0) THEN
56846 C * SDOWN -> NU(BAR) + D and LEPTON- + U
56847 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
56851 C...~d_J -> nu_Ibar + d_K
56853 IDLAM(LKNT,1)=-12 -2*(I-1)
56854 IDLAM(LKNT,2)= 1 +2*(K-1)
56857 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56858 IF (IMSS(52).NE.0) XLAM(LKNT) =
56859 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56860 C...KINEMATICS CHECK
56861 IF (XLAM(LKNT).EQ.0D0) THEN
56869 C...~d_K -> nu_I + d_J
56871 IDLAM(LKNT,1)= 12 +2*(I-1)
56872 IDLAM(LKNT,2)= 1 +2*(J-1)
56875 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56876 IF (IMSS(52).NE.0) XLAM(LKNT) =
56877 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56878 C...KINEMATICS CHECK
56879 IF (XLAM(LKNT).EQ.0D0) THEN
56882 C...~d_K -> lepton_I- + u_J
56884 IDLAM(LKNT,1)= 11 +2*(I-1)
56885 IDLAM(LKNT,2)= 2 +2*(J-1)
56888 IF (IMSS(52).NE.0) THEN
56889 C...Use massive top quark
56890 IF (IDLAM(LKNT,2).EQ.6) THEN
56891 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
56893 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
56894 C...If no top quark, all decay products massless
56896 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56898 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56900 C...KINEMATICS CHECK
56901 IF (XLAM(LKNT).EQ.0D0) THEN
56908 C * SUP -> LEPTON+ + D
56909 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
56913 C...~u_J -> lepton_I+ + d_K
56915 IDLAM(LKNT,1)=-11 -2*(I-1)
56916 IDLAM(LKNT,2)= 1 +2*(K-1)
56919 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56920 IF (IMSS(52).NE.0) XLAM(LKNT) =
56921 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56922 C...KINEMATICS CHECK
56923 IF (XLAM(LKNT).EQ.0D0) THEN
56930 C...BARYON NUMBER VIOLATING DECAYS
56931 IF (IMSS(53).GE.1) THEN
56932 C * SUP -> DBAR + DBAR
56933 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
56937 C...~u_I -> dbar_J + dbar_K
56939 C...(anti-) symmetry J <-> K.
56941 IDLAM(LKNT,1) = -1 -2*(J-1)
56942 IDLAM(LKNT,2) = -1 -2*(K-1)
56945 RM2 = 2.*(RVLAMB(I,J,K)**2)
56946 & * SFMIX(KFSM,2*ICNT)**2 * SM
56948 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56949 C...KINEMATICS CHECK
56950 IF (XLAM(LKNT).EQ.0D0) THEN
56957 C * SDOWN -> UBAR + DBAR
56958 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
56962 C...LAMB coupling antisymmetric in J and K.
56964 C...~d_K -> ubar_I + dbar_K
56966 IDLAM(LKNT,1)= -2 -2*(I-1)
56967 IDLAM(LKNT,2)= -1 -2*(J-1)
56970 C...Use massive top quark
56971 IF (IDLAM(LKNT,1).EQ.-6) THEN
56972 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
56975 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
56976 C...If no top quark, all decay products massless
56978 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56980 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56982 C...KINEMATICS CHECK
56983 IF (XLAM(LKNT).EQ.0D0) THEN
56996 C*********************************************************************
56999 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
57002 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
57004 C...Double precision and integer declarations.
57005 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57006 IMPLICIT INTEGER(I-N)
57007 C...Parameter statement to help give large particle numbers.
57008 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57009 &KEXCIT=4000000,KDIMEN=5000000)
57011 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57012 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57013 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57014 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57015 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57016 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57017 C...Local variables.
57018 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57020 DOUBLE PRECISION XLAM(0:400)
57021 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
57022 INTEGER IDLAM(400,3), PYCOMP
57024 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
57026 C...R-VIOLATING DECAYS
57027 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57029 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
57030 C...WHICH NEUTRALINO ?
57032 IF (KFSM.EQ.23) NCHI=2
57033 IF (KFSM.EQ.25) NCHI=3
57034 IF (KFSM.EQ.35) NCHI=4
57035 C...SIGN OF MASS (Opposite convention as HERWIG)
57037 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
57039 C...Useful parameters for the calculation of the A and B constants.
57040 WMASS = PMAS(PYCOMP(24),1)
57041 ECHG = 2*SQRT(PARU(103)*PARU(1))
57042 COSB=1/(SQRT(1+RMSS(5)**2))
57043 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
57044 COSW=SQRT(1-PARU(102))
57045 SINW=SQRT(PARU(102))
57046 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
57047 C...Run quark masses to neutralino mass squared (for Higgs-type
57049 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
57051 RMQ(I)=PYMRUN(I,SQMCHI)
57053 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
57055 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
57056 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
57057 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
57058 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
57060 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
57061 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
57062 C2=ECHG*ZPMIX(NCHI,1)
57063 C3=GW*ZPMIX(NCHI,2)/COSW
57067 C x=1-2 : Select A or B constant (1:A ; 2:B)
57068 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57069 C 11-16:e,nu_e,mu,...)
57070 C z=1-2 : Mass eigenstate number
57071 C...CALCULATE COUPLINGS
57073 CMS=PMAS(PYCOMP(I),1)
57074 C...Intermediate sleptons
57075 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
57076 & *(C2-C3*SINW**2))
57077 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
57078 & *(C2-C3*SINW**2))
57079 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
57081 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
57083 C...Inermediate sneutrinos
57085 AB(2,I+1,1)=5D-1*C3
57088 C...Inermediate sdown
57091 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
57092 & *ED*(C2-C3*SINW**2))
57093 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
57094 & *ED*(C2-C3*SINW**2))
57095 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
57096 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57097 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
57098 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57099 C...Inermediate sup
57102 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
57103 & *EU*(C2-C3*SINW**2))
57104 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
57105 & *EU*(C2-C3*SINW**2))
57106 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
57107 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57108 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
57109 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57112 IF (IMSS(51).GE.1) THEN
57113 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
57114 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
57115 C...STEP IN I,J,K USING SINGLE COUNTER
57117 C...LAMBDA COUPLING ASYM IN I,J
57118 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57120 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57121 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57122 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57124 C...Set coupling, and decay product masses on/off
57125 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57126 & ,MOD(ISC,3)+1)**2
57128 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
57130 C...Resonance KF codes (1=I,2=J,3=K)
57131 KFR(1)=-IDLAM(LKNT,1)
57132 KFR(2)=-IDLAM(LKNT,2)
57133 KFR(3)=-IDLAM(LKNT,3)
57134 C...Calculate width.
57135 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57136 & IDLAM(LKNT,3),XLAM(LKNT))
57137 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57138 C...Charge conjugate mode.
57140 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57141 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57142 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57143 XLAM(LKNT)=XLAM(LKNT-1)
57144 C...KINEMATICS CHECK
57145 IF (XLAM(LKNT).EQ.0D0) THEN
57152 IF (IMSS(52).GE.1) THEN
57153 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
57154 C * CHI0 -> NUBAR_I + DBAR_J + D_K
57157 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57158 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57159 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57161 C...Set coupling, and decay product masses on/off
57162 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57163 & ,MOD(ISC,3)+1)**2
57165 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
57167 C...Resonance KF codes (1=I,2=J,3=K)
57168 KFR(1)=-IDLAM(LKNT,1)
57169 KFR(2)=-IDLAM(LKNT,2)
57170 KFR(3)=-IDLAM(LKNT,3)
57171 C...Calculate width.
57172 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57174 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57175 C...Charge conjugate mode.
57177 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57178 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57179 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57180 XLAM(LKNT)=XLAM(LKNT-1)
57181 C...KINEMATICS CHECK
57182 IF (XLAM(LKNT).EQ.0D0) THEN
57186 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
57188 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57189 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57190 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57192 C...Set coupling, and decay product masses on/off
57193 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57194 & ,MOD(ISC,3)+1)**2
57196 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
57197 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
57198 C...Resonance KF codes (1=I,2=J,3=K)
57199 KFR(1)=-IDLAM(LKNT,1)
57200 KFR(2)=-IDLAM(LKNT,2)
57201 KFR(3)=-IDLAM(LKNT,3)
57202 C...Calculate width.
57203 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57205 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57206 C...Charge conjugate mode.
57208 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57209 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57210 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57211 XLAM(LKNT)=XLAM(LKNT-1)
57212 C...KINEMATICS CHECK
57213 IF (XLAM(LKNT).EQ.0D0) THEN
57219 IF (IMSS(53).GE.1) THEN
57220 C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
57221 C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
57223 C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
57224 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
57226 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
57227 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57228 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57230 C...Set coupling, and decay product masses on/off
57231 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
57232 & +1,MOD(ISC,3)+1)**2
57234 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
57235 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
57236 C...Resonance KF codes (1=I,2=J,3=K)
57237 KFR(1) = IDLAM(LKNT,1)
57238 KFR(2) = IDLAM(LKNT,2)
57239 KFR(3) = IDLAM(LKNT,3)
57240 C...Calculate width.
57241 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57242 & IDLAM(LKNT,3),XLAM(LKNT))
57243 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57244 C...Charge conjugate mode.
57246 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57247 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57248 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57249 XLAM(LKNT)=XLAM(LKNT-1)
57250 C...KINEMATICS CHECK
57251 IF (XLAM(LKNT).EQ.0D0) THEN
57263 C*********************************************************************
57266 C...Calculates R-violating chargino decay widths.
57269 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
57271 C...Double precision and integer declarations.
57272 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57273 IMPLICIT INTEGER(I-N)
57274 C...Parameter statement to help give large particle numbers.
57275 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57276 &KEXCIT=4000000,KDIMEN=5000000)
57278 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57279 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57280 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57281 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57282 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57283 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57284 C...Local variables.
57285 DOUBLE PRECISION XLAM(0:400)
57286 INTEGER IDLAM(400,3), PYCOMP
57287 C...Information from main routine to PYRVGW
57288 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57290 C...Auxiliary variables needed for BV (RV Gauge STOre)
57291 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
57293 C...Running quark masses
57294 DOUBLE PRECISION RMQ(6)
57295 C...Decay product masses on/off
57297 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57301 C...IF R-VIOLATION ON.
57302 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57304 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
57305 C...WHICH CHARGINO ?
57307 IF (KFSM.EQ.37) NCHI = 2
57309 C...Useful parameters for calculating the A and B constants.
57310 C...SIGN OF MASS (Opposite convention as HERWIG)
57312 IF (SMW(NCHI).LT.0D0) ISM = -1
57313 WMASS = PMAS(PYCOMP(24),1)
57314 COSB = 1/(SQRT(1+RMSS(5)**2))
57315 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
57316 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
57317 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
57318 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
57321 C...Running masses at Q^2=MCHI^2.
57322 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
57324 RMQ(I)=PYMRUN(I,SQMCHI)
57327 C... AB(x,y,z) coefficients:
57328 C x=1-2 : A or B coefficient (1:A ; 2:B)
57329 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57330 C 11-16:e,nu_e,mu,...)
57331 C z=1-2 : Mass eigenstate number
57333 C...Intermediate sleptons
57336 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
57338 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
57340 C...Intermediate sneutrinos
57341 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
57343 AB(2,I+1,1) = ISM*C3
57345 C...Intermediate sdown
57347 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
57348 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
57349 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
57350 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
57351 C...Intermediate sup
57353 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
57354 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
57355 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
57356 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
57359 C...LLE TYPE R-VIOLATION
57360 IF (IMSS(51).GE.1) THEN
57361 C...LOOP OVER DECAY MODES
57364 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
57365 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57367 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
57368 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
57369 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
57371 C...Set coupling, and decay product masses on/off
57372 RVLAMC = GW2 * 5D-1 *
57373 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57376 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
57377 C...Resonance KF codes (1=I,2=J,3=K).
57380 KFR(3) = -IDLAM(LKNT,3)+1
57381 C...Calculate width.
57382 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57383 & IDLAM(LKNT,3),XLAM(LKNT))
57384 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57385 C...KINEMATICS CHECK
57386 IF (XLAM(LKNT).EQ.0D0) THEN
57390 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
57391 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
57393 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
57394 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
57395 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
57397 C...Set coupling, and decay product masses on/off
57398 RVLAMC = GW2 * 5D-1 *
57399 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57400 C...I,J SYMMETRY => FACTOR 2
57403 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
57404 C...Resonance KF codes (1=I,2=J,3=K)
57405 KFR(1)=IDLAM(LKNT,1)-1
57406 KFR(2)=IDLAM(LKNT,2)-1
57408 C...Calculate width.
57409 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57410 & IDLAM(LKNT,3),XLAM(LKNT))
57411 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57412 C...KINEMATICS CHECK
57413 IF (XLAM(LKNT).EQ.0D0) THEN
57418 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
57420 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57421 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57422 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57424 C...Set coupling, and decay product masses on/off
57425 RVLAMC = GW2 * 5D-1 *
57426 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57427 C...I,J SYMMETRY => FACTOR 2
57430 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
57431 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
57432 C...Resonance KF codes (1=I,2=J,3=K)
57433 KFR(1) =-IDLAM(LKNT,1)+1
57434 KFR(2) =-IDLAM(LKNT,2)+1
57436 C...Calculate width.
57437 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57438 & IDLAM(LKNT,3),XLAM(LKNT))
57439 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57440 C...KINEMATICS CHECK
57441 IF (XLAM(LKNT).EQ.0D0) THEN
57448 C...LQD TYPE R-VIOLATION
57449 IF (IMSS(52).GE.1) THEN
57450 C...LOOP OVER DECAY MODES
57453 C...CHI+ -> NUBAR_I + DBAR_J + U_K
57455 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57456 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57457 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
57459 C...Set coupling, and decay product masses on/off
57460 RVLAMC = 3. * GW2 * 5D-1 *
57461 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57463 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
57465 C...Resonance KF codes (1=I,2=J,3=K)
57468 KFR(3)=-IDLAM(LKNT,3)+1
57469 C...Calculate width.
57470 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57472 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57473 C...KINEMATICS CHECK
57474 IF (XLAM(LKNT).EQ.0D0) THEN
57478 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
57480 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57481 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57482 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
57484 C...Set coupling, and decay product masses on/off
57485 RVLAMC = 3. * GW2 * 5D-1 *
57486 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57488 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
57489 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
57490 C...Resonance KF codes (1=I,2=J,3=K)
57493 KFR(3)=-IDLAM(LKNT,3)+1
57494 C...Calculate width.
57495 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57497 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57498 C...KINEMATICS CHECK
57499 IF (XLAM(LKNT).EQ.0D0) THEN
57503 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
57505 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57506 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57507 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57509 C...Set coupling, and decay product masses on/off
57510 RVLAMC = 3. * GW2 * 5D-1 *
57511 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57513 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
57514 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
57515 C...Resonance KF codes (1=I,2=J,3=K)
57516 KFR(1)=-IDLAM(LKNT,1)+1
57517 KFR(2)=-IDLAM(LKNT,2)+1
57519 C...Calculate width.
57520 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57522 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57523 C...KINEMATICS CHECK
57524 IF (XLAM(LKNT).EQ.0D0) THEN
57528 C * CHI+ -> NU_I + U_J + DBAR_K.
57530 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
57531 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
57532 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57534 C...Set coupling, and decay product masses on/off
57536 RVLAMC = 3. * GW2 * 5D-1 *
57537 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57538 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
57540 C...Resonance KF codes (1=I,2=J,3=K)
57541 KFR(1)=IDLAM(LKNT,1)-1
57542 KFR(2)=IDLAM(LKNT,2)-1
57544 C...Calculate width.
57545 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57547 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57548 C...KINEMATICS CHECK
57549 IF (XLAM(LKNT).EQ.0D0) THEN
57556 C...UDD TYPE R-VIOLATION
57557 C...These decays need special treatment since more than one BV coupling
57558 C...contributes (with interference). Consider e.g. (symbolically)
57559 C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
57560 C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
57561 C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
57562 C...The problem is that a single call to PYRVGW would evaluate all
57563 C...these terms and sum them, but without the different couplings. The
57564 C...way out is to call PYRVGW three times, once for the first line, once
57565 C...for the second line, and then once for all the lines (it is
57566 C...impossible to get just the last line out) without multiplying by
57567 C...couplings. The last line is then obtained as the result of the third
57568 C...call minus the results of the two first calls. Each term is then
57569 C...multiplied by its respective coupling before the whole thing is
57570 C...summed up in XLAM.
57571 C...Note that with three interfering resonances, this procedure becomes
57572 C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
57574 IF (IMSS(53).GE.1) THEN
57575 C...LOOP OVER DECAY MODES
57578 C...CHI+ -> U_I + U_J + D_K
57579 C...Decay mode I<->J symmetric.
57580 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
57582 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
57583 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
57584 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57586 C...Set coupling, and decay product masses on/off
57587 RVLAMC= 6. * GW2 * 5D-1
57588 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
57590 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
57592 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
57595 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
57596 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
57597 C...Resonance KF codes (1=I,2=J,3=K)
57598 KFR(1) = -IDLAM(LKNT,1)+1
57601 C...Calculate width.
57602 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57603 & IDLAM(LKNT,3),XRESI)
57604 C...Resonance KF codes (1=I,2=J,3=K)
57606 KFR(2) = -IDLAM(LKNT,2)+1
57608 C...Calculate width.
57609 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57610 & IDLAM(LKNT,3),XRESJ)
57611 C...Resonance KF codes (1=I,2=J,3=K)
57612 KFR(1) = -IDLAM(LKNT,1)+1
57613 KFR(2) = -IDLAM(LKNT,2)+1
57615 C...Calculate width.
57616 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57617 & IDLAM(LKNT,3),XRESIJ)
57618 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
57619 XRESIJ = XRESIJ-XRESI-XRESJ
57623 C...CALCULATE TOTAL WIDTH
57624 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
57625 & + RVLJIK*RVLIJK * XRESIJ
57626 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57627 C...KINEMATICS CHECK
57628 IF (XLAM(LKNT).EQ.0D0) THEN
57632 C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
57633 C...Symmetry I<->J<->K.
57634 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
57635 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
57637 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
57638 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57639 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57641 C...Set coupling, and decay product masses on/off
57642 RVLAMC = 6. * GW2 * 5D-1
57643 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
57645 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
57647 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
57650 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
57651 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
57652 C...Collect symmetry factors
57653 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
57654 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
57655 & RVLAMC = 5D-1 * RVLAMC
57656 C...Resonance KF codes (1=I,2=J,3=K)
57657 KFR(1) = IDLAM(LKNT,1)-1
57660 C...Calculate width.
57661 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57662 & IDLAM(LKNT,3),XRESI)
57663 C...Resonance KF codes (1=I,2=J,3=K)
57665 KFR(2) = IDLAM(LKNT,2)-1
57667 C...Calculate width.
57668 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57669 & IDLAM(LKNT,3),XRESJ)
57670 C...Resonance KF codes (1=I,2=J,3=K)
57673 KFR(3) = IDLAM(LKNT,3)-1
57674 C...Calculate width.
57675 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57676 & IDLAM(LKNT,3),XRESK)
57677 C...Resonance KF codes (1=I,2=J,3=K)
57678 KFR(1) = IDLAM(LKNT,1)-1
57679 KFR(2) = IDLAM(LKNT,2)-1
57681 C...Calculate width.
57682 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57683 & IDLAM(LKNT,3),XRESIJ)
57684 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*(XRESI+XRESJ)) THEN
57685 XRESIJ = XRESI+XRESJ-XRESIJ
57689 C...Resonance KF codes (1=I,2=J,3=K)
57691 KFR(2) = IDLAM(LKNT,2)-1
57692 KFR(3) = IDLAM(LKNT,3)-1
57693 C...Calculate width.
57694 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57695 & IDLAM(LKNT,3),XRESJK)
57696 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*(XRESJ+XRESK)) THEN
57697 XRESJK = XRESJ+XRESK-XRESJK
57701 C...Resonance KF codes (1=I,2=J,3=K)
57702 KFR(1) = IDLAM(LKNT,1)-1
57704 KFR(3) = IDLAM(LKNT,3)-1
57705 C...Calculate width.
57706 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57707 & IDLAM(LKNT,3),XRESIK)
57708 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*(XRESI+XRESK)) THEN
57709 XRESIK = XRESI+XRESK-XRESIK
57713 C...CALCULATE TOTAL WIDTH
57715 & RVLIJK**2 * XRESI
57716 & + RVLJKI**2 * XRESJ
57717 & + RVLKIJ**2 * XRESK
57718 & + RVLIJK*RVLJKI * XRESIJ
57719 & + RVLIJK*RVLKIJ * XRESIK
57720 & + RVLJKI*RVLKIJ * XRESJK
57721 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
57722 C...KINEMATICS CHECK
57723 IF (XLAM(LKNT).EQ.0D0) THEN
57735 C*********************************************************************
57738 C...Calculates R-violating gluino decay widths.
57739 C...See BV part of PYRVCH for comments about the way the BV decay width
57740 C...is calculated. Same comments apply here.
57743 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
57745 C...Double precision and integer declarations.
57746 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57747 IMPLICIT INTEGER(I-N)
57748 C...Parameter statement to help give large particle numbers.
57749 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57750 &KEXCIT=4000000,KDIMEN=5000000)
57752 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57753 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57754 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57755 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57756 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57757 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57758 C...Local variables.
57759 DOUBLE PRECISION XLAM(0:400)
57760 INTEGER IDLAM(400,3), PYCOMP
57761 C...Information from main routine to PYRVGW
57762 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57764 C...Auxiliary variables needed for BV (RV Gauge STOre)
57765 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
57767 C...Running quark masses
57768 DOUBLE PRECISION RMQ(6)
57769 C...Decay product masses on/off
57771 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57774 C...IF LQD OR UDD TYPE R-VIOLATION ON.
57775 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
57779 C x=1-2 : Select A or B coupling (1:A ; 2:B)
57780 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57781 C 11-16:e,nu_e,mu,... not used here)
57782 C z=1-2 : Mass eigenstate number
57785 AB(1,I,1) = SFMIX(I,2)
57786 AB(1,I,2) = SFMIX(I,4)
57788 AB(2,I,1) = -SFMIX(I,1)
57789 AB(2,I,2) = -SFMIX(I,3)
57791 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
57793 IF (IMSS(52).GE.1) THEN
57794 C...STEP IN I,J,K USING SINGLE COUNTER
57796 C * GLUINO -> NUBAR_I + DBAR_J + D_K.
57798 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57799 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57800 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57802 C...Set coupling, and decay product masses on/off
57803 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57806 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
57807 C...Resonance KF codes (1=I,2=J,3=K)
57809 KFR(2) = -IDLAM(LKNT,2)
57810 KFR(3) = -IDLAM(LKNT,3)
57811 C...Calculate width.
57812 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57815 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57816 C...Charge conjugate mode.
57818 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
57819 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
57820 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
57821 XLAM(LKNT) = XLAM(LKNT-1)
57822 C...KINEMATICS CHECK
57823 IF (XLAM(LKNT).EQ.0D0) THEN
57827 C * GLUINO -> LEPTON+_I + UBAR_J + D_K
57829 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57830 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57831 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57833 C...Set coupling, and decay product masses on/off
57834 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57835 & **2* 5D-1 * GSTR2
57837 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
57838 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
57839 C...Resonance KF codes (1=I,2=J,3=K)
57841 KFR(2) = -IDLAM(LKNT,2)
57842 KFR(3) = -IDLAM(LKNT,3)
57843 C...Calculate width.
57844 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57846 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57847 C...Charge conjugate mode.
57849 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
57850 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
57851 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
57852 XLAM(LKNT) = XLAM(LKNT-1)
57853 C...KINEMATICS CHECK
57854 IF (XLAM(LKNT).EQ.0D0) THEN
57862 IF (IMSS(53).GE.1) THEN
57863 C...STEP IN I,J,K USING SINGLE COUNTER
57865 C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
57866 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
57868 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
57869 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57870 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57872 C...Set coupling, and decay product masses on/off. A factor of 2 for
57873 C...(N_C-1) has been used to cancel a factor 0.5.
57874 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57877 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
57878 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
57879 C...Resonance KF codes (1=I,2=J,3=K)
57880 KFR(1) = IDLAM(LKNT,1)
57883 C...Calculate width.
57884 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57886 C...Resonance KF codes (1=I,2=J,3=K)
57888 KFR(2) = IDLAM(LKNT,2)
57890 C...Calculate width.
57891 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57893 C...Resonance KF codes (1=I,2=J,3=K)
57896 KFR(3) = IDLAM(LKNT,3)
57897 C...Calculate width.
57898 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57900 C...Resonance KF codes (1=I,2=J,3=K)
57901 KFR(1) = IDLAM(LKNT,1)
57902 KFR(2) = IDLAM(LKNT,2)
57904 C...Calculate width.
57905 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57907 C...Calculate interference function. (Factor -1/2 to make up for factor
57909 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
57910 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
57914 C...Resonance KF codes (1=I,2=J,3=K)
57916 KFR(2) = IDLAM(LKNT,2)
57917 KFR(3) = IDLAM(LKNT,3)
57918 C...Calculate width.
57919 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57921 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*XRESJK) THEN
57922 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
57926 C...Resonance KF codes (1=I,2=J,3=K)
57927 KFR(1) = IDLAM(LKNT,1)
57929 KFR(3) = IDLAM(LKNT,3)
57930 C...Calculate width.
57931 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57933 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*XRESIK) THEN
57934 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
57938 C...Calculate total width (factor 1/2 from 1/(N_C-1))
57939 XLAM(LKNT) = XRESI + XRESJ + XRESK
57940 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
57942 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57943 C...Charge conjugate mode.
57945 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
57946 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
57947 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
57948 XLAM(LKNT) = XLAM(LKNT-1)
57949 C...KINEMATICS CHECK
57950 IF (XLAM(LKNT).EQ.0D0) THEN
57960 C*********************************************************************
57963 C...Auxiliary function to PYRVSF for calculating R-Violating
57964 C...sfermion widths. Though the decay products are most often treated
57965 C...as massless in the calculation, the kinematical boundary of phase
57966 C...space is tested using the true masses.
57967 C...MODE = 1: All decay products massive
57968 C...MODE = 2: Decay product 1 massless
57969 C...MODE = 3: Decay product 2 massless
57970 C...MODE = 4: All decay products massless
57972 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
57974 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
57975 IMPLICIT INTEGER (I-N)
57976 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57977 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57978 SAVE /PYDAT1/,/PYDAT2/
57979 DOUBLE PRECISION SM(3)
57980 INTEGER PYCOMP, KC(3)
57984 SM(1)=PMAS(KC(1),1)**2
57985 SM(2)=PMAS(KC(2),1)**2
57986 SM(3)=PMAS(KC(3),1)**2
57987 C...Kinematics check
57988 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
57992 C...CM momenta squared
57993 IF (MODE.EQ.1) THEN
57994 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
57995 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
57996 ELSE IF (MODE.EQ.2) THEN
57997 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
57998 ELSE IF (MODE.EQ.3) THEN
57999 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
58003 C...Calculate Width
58004 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
58008 C*********************************************************************
58011 C...Generalized Matrix Element for R-Violating 3-body widths.
58013 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
58015 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
58016 IMPLICIT INTEGER (I-N)
58017 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58018 &KEXCIT=4000000,KDIMEN=5000000)
58019 PARAMETER (EPS=1D-4)
58020 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58021 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58023 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58024 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58025 DOUBLE PRECISION XLIM(3,3)
58026 INTEGER KC(0:3), PYCOMP
58027 LOGICAL DCMASS, DCHECK(6)
58028 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
58032 KC(0) = PYCOMP(KFIN)
58033 KC(1) = PYCOMP(ID1)
58034 KC(2) = PYCOMP(ID2)
58035 KC(3) = PYCOMP(ID3)
58036 RMS(0) = PMAS(KC(0),1)
58037 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
58038 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
58039 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
58040 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
58041 XLIM(1,1)=(RMS(1)+RMS(2))**2
58042 XLIM(1,2)=(RMS(0)-RMS(3))**2
58043 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
58044 XLIM(2,1)=(RMS(2)+RMS(3))**2
58045 XLIM(2,2)=(RMS(0)-RMS(1))**2
58046 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
58047 XLIM(3,1)=(RMS(1)+RMS(3))**2
58048 XLIM(3,2)=(RMS(0)-RMS(2))**2
58049 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
58050 C...Check Phase Space
58051 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
58055 C...INITIALIZE RESONANCE INFORMATION
58058 IRES = 2*(JRES-1)+IMASS
58060 DCHECK(IRES) =.FALSE.
58061 C...NO RIGHT-HANDED NEUTRINOS
58062 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
58063 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
58064 & .KFR(JRES).EQ.0) GOTO 100
58065 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
58066 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
58067 INTRES(IRES,1) = IABS(KFR(JRES))
58068 INTRES(IRES,2) = IMASS
58069 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
58070 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
58074 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
58076 C...RESONANCE CONTRIBUTIONS
58077 C...(Only sum contributions where the resonance is off shell).
58078 C...Store whether diagram on/off in DCHECK.
58079 C...LOOP OVER MASS STATES
58082 IF(INTRES(IDR,1).NE.0) THEN
58084 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58085 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
58086 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58087 DCHECK(IDR) =.TRUE.
58088 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
58093 IF(INTRES(IDR,1).NE.0) THEN
58094 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58095 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58096 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58097 DCHECK(IDR) =.TRUE.
58098 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
58103 IF(INTRES(IDR,1).NE.0) THEN
58104 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58105 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58106 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58107 DCHECK(IDR) =.TRUE.
58108 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
58112 C... L-R INTERFERENCES
58113 C... (Only add contributions where both contributing diagrams
58114 C... are non-resonant).
58116 IF (DCHECK(1).AND.DCHECK(2)) THEN
58117 C...Bug corrected 11/12 2001. Skands.
58118 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
58119 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
58120 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
58124 IF (DCHECK(3).AND.DCHECK(4)) THEN
58125 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
58126 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
58127 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
58131 IF (DCHECK(5).AND.DCHECK(6)) THEN
58132 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
58133 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
58134 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
58136 C... TRUE INTERFERENCES
58137 C... (Only add contributions where both contributing diagrams
58138 C... are non-resonant).
58140 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
58145 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58146 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
58147 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58148 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58153 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58154 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
58155 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58156 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58161 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58162 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
58163 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58164 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58172 C*********************************************************************
58175 C...Function to integrate resonance contributions
58177 FUNCTION PYRVI1(ID1,ID2,ID3)
58180 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
58181 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58182 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58183 LOGICAL MFLAG,DCMASS
58184 EXTERNAL PYRVG1,PYGAUS
58185 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58187 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58188 SAVE/PYRVNV/,/PYRVPM/
58189 C...Initialize mass and width information
58195 RESM(1)= RES(IDR,1)
58196 RESW(1)= RES(IDR,2)
58197 C...A->B and B->A for antisparticles
58198 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58199 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58200 C...Integration boundaries and mass flag
58201 LO = (RM(1)+RM(2))**2
58202 HI = (RM(0)-RM(3))**2
58204 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
58208 C*********************************************************************
58211 C...Function to integrate L-R interference contributions
58213 FUNCTION PYRVI2(ID1,ID2,ID3)
58216 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
58217 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58218 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58219 LOGICAL MFLAG,DCMASS
58220 EXTERNAL PYRVG2,PYGAUS
58221 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58223 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58224 SAVE/PYRVNV/,/PYRVPM/
58225 C...Initialize mass and width information
58231 RESM(1)= RES(IDR,1)
58232 RESW(1)= RES(IDR,2)
58233 RESM(2)= RES(IDR+1,1)
58234 RESW(2)= RES(IDR+1,2)
58235 C...A->B and B->A for antisparticles
58236 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58237 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58238 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
58239 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
58240 C...Boundaries and mass flag
58241 LO = (RM(1)+RM(2))**2
58242 HI = (RM(0)-RM(3))**2
58244 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
58248 C*********************************************************************
58251 C...Function to integrate true interference contributions
58253 FUNCTION PYRVI3(ID1,ID2,ID3)
58256 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
58257 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58258 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58259 LOGICAL MFLAG,DCMASS
58260 EXTERNAL PYRVG3,PYGAUS
58261 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58263 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58264 SAVE/PYRVNV/,/PYRVPM/
58265 C...Initialize mass and width information
58271 RESM(1)= RES(IDR,1)
58272 RESW(1)= RES(IDR,2)
58273 RESM(2)= RES(IDR2,1)
58274 RESW(2)= RES(IDR2,2)
58275 C...A -> B and B -> A for antisparticles
58276 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58277 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58278 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
58279 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
58280 C...Boundaries and mass flag
58281 LO = (RM(1)+RM(2))**2
58282 HI = (RM(0)-RM(3))**2
58284 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
58288 C*********************************************************************
58291 C...Integrand for resonance contributions
58296 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58297 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
58298 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
58301 RVR = PYRVR(X,RESM(1),RESW(1))
58302 C1 = 2D0*SQRT(MAX(0D0,X))
58303 IF (.NOT.MFLAG) THEN
58305 E3 = (RM(0)**2-X)/C1
58307 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
58309 E2 = (X-RM(1)**2+RM(2)**2)/C1
58310 E3 = (RM(0)**2-X-RM(3)**2)/C1
58311 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58312 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58313 DELTAY = 4D0*SR1*SR2
58314 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
58315 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
58316 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
58321 C*********************************************************************
58324 C...Integrand for L-R interference contributions
58329 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58330 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
58331 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
58334 C1 = 2D0*SQRT(MAX(0D0,X))
58335 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
58336 IF (.NOT.MFLAG) THEN
58338 E3 = (RM(0)**2-X)/C1
58340 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
58342 E2 = (X-RM(1)**2+RM(2)**2)/C1
58343 E3 = (RM(0)**2-X-RM(3)**2)/C1
58344 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58345 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58346 DELTAY = 4D0*SR1*SR2
58347 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
58348 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
58349 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
58354 C*********************************************************************
58357 C...Function to do Y integration over true interference contributions
58362 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58363 C...Second Dalitz variable for PYRVG4
58365 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
58366 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
58367 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
58369 EXTERNAL PYGAU2,PYRVG4
58370 SAVE/PYRVPM/,/PYG2DX/
58372 C1=2D0*SQRT(MAX(1D-9,X))
58374 IF (.NOT.MFLAG) THEN
58376 E3 = (RM(0)**2-X)/C1
58380 E2 = (X-RM(1)**2+RM(2)**2)/C1
58381 E3 = (RM(0)**2-X-RM(3)**2)/C1
58383 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58384 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58385 YMIN = SQ1-(SR1+SR2)**2
58386 YMAX = SQ1-(SR1-SR2)**2
58388 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
58392 C*********************************************************************
58395 C...Integrand for true intereference contributions
58400 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58402 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
58404 SAVE /PYRVPM/,/PYG2DX/
58406 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
58407 IF (.NOT.MFLAG) THEN
58408 PYRVG4 = RVS*B(1)*B(2)*X*Y
58410 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
58411 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
58412 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
58413 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
58418 C*********************************************************************
58421 C...Breit-Wigner for resonance contributions
58423 FUNCTION PYRVR(Mab2,RM,RW)
58426 DOUBLE PRECISION Mab2,RM,RW,PYRVR
58427 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
58431 C*********************************************************************
58434 C...Interference function
58436 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
58439 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
58440 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
58445 C*********************************************************************
58448 C...Stores one parton/particle in commonblock PYJETS.
58450 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
58452 C...Double precision and integer declarations.
58453 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58454 IMPLICIT INTEGER(I-N)
58455 INTEGER PYK,PYCHGE,PYCOMP
58457 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58458 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58459 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58460 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58462 C...Standard checks.
58464 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58465 IPA=MAX(1,IABS(IP))
58466 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
58467 &'(PY1ENT:) writing outside PYJETS memory')
58469 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
58471 C...Find mass. Reset K, P and V vectors.
58473 IF(MSTU(10).EQ.1) PM=P(IPA,5)
58474 IF(MSTU(10).GE.2) PM=PYMASS(KF)
58481 C...Store parton/particle in K and P vectors.
58483 IF(IP.LT.0) K(IPA,1)=2
58486 P(IPA,4)=MAX(PE,PM)
58487 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
58488 P(IPA,1)=PA*SIN(THE)*COS(PHI)
58489 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
58490 P(IPA,3)=PA*COS(THE)
58492 C...Set N. Optionally fragment/decay.
58494 IF(IP.EQ.0) CALL PYEXEC
58499 C*********************************************************************
58502 C...Stores two partons/particles in their CM frame,
58503 C...with the first along the +z axis.
58505 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
58507 C...Double precision and integer declarations.
58508 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58509 IMPLICIT INTEGER(I-N)
58510 INTEGER PYK,PYCHGE,PYCOMP
58512 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58513 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58514 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58515 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58517 C...Standard checks.
58519 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58520 IPA=MAX(1,IABS(IP))
58521 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
58522 &'(PY2ENT:) writing outside PYJETS memory')
58525 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
58526 &'(PY2ENT:) unknown flavour code')
58528 C...Find masses. Reset K, P and V vectors.
58530 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58531 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58533 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58534 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58543 C...Check flavours.
58544 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58545 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58546 IF(MSTU(19).EQ.1) THEN
58549 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
58550 & '(PY2ENT:) unphysical flavour combination')
58555 C...Store partons/particles in K vectors for normal case.
58558 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
58561 C...Store partons in K vectors for parton shower evolution.
58565 K(IPA,4)=MSTU(5)*(IPA+1)
58567 K(IPA+1,4)=MSTU(5)*IPA
58568 K(IPA+1,5)=K(IPA+1,4)
58571 C...Check kinematics and store partons/particles in P vectors.
58572 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
58573 &'(PY2ENT:) energy smaller than sum of masses')
58574 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
58577 P(IPA,4)=SQRT(PM1**2+PA**2)
58580 P(IPA+1,4)=SQRT(PM2**2+PA**2)
58583 C...Set N. Optionally fragment/decay.
58585 IF(IP.EQ.0) CALL PYEXEC
58590 C*********************************************************************
58593 C...Stores three partons or particles in their CM frame,
58594 C...with the first along the +z axis and the third in the (x,z)
58595 C...plane with x > 0.
58597 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
58599 C...Double precision and integer declarations.
58600 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58601 IMPLICIT INTEGER(I-N)
58602 INTEGER PYK,PYCHGE,PYCOMP
58604 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58605 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58606 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58607 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58609 C...Standard checks.
58611 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58612 IPA=MAX(1,IABS(IP))
58613 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
58614 &'(PY3ENT:) writing outside PYJETS memory')
58618 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
58619 &'(PY3ENT:) unknown flavour code')
58621 C...Find masses. Reset K, P and V vectors.
58623 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58624 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58626 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58627 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58629 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
58630 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
58639 C...Check flavours.
58640 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58641 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58642 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
58643 IF(MSTU(19).EQ.1) THEN
58645 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
58646 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
58647 & KQ1+KQ3.EQ.4)) THEN
58649 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
58655 C...Store partons/particles in K vectors for normal case.
58658 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
58660 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
58663 C...Store partons in K vectors for parton shower evolution.
58669 IF(KQ1.EQ.-1) KCS=5
58670 K(IPA,KCS)=MSTU(5)*(IPA+1)
58671 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
58672 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
58673 K(IPA+1,9-KCS)=MSTU(5)*IPA
58674 K(IPA+2,KCS)=MSTU(5)*IPA
58675 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
58678 C...Check kinematics.
58680 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
58681 &0.5D0*X3*PECM.LE.PM3) MKERR=1
58682 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
58683 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
58684 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
58685 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
58686 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
58687 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
58688 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
58689 IF(MKERR.NE.0) CALL PYERRM(13,
58690 &'(PY3ENT:) unphysical kinematical variable setup')
58692 C...Store partons/particles in P vectors.
58694 P(IPA,4)=SQRT(PA1**2+PM1**2)
58696 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
58697 P(IPA+2,3)=PA3*CTHE3
58698 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
58700 P(IPA+1,1)=-P(IPA+2,1)
58701 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
58702 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
58705 C...Set N. Optionally fragment/decay.
58707 IF(IP.EQ.0) CALL PYEXEC
58712 C*********************************************************************
58715 C...Stores four partons or particles in their CM frame, with
58716 C...the first along the +z axis, the last in the xz plane with x > 0
58717 C...and the second having y < 0 and y > 0 with equal probability.
58719 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
58721 C...Double precision and integer declarations.
58722 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58723 IMPLICIT INTEGER(I-N)
58724 INTEGER PYK,PYCHGE,PYCOMP
58726 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58727 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58728 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58729 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58731 C...Standard checks.
58733 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58734 IPA=MAX(1,IABS(IP))
58735 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
58736 &'(PY4ENT:) writing outside PYJETS momory')
58741 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
58742 &'(PY4ENT:) unknown flavour code')
58744 C...Find masses. Reset K, P and V vectors.
58746 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58747 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58749 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58750 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58752 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
58753 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
58755 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
58756 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
58765 C...Check flavours.
58766 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58767 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58768 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
58769 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
58770 IF(MSTU(19).EQ.1) THEN
58772 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
58773 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
58774 & KQ1+KQ4.EQ.4)) THEN
58775 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
58778 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
58785 C...Store partons/particles in K vectors for normal case.
58788 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
58790 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
58793 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
58796 C...Store partons for parton shower evolution from q-g-g-qbar or
58798 ELSEIF(KQ1+KQ2.NE.0) THEN
58804 IF(KQ1.EQ.-1) KCS=5
58805 K(IPA,KCS)=MSTU(5)*(IPA+1)
58806 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
58807 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
58808 K(IPA+1,9-KCS)=MSTU(5)*IPA
58809 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
58810 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
58811 K(IPA+3,KCS)=MSTU(5)*IPA
58812 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
58814 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
58820 K(IPA,4)=MSTU(5)*(IPA+1)
58822 K(IPA+1,4)=MSTU(5)*IPA
58823 K(IPA+1,5)=K(IPA+1,4)
58824 K(IPA+2,4)=MSTU(5)*(IPA+3)
58825 K(IPA+2,5)=K(IPA+2,4)
58826 K(IPA+3,4)=MSTU(5)*(IPA+2)
58827 K(IPA+3,5)=K(IPA+3,4)
58830 C...Check kinematics.
58832 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
58833 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
58835 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
58836 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
58837 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
58838 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
58839 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
58840 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
58841 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
58842 STHE4=SQRT(1D0-CTHE4**2)
58843 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
58844 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
58845 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
58846 STHE2=SQRT(1D0-CTHE2**2)
58847 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
58848 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
58849 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
58850 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
58851 IF(MKERR.EQ.1) CALL PYERRM(13,
58852 &'(PY4ENT:) unphysical kinematical variable setup')
58854 C...Store partons/particles in P vectors.
58856 P(IPA,4)=SQRT(PA1**2+PM1**2)
58858 P(IPA+3,1)=PA4*STHE4
58859 P(IPA+3,3)=PA4*CTHE4
58860 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
58862 P(IPA+1,1)=PA2*STHE2*CPHI2
58863 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
58864 P(IPA+1,3)=PA2*CTHE2
58865 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
58867 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
58868 P(IPA+2,2)=-P(IPA+1,2)
58869 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
58870 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
58873 C...Set N. Optionally fragment/decay.
58875 IF(IP.EQ.0) CALL PYEXEC
58880 C*********************************************************************
58883 C...An interface from a two-fermion generator to include
58884 C...parton showers and hadronization.
58886 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
58888 C...Double precision and integer declarations.
58889 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58890 IMPLICIT INTEGER(I-N)
58891 INTEGER PYK,PYCHGE,PYCOMP
58893 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58894 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58895 SAVE /PYJETS/,/PYDAT1/
58897 DIMENSION IJOIN(2),INTAU(2)
58899 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
58905 C...Loop through entries and pick up all final fermions/antifermions.
58909 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
58911 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
58912 IF(K(I,2).GT.0) THEN
58916 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
58922 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
58928 C...Check that event is arranged according to conventions.
58929 IF(I1.EQ.0.OR.I2.EQ.0) THEN
58930 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
58933 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
58936 C...Check whether fermion pair is quarks or leptons.
58937 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
58939 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
58942 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
58945 C...Decide whether to allow or not photon radiation in showers.
58947 IF(IRAD.EQ.0) MSTJ(41)=1
58949 C...Do colour joining and parton showers.
58952 IF(IQL12.EQ.1) THEN
58955 CALL PYJOIN(2,IJOIN)
58957 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
58958 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
58959 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
58960 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
58963 C...Do fragmentation and decays. Possibly except tau decay.
58967 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
58981 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
58989 C*********************************************************************
58992 C...An interface from a four-fermion generator to include
58993 C...parton showers and hadronization.
58995 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
58997 C...Double precision and integer declarations.
58998 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58999 IMPLICIT INTEGER(I-N)
59000 INTEGER PYK,PYCHGE,PYCOMP
59002 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59003 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59004 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59005 COMMON/PYINT1/MINT(400),VINT(400)
59006 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
59008 DIMENSION IJOIN(2),INTAU(4)
59010 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59016 C...Loop through entries and pick up all final fermions/antifermions.
59022 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59024 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59025 IF(K(I,2).GT.0) THEN
59028 ELSEIF(I3.EQ.0) THEN
59031 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
59036 ELSEIF(I4.EQ.0) THEN
59039 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
59045 C...Check that event is arranged according to conventions.
59046 IF(I3.EQ.0.OR.I4.EQ.0) THEN
59047 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
59049 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59050 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
59053 C...Check which fermion pairs are quarks and which leptons.
59054 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59056 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59059 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
59061 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59063 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59066 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
59069 C...Decide whether to allow or not photon radiation in showers.
59071 IF(IRAD.EQ.0) MSTJ(41)=1
59073 C...Decide on dipole pairing.
59078 IF(IQL12.EQ.IQL34) THEN
59081 DELTA=ATOTSQ-A1SQ-A2SQ
59082 IF(ISTRAT.EQ.1) THEN
59083 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
59084 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
59085 ELSEIF(ISTRAT.EQ.2) THEN
59086 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
59087 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
59089 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
59095 C...If colour reconnection then bookkeep W+W- or Z0Z0
59096 C...and copy q qbar q qbar consecutively.
59097 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59106 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
59110 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
59124 P(N+1,J)=P(IP1,J)+P(IP2,J)
59125 P(N+2,J)=P(IP3,J)+P(IP4,J)
59137 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59139 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59145 C...Remove original q qbar q qbar and update counters.
59146 K(IP1,1)=K(IP1,1)+10
59147 K(IP2,1)=K(IP2,1)+10
59148 K(IP3,1)=K(IP3,1)+10
59149 K(IP4,1)=K(IP4,1)+10
59160 C...Do colour joinings and parton showers.
59161 IF(IQL12.EQ.1) THEN
59164 CALL PYJOIN(2,IJOIN)
59166 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59167 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59168 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59169 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59172 IF(IQL34.EQ.1) THEN
59175 CALL PYJOIN(2,IJOIN)
59177 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59178 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59179 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59180 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59183 C...Optionally do colour reconnection.
59186 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59187 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
59191 C...Do fragmentation and decays. Possibly except tau decay.
59195 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59209 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59217 C*********************************************************************
59220 C...An interface from a six-fermion generator to include
59221 C...parton showers and hadronization.
59223 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
59225 C...Double precision and integer declarations.
59226 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59227 IMPLICIT INTEGER(I-N)
59228 INTEGER PYK,PYCHGE,PYCOMP
59230 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59231 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59232 SAVE /PYJETS/,/PYDAT1/
59234 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
59236 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59242 C...Loop through entries and pick up all final fermions/antifermions.
59250 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59252 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59253 IF(K(I,2).GT.0) THEN
59256 ELSEIF(I3.EQ.0) THEN
59258 ELSEIF(I5.EQ.0) THEN
59261 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
59266 ELSEIF(I4.EQ.0) THEN
59268 ELSEIF(I6.EQ.0) THEN
59271 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
59277 C...Check that event is arranged according to conventions.
59278 IF(I5.EQ.0.OR.I6.EQ.0) THEN
59279 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
59281 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
59282 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
59285 C...Check which fermion pairs are quarks and which leptons.
59286 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59288 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59291 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
59293 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59295 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59298 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
59300 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
59302 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
59305 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
59308 C...Decide whether to allow or not photon radiation in showers.
59310 IF(IRAD.EQ.0) MSTJ(41)=1
59312 C...Allow dipole pairings only among leptons and quarks separately.
59315 IF(IQL34.EQ.IQL56) P13D=P13
59317 IF(IQL12.EQ.IQL34) P21D=P21
59319 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
59321 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
59323 IF(IQL12.EQ.IQL56) P32D=P32
59325 C...Decide whether t+tbar.
59327 IF(PYR(0).LT.PTOP) THEN
59330 C...If t+tbar: reconstruct t's.
59336 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
59337 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
59345 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
59347 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
59351 C...If t+tbar: colour join t's and let them shower.
59354 CALL PYJOIN(2,IJOIN)
59355 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
59356 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
59357 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
59359 C...If t+tbar: pick up the t's after shower.
59363 IF(K(I,2).EQ.6) ITNEW=I
59364 IF(K(I,2).EQ.-6) ITBNEW=I
59367 C...If t+tbar: loop over two top systems.
59382 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
59383 & '(PY6FRM:) not b in t decay')
59385 C...If t+tbar: find boost from original to new top frame.
59387 BETAO(J)=P(ITO,J)/P(ITO,4)
59388 BETAN(J)=P(ITN,J)/P(ITN,4)
59391 C...If t+tbar: boost copy of b by t shower and connect it in colour.
59401 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59402 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59403 K(IB,4)=MSTU(5)*ITN
59404 K(IB,5)=MSTU(5)*ITN
59405 K(ITN,4)=K(ITN,4)+IB
59406 K(ITN,5)=K(ITN,5)+IB
59407 K(ITN,1)=K(ITN,1)+10
59408 K(IBO,1)=K(IBO,1)+10
59410 C...If t+tbar: construct W recoiling against b.
59418 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
59419 IF(IABS(KCHW).EQ.3) THEN
59420 K(IW,2)=ISIGN(24,KCHW)
59422 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
59426 C...If t+tbar: construct W momentum, including boost by t shower.
59428 P(IW,J)=P(IW1,J)+P(IW2,J)
59430 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
59432 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59433 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59435 C...If t+tbar: boost b and W to top rest frame.
59437 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
59439 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59440 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59442 C...If t+tbar: let b shower and pick up modified W.
59443 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
59444 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
59445 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
59447 IF(IABS(K(I,2)).EQ.24) IWM=I
59450 C...If t+tbar: take copy of W decay products.
59459 K(IW1,1)=K(IW1,1)+10
59460 K(IW2,1)=K(IW2,1)+10
59461 K(IWM,1)=K(IWM,1)+10
59475 C...If t+tbar: boost W decay products, first by effects of t shower,
59476 C...then by those of b shower. b and its shower simple boost back.
59477 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59478 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59479 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59480 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
59481 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
59482 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
59483 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
59484 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
59485 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
59489 C...Decide on dipole pairing.
59493 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
59494 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
59498 ELSEIF(PRN.LT.P12D+P13D) THEN
59502 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
59506 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
59510 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
59520 C...Do colour joinings and parton showers
59521 C...(except ones already made for t+tbar).
59523 IF(IQL12.EQ.1) THEN
59526 CALL PYJOIN(2,IJOIN)
59528 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59529 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59530 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59531 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59534 IF(IQL34.EQ.1) THEN
59537 CALL PYJOIN(2,IJOIN)
59539 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59540 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59541 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59542 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59544 IF(IQL56.EQ.1) THEN
59547 CALL PYJOIN(2,IJOIN)
59549 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
59550 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
59551 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
59552 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
59555 C...Do fragmentation and decays. Possibly except tau decay.
59559 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59573 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59581 C*********************************************************************
59584 C...An interface from a four-parton generator to include
59585 C...parton showers and hadronization.
59587 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
59589 C...Double precision and integer declarations.
59590 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59591 IMPLICIT INTEGER(I-N)
59592 INTEGER PYK,PYCHGE,PYCOMP
59594 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59595 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59596 SAVE /PYJETS/,/PYDAT1/
59598 DIMENSION IJOIN(2),PTOT(4),BETA(3)
59600 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59606 C...Loop through entries and pick up all final partons.
59612 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59614 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
59615 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
59618 ELSEIF(I3.EQ.0) THEN
59621 CALL PYERRM(16,'(PY4JET:) more than two quarks')
59623 ELSEIF(K(I,2).LT.0) THEN
59626 ELSEIF(I4.EQ.0) THEN
59629 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
59634 ELSEIF(I4.EQ.0) THEN
59637 CALL PYERRM(16,'(PY4JET:) more than two gluons')
59643 C...Check that event is arranged according to conventions.
59644 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
59645 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
59647 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59648 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
59651 C...Check whether second pair are quarks or gluons.
59652 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59654 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
59657 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
59660 C...Boost partons to their cm frame.
59662 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
59664 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
59666 BETA(J)=PTOT(J)/PTOT(4)
59668 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59669 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59670 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59671 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59674 C...Decide and set up shower history for q qbar q' qbar' events.
59675 IF(IQG34.EQ.1) THEN
59676 W1=PY4JTW(0,I1,I3,I4)
59677 W2=PY4JTW(0,I2,I3,I4)
59678 IF(W1.GT.PYR(0)*(W1+W2)) THEN
59679 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
59681 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
59684 C...Decide and set up shower history for q qbar g g events.
59686 W1=PY4JTW(I1,I3,I2,I4)
59687 W2=PY4JTW(I1,I4,I2,I3)
59688 W3=PY4JTW(0,I3,I1,I4)
59689 W4=PY4JTW(0,I4,I1,I3)
59690 W5=PY4JTW(0,I3,I2,I4)
59691 W6=PY4JTW(0,I4,I2,I3)
59692 W7=PY4JTW(0,I1,I3,I4)
59693 W8=PY4JTW(0,I2,I3,I4)
59694 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
59696 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
59697 ELSEIF(W1+W2.GT.WR) THEN
59698 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
59699 ELSEIF(W1+W2+W3.GT.WR) THEN
59700 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
59701 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
59702 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
59703 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
59704 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
59705 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
59706 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
59707 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
59708 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
59710 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
59714 C...Boost back original partons and mark them as deleted.
59715 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
59716 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
59717 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
59718 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
59724 C...Rotate shower initiating partons to be along z axis.
59725 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
59726 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
59727 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
59728 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
59730 C...Set up copy of shower initiating partons as on mass shell.
59740 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
59751 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
59752 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
59754 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
59756 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
59759 C...Decide whether to allow or not photon radiation in showers.
59760 C...Connect up colours.
59762 IF(IRAD.EQ.0) MSTJ(41)=1
59765 CALL PYJOIN(2,IJOIN)
59767 C...Decide on maximum virtuality and do parton shower.
59768 IF(PMAX.LT.PARJ(82)) THEN
59773 CALL PYSHOW(NSAV+1,-100,PQMAX)
59775 C...Rotate and boost back system.
59776 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
59778 C...Do fragmentation and decays.
59781 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59790 C*********************************************************************
59793 C...Auxiliary to PY4JET, to evaluate weight of configuration.
59795 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
59797 C...Double precision and integer declarations.
59798 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59799 IMPLICIT INTEGER(I-N)
59800 INTEGER PYK,PYCHGE,PYCOMP
59802 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59805 C...First case: when both original partons radiate.
59806 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
59809 P(N+1,J)=P(IA1,J)+P(IA2,J)
59810 P(N+2,J)=P(IA3,J)+P(IA4,J)
59812 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59814 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59816 Z1=P(IA1,4)/P(N+1,4)
59817 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
59818 Z2=P(IA3,4)/P(N+2,4)
59819 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
59821 C...Second case: when one original parton radiates to three.
59822 C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
59825 P(N+2,J)=P(IA3,J)+P(IA4,J)
59826 P(N+1,J)=P(N+2,J)+P(IA2,J)
59828 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59830 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59832 IF(K(IA2,2).EQ.21) THEN
59833 Z1=P(N+2,4)/P(N+1,4)
59834 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
59837 Z1=P(IA2,4)/P(N+1,4)
59838 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
59841 Z2=P(IA3,4)/P(N+2,4)
59842 IF(K(IA2,2).EQ.21) THEN
59843 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
59845 ELSEIF(K(IA3,2).EQ.21) THEN
59846 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
59848 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
59858 C*********************************************************************
59861 C...Auxiliary to PY4JET, to set up chosen configuration.
59863 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
59865 C...Double precision and integer declarations.
59866 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59867 IMPLICIT INTEGER(I-N)
59868 INTEGER PYK,PYCHGE,PYCOMP
59870 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59882 C...First case: when both original partons radiate.
59883 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
59886 C...Set up flavour and history pointers for new partons.
59904 C...Set up momenta for new partons.
59906 P(N+1,J)=P(IA1,J)+P(IA2,J)
59907 P(N+2,J)=P(IA3,J)+P(IA4,J)
59913 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59915 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59917 QMAX=MIN(P(N+1,5),P(N+2,5))
59919 C...Second case: q radiates twice.
59920 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
59921 C...IA5=N+2 does not radiate.
59922 ELSEIF(K(IA2,2).EQ.21) THEN
59924 C...Set up flavour and history pointers for new partons.
59942 C...Set up momenta for new partons.
59944 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
59946 P(N+3,J)=P(IA3,J)+P(IA4,J)
59951 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59953 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
59957 C...Third case: q radiates g, g branches.
59958 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
59959 C...IA5=N+2 does not radiate.
59962 C...Set up flavour and history pointers for new partons.
59980 C...Set up momenta for new partons.
59982 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
59985 P(N+4,J)=P(IA3,J)+P(IA4,J)
59989 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59991 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
60001 C*********************************************************************
60004 C...Connects a sequence of partons with colour flow indices,
60005 C...as required for subsequent shower evolution (or other operations).
60007 SUBROUTINE PYJOIN(NJOIN,IJOIN)
60009 C...Double precision and integer declarations.
60010 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60011 IMPLICIT INTEGER(I-N)
60012 INTEGER PYK,PYCHGE,PYCOMP
60014 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60015 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60016 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60017 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
60021 C...Check that partons are of right types to be connected.
60022 IF(NJOIN.LT.2) GOTO 120
60026 IF(I.LE.0.OR.I.GT.N) GOTO 120
60027 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
60029 IF(KC.EQ.0) GOTO 120
60030 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
60031 IF(KQ.EQ.0) GOTO 120
60032 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
60033 IF(KQ.NE.2) KQSUM=KQSUM+KQ
60034 IF(IJN.EQ.1) KQS=KQ
60036 IF(KQSUM.NE.0) GOTO 120
60038 C...Connect the partons sequentially (closing for gluon loop).
60040 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
60044 IF(IJN.NE.1) IP=IJOIN(IJN-1)
60045 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
60046 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
60047 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
60048 K(I,KCS)=MSTU(5)*IN
60049 K(I,9-KCS)=MSTU(5)*IP
60050 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
60051 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
60054 C...Error exit: no action taken.
60056 120 CALL PYERRM(12,
60057 &'(PYJOIN:) given entries can not be joined by one string')
60062 C*********************************************************************
60065 C...Sets values of commonblock variables.
60067 SUBROUTINE PYGIVE(CHIN)
60069 C...Double precision and integer declarations.
60070 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60071 IMPLICIT INTEGER(I-N)
60072 INTEGER PYK,PYCHGE,PYCOMP
60074 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60075 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60076 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60077 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60078 COMMON/PYDAT4/CHAF(500,2)
60080 COMMON/PYDATR/MRPY(6),RRPY(100)
60081 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
60082 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60083 COMMON/PYINT1/MINT(400),VINT(400)
60084 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
60085 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
60086 COMMON/PYINT4/MWID(500),WIDS(500,5)
60087 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
60088 COMMON/PYINT6/PROC(0:500)
60090 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
60091 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
60093 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
60094 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
60095 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
60096 COMMON/PYPUED/IUED(0:99),RUED(0:99)
60097 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
60098 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
60099 &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/
60100 C...Local arrays and character variables.
60101 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
60102 &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10,
60104 DIMENSION MSVAR(56,8)
60106 C...For each variable to be translated give: name,
60107 C...integer/real/character, no. of indices, lower&upper index bounds.
60108 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
60109 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
60110 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
60111 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
60112 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
60113 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
60114 &'ITCM','RTCM','IUED','RUED'/
60115 DATA ((MSVAR(I,J),J=1,8),I=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0,
60116 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
60117 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60118 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
60119 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
60120 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
60121 &1,1,1,6,4*0, 2,1,1,100,4*0,
60122 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
60123 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60124 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
60125 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
60126 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
60127 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
60128 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
60129 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
60130 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
60131 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
60132 &1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
60133 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60134 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
60136 C...Length of character variable. Subdivide it into instructions.
60137 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
60138 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
60142 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
60145 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
60147 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
60152 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
60154 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
60156 C...Send off decay-mode on/off commands to PYONOF.
60159 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
60161 IF(IONOF.EQ.1) THEN
60166 C...Peel off any text following exclamation mark.
60168 DO 140 LLOW2=LHIG2,1,-1
60169 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
60171 IF(LBIT.EQ.0) RETURN
60173 C...Identify commonblock variable.
60176 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
60177 &LNAM.LE.6) GOTO 150
60178 CHNAM=CHBIT(1:LNAM-1)//' '
60179 DO 170 LCOM=1,LNAM-1
60181 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
60182 & CHALP(2)(LALP:LALP)
60187 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
60190 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
60192 IF(LLOW.LT.LTOT) GOTO 120
60196 C...Identify any indices.
60201 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
60204 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
60206 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
60207 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
60208 & IVAR.EQ.37)) THEN
60209 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
60210 READ(CHIND,'(I8)') KF
60212 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
60214 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
60217 IF(LLOW.LT.LTOT) GOTO 120
60220 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60221 READ(CHIND,'(I8)') I1
60224 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
60227 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
60230 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
60232 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60233 READ(CHIND,'(I8)') I2
60235 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
60238 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
60241 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
60243 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60244 READ(CHIND,'(I8)') I3
60249 C...Check that indices allowed.
60251 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
60252 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
60254 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
60256 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
60258 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
60260 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
60263 IF(LLOW.LT.LTOT) GOTO 120
60267 C...Save old value of variable.
60270 ELSEIF(IVAR.EQ.2) THEN
60272 ELSEIF(IVAR.EQ.3) THEN
60274 ELSEIF(IVAR.EQ.4) THEN
60276 ELSEIF(IVAR.EQ.5) THEN
60278 ELSEIF(IVAR.EQ.6) THEN
60280 ELSEIF(IVAR.EQ.7) THEN
60282 ELSEIF(IVAR.EQ.8) THEN
60284 ELSEIF(IVAR.EQ.9) THEN
60286 ELSEIF(IVAR.EQ.10) THEN
60288 ELSEIF(IVAR.EQ.11) THEN
60290 ELSEIF(IVAR.EQ.12) THEN
60292 ELSEIF(IVAR.EQ.13) THEN
60294 ELSEIF(IVAR.EQ.14) THEN
60296 ELSEIF(IVAR.EQ.15) THEN
60298 ELSEIF(IVAR.EQ.16) THEN
60300 ELSEIF(IVAR.EQ.17) THEN
60301 CHOLD=CHAF(I1,I2)(1:8)
60302 ELSEIF(IVAR.EQ.18) THEN
60304 ELSEIF(IVAR.EQ.19) THEN
60306 ELSEIF(IVAR.EQ.20) THEN
60308 ELSEIF(IVAR.EQ.21) THEN
60310 ELSEIF(IVAR.EQ.22) THEN
60312 ELSEIF(IVAR.EQ.23) THEN
60314 ELSEIF(IVAR.EQ.24) THEN
60316 ELSEIF(IVAR.EQ.25) THEN
60318 ELSEIF(IVAR.EQ.26) THEN
60320 ELSEIF(IVAR.EQ.27) THEN
60322 ELSEIF(IVAR.EQ.28) THEN
60324 ELSEIF(IVAR.EQ.29) THEN
60326 ELSEIF(IVAR.EQ.30) THEN
60328 ELSEIF(IVAR.EQ.31) THEN
60330 ELSEIF(IVAR.EQ.32) THEN
60332 ELSEIF(IVAR.EQ.33) THEN
60333 IOLD=ICOL(I1,I2,I3)
60334 ELSEIF(IVAR.EQ.34) THEN
60336 ELSEIF(IVAR.EQ.35) THEN
60338 ELSEIF(IVAR.EQ.36) THEN
60340 ELSEIF(IVAR.EQ.37) THEN
60342 ELSEIF(IVAR.EQ.38) THEN
60344 ELSEIF(IVAR.EQ.39) THEN
60346 ELSEIF(IVAR.EQ.40) THEN
60348 ELSEIF(IVAR.EQ.41) THEN
60350 ELSEIF(IVAR.EQ.42) THEN
60351 ROLD=SIGT(I1,I2,I3)
60352 ELSEIF(IVAR.EQ.43) THEN
60354 ELSEIF(IVAR.EQ.44) THEN
60356 ELSEIF(IVAR.EQ.45) THEN
60358 ELSEIF(IVAR.EQ.46) THEN
60360 ELSEIF(IVAR.EQ.47) THEN
60362 ELSEIF(IVAR.EQ.48) THEN
60364 ELSEIF(IVAR.EQ.49) THEN
60366 ELSEIF(IVAR.EQ.50) THEN
60367 ROLD=RVLAM(I1,I2,I3)
60368 ELSEIF(IVAR.EQ.51) THEN
60369 ROLD=RVLAMP(I1,I2,I3)
60370 ELSEIF(IVAR.EQ.52) THEN
60371 ROLD=RVLAMB(I1,I2,I3)
60372 ELSEIF(IVAR.EQ.53) THEN
60374 ELSEIF(IVAR.EQ.54) THEN
60376 ELSEIF(IVAR.EQ.55) THEN
60378 ELSEIF(IVAR.EQ.56) THEN
60382 C...Print current value of variable. Loop back.
60383 IF(LNAM.GE.LBIT) THEN
60385 CHBIT(15:60)=' has the value '
60386 IF(MSVAR(IVAR,1).EQ.1) THEN
60387 WRITE(CHBIT(51:60),'(I10)') IOLD
60388 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60389 WRITE(CHBIT(47:60),'(F14.5)') ROLD
60390 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60395 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60397 IF(LLOW.LT.LTOT) GOTO 120
60401 C...Read in new variable value.
60402 IF(MSVAR(IVAR,1).EQ.1) THEN
60404 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
60405 READ(CHINI,'(I10)') INEW
60406 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60408 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
60410 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60411 CHNEW=CHBIT(LNAM+1:LBIT)//' '
60413 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
60416 C...Store new variable value.
60419 ELSEIF(IVAR.EQ.2) THEN
60421 ELSEIF(IVAR.EQ.3) THEN
60423 ELSEIF(IVAR.EQ.4) THEN
60425 ELSEIF(IVAR.EQ.5) THEN
60427 ELSEIF(IVAR.EQ.6) THEN
60429 ELSEIF(IVAR.EQ.7) THEN
60431 ELSEIF(IVAR.EQ.8) THEN
60433 ELSEIF(IVAR.EQ.9) THEN
60435 ELSEIF(IVAR.EQ.10) THEN
60437 ELSEIF(IVAR.EQ.11) THEN
60439 ELSEIF(IVAR.EQ.12) THEN
60441 ELSEIF(IVAR.EQ.13) THEN
60443 ELSEIF(IVAR.EQ.14) THEN
60445 ELSEIF(IVAR.EQ.15) THEN
60447 ELSEIF(IVAR.EQ.16) THEN
60449 ELSEIF(IVAR.EQ.17) THEN
60451 ELSEIF(IVAR.EQ.18) THEN
60453 ELSEIF(IVAR.EQ.19) THEN
60455 ELSEIF(IVAR.EQ.20) THEN
60457 ELSEIF(IVAR.EQ.21) THEN
60459 ELSEIF(IVAR.EQ.22) THEN
60461 ELSEIF(IVAR.EQ.23) THEN
60463 ELSEIF(IVAR.EQ.24) THEN
60465 ELSEIF(IVAR.EQ.25) THEN
60467 ELSEIF(IVAR.EQ.26) THEN
60469 ELSEIF(IVAR.EQ.27) THEN
60471 ELSEIF(IVAR.EQ.28) THEN
60473 ELSEIF(IVAR.EQ.29) THEN
60475 ELSEIF(IVAR.EQ.30) THEN
60477 ELSEIF(IVAR.EQ.31) THEN
60479 ELSEIF(IVAR.EQ.32) THEN
60481 ELSEIF(IVAR.EQ.33) THEN
60482 ICOL(I1,I2,I3)=INEW
60483 ELSEIF(IVAR.EQ.34) THEN
60485 ELSEIF(IVAR.EQ.35) THEN
60487 ELSEIF(IVAR.EQ.36) THEN
60489 ELSEIF(IVAR.EQ.37) THEN
60491 ELSEIF(IVAR.EQ.38) THEN
60493 ELSEIF(IVAR.EQ.39) THEN
60495 ELSEIF(IVAR.EQ.40) THEN
60497 ELSEIF(IVAR.EQ.41) THEN
60499 ELSEIF(IVAR.EQ.42) THEN
60500 SIGT(I1,I2,I3)=RNEW
60501 ELSEIF(IVAR.EQ.43) THEN
60503 ELSEIF(IVAR.EQ.44) THEN
60505 ELSEIF(IVAR.EQ.45) THEN
60507 ELSEIF(IVAR.EQ.46) THEN
60509 ELSEIF(IVAR.EQ.47) THEN
60511 ELSEIF(IVAR.EQ.48) THEN
60513 ELSEIF(IVAR.EQ.49) THEN
60515 ELSEIF(IVAR.EQ.50) THEN
60516 RVLAM(I1,I2,I3)=RNEW
60517 ELSEIF(IVAR.EQ.51) THEN
60518 RVLAMP(I1,I2,I3)=RNEW
60519 ELSEIF(IVAR.EQ.52) THEN
60520 RVLAMB(I1,I2,I3)=RNEW
60521 ELSEIF(IVAR.EQ.53) THEN
60523 ELSEIF(IVAR.EQ.54) THEN
60525 ELSEIF(IVAR.EQ.55) THEN
60527 ELSEIF(IVAR.EQ.56) THEN
60531 C...Write old and new value. Loop back.
60533 CHBIT(15:60)=' changed from to '
60534 IF(MSVAR(IVAR,1).EQ.1) THEN
60535 WRITE(CHBIT(33:42),'(I10)') IOLD
60536 WRITE(CHBIT(51:60),'(I10)') INEW
60537 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60538 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60539 WRITE(CHBIT(29:42),'(F14.5)') ROLD
60540 WRITE(CHBIT(47:60),'(F14.5)') RNEW
60541 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60542 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60545 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60547 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
60548 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
60551 IF(LLOW.LT.LTOT) GOTO 120
60553 C...Format statement for output on unit MSTU(11) (by default 6).
60554 5000 FORMAT(5X,A60)
60555 5100 FORMAT(5X,A88)
60560 C*********************************************************************
60563 C...Switches on and off decay channel by search for match.
60565 SUBROUTINE PYONOF(CHIN)
60567 C...Double precision and integer declarations.
60568 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60569 IMPLICIT INTEGER(I-N)
60570 INTEGER PYK,PYCHGE,PYCOMP
60572 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60573 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60574 SAVE /PYDAT1/,/PYDAT3/
60575 C...Local arrays and character variables.
60576 INTEGER KFCMP(10),KFTMP(10)
60577 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
60579 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60580 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
60582 C...Determine length of character variable.
60586 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
60589 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
60591 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
60593 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
60595 C...Find colon separator and particle code.
60597 120 LCOLON=LCOLON+1
60598 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
60600 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
60601 READ(CHCODE,'(I8)',ERR=300) KF
60604 C...Done if unknown code or no decay channels.
60606 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
60611 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
60612 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
60616 C...Find command name up to blank or equal sign.
60619 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
60620 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
60622 LMODE=LSEP-LCOLON-1
60623 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
60625 C...Convert to uppercase.
60626 DO 150 LCOM=1,LMODE
60628 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
60629 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
60633 C...Identify command. Failed if not identified.
60635 IF(CHMODE.EQ.'ALLOFF') MODE=1
60636 IF(CHMODE.EQ.'ALLON') MODE=2
60637 IF(CHMODE.EQ.'OFFIFANY') MODE=3
60638 IF(CHMODE.EQ.'ONIFANY') MODE=4
60639 IF(CHMODE.EQ.'OFFIFALL') MODE=5
60640 IF(CHMODE.EQ.'ONIFALL') MODE=6
60641 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
60642 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
60644 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
60648 C...Simple cases when all on or all off.
60649 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
60650 WRITE(MSTU(11),1000) KF,CHMODE
60651 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
60652 IF(MDME(IDC,1).LT.0) GOTO 160
60658 C...Identify matching list.
60662 IF(LBEG.GT.LEN) GOTO 190
60663 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
60664 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
60667 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
60668 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
60669 IF(LEND.LT.LEN) LEND=LEND-1
60671 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
60672 READ(CHCODE,'(I8)',ERR=300) KFREAD
60674 KFCMP(NCMP)=IABS(KFREAD)
60676 IF(NCMP.LT.10) GOTO 170
60678 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
60680 C...Only one matching required.
60681 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
60682 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
60683 IF(MDME(IDC,1).LT.0) GOTO 220
60685 KFNOW=IABS(KFDP(IDC,IKF))
60686 IF(KFNOW.EQ.0) GOTO 210
60688 IF(KFCMP(ICMP).EQ.KFNOW) THEN
60698 C...Multiple matchings required.
60699 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
60700 IF(MDME(IDC,1).LT.0) GOTO 260
60703 KFTMP(ITMP)=KFCMP(ITMP)
60707 KFNOW=IABS(KFDP(IDC,IKF))
60708 IF(KFNOW.EQ.0) GOTO 250
60711 IF(KFTMP(ITMP).EQ.KFNOW) THEN
60712 KFTMP(ITMP)=KFTMP(NTMP)
60718 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
60719 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
60720 & MDME(IDC,1)=MODE-7
60724 C...Error exit for impossible read of particle code.
60725 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
60728 C...Formats for output.
60729 1000 FORMAT(' Decays for',I8,' set ',A10)
60730 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
60734 C*********************************************************************
60737 C...Presets for a few specific underlying-event and min-bias tunes
60738 C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
60739 C...others require particular versions of pythia (e.g. the SCI and GAL
60740 C...models). See below for details.
60741 SUBROUTINE PYTUNE(ITUNE)
60743 C ITUNE NAME (detailed descriptions below)
60744 C 0 Default : No settings changed => defaults.
60746 C ====== Old UE, Q2-ordered showers ====================================
60747 C 100 A : Rick Field's CDF Tune A (Oct 2002)
60748 C 101 AW : Rick Field's CDF Tune AW (Apr 2006)
60749 C 102 BW : Rick Field's CDF Tune BW (Apr 2006)
60750 C 103 DW : Rick Field's CDF Tune DW (Apr 2006)
60751 C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006)
60752 C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?)
60753 C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?)
60754 C 107 ACR : Tune A modified with new CR model (Mar 2007)
60755 C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?)
60756 C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?)
60757 C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
60758 C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008)
60759 C 111 AW-Pro : Tune AW, -"- (Oct 2008)
60760 C 112 BW-Pro : Tune BW, -"- (Oct 2008)
60761 C 113 DW-Pro : Tune DW, -"- (Oct 2008)
60762 C 114 DWT-Pro : Tune DWT, -"- (Oct 2008)
60763 C 115 QW-Pro : Tune QW, -"- (Oct 2008)
60764 C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008)
60765 C 117 ACR-Pro : Tune ACR, -"- (Oct 2008)
60766 C 118 D6-Pro : Tune D6, -"- (Oct 2008)
60767 C 119 D6T-Pro : Tune D6T, -"- (Oct 2008)
60768 C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
60769 C 129 Pro-Q20 : Professor Q2-ordered tune (Feb 2009)
60771 C ====== Intermediate and Hybrid Models ================================
60772 C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
60773 C 201 APT : Tune A w. pT-ordered FSR (Mar 2007)
60774 C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008)
60775 C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009)
60776 C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
60778 C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
60779 C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006)
60780 C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006)
60781 C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006)
60782 C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006)
60783 C 304 NOCR : New UE "best try" without col. rec. (Apr 2006)
60784 C 305 Old : New UE, original (primitive) col. rec. (Aug 2004)
60785 C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
60786 C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
60787 C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008)
60788 C 311 S1-Pro : S1 -"- (Oct 2008)
60789 C 312 S2-Pro : S2 -"- (Oct 2008)
60790 C 313 S0A-Pro : S0A -"- (Oct 2008)
60791 C 314 NOCR-Pro : NOCR -"- (Oct 2008)
60792 C 315 Old-Pro : Old -"- (Oct 2008)
60793 C ---- Peter's Perugia Tunes : 320+ ------------------------------------
60794 C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009)
60795 C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
60796 C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
60797 C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
60798 C balance & different scaling to LHC & RHIC (Feb 2009)
60799 C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009)
60800 C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
60801 C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
60802 C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
60803 C 329 Pro-pT0 : Professor pT-ordered tune w. S0 CR model (Feb 2009)
60805 C ======= The Uppsala models ===========================================
60806 C ( NB! must be run with special modified Pythia 6.215 version )
60807 C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
60808 C 400 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
60809 C 401 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
60810 C 402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006)
60811 C 403 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
60815 C Quick Dictionary:
60816 C BE : Bose-Einstein
60817 C BR : Beam Remnants
60818 C CR : Colour Reconnections
60819 C HAD: Hadronization
60820 C ISR/FSR: Initial-State Radiation / Final-State Radiation
60821 C FSI: Final-State Interactions (=CR+BE)
60822 C MB : Minimum-bias
60823 C MI : Multiple Interactions
60824 C UE : Underlying Event
60826 C=======================================================================
60827 C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
60828 C=======================================================================
60830 C A (100) and AW (101). CTEQ5L parton distributions
60831 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60832 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60833 C...Key feature: extensively compared to CDF data (R.D. Field).
60834 C...* Large starting scale for ISR (PARP(67)=4)
60835 C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
60836 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60838 C BW (102). CTEQ5L parton distributions
60839 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60840 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60841 C...Key feature: extensively compared to CDF data (R.D. Field).
60842 C...NB: Can also be run with Pythia 6.2 or 6.312+
60843 C...* Small starting scale for ISR (PARP(67)=1)
60844 C...* BW has more radiation due to smaller mu_R choice in alpha_s.
60845 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60847 C DW (103) and DWT (104). CTEQ5L parton distributions
60848 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60849 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60850 C...Key feature: extensively compared to CDF data (R.D. Field).
60851 C...NB: Can also be run with Pythia 6.2 or 6.312+
60852 C...* Intermediate starting scale for ISR (PARP(67)=2.5)
60853 C...* DWT has a different reference energy, the same as the "S" models
60854 C... below, leading to more UE activity at the LHC, but less at RHIC.
60855 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60857 C QW (105). CTEQ61 parton distributions
60858 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60859 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60860 C...Key feature: uses CTEQ61 (external pdf library must be linked)
60862 C ATLAS-DC2 (106). CTEQ5L parton distributions
60863 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60864 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60865 C...Key feature: tune used by the ATLAS collaboration.
60867 C ACR (107). CTEQ5L parton distributions
60868 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
60869 C...Key feature: Tune A modified to use annealing CR.
60870 C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
60872 C D6 (108) and D6T (109). CTEQ6L parton distributions
60873 C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
60875 C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
60876 C Old UE model, Q2-ordered showers.
60877 C...Key feature: Rick Field's family of tunes revamped with the
60878 C...Professor Q2-ordered final-state shower and fragmentation tunes
60879 C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
60880 C...Key feature: improved descriptions of LEP data.
60882 C Pro-Q20 (129). CTEQ5L parton distributions
60883 C Old UE model, Q2-ordered showers.
60884 C...Key feature: Complete retune of old model by Professor, including
60885 C...large amounts of both LEP and Tevatron data.
60886 C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
60887 C...extreme in this tune, corresponding to using mu_R = pT/3 .
60889 C=======================================================================
60890 C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
60891 C=======================================================================
60893 C IM1 (200). Intermediate model, Q2-ordered showers,
60894 C CTEQ5L parton distributions
60895 C...Key feature: new UE model w Q2-ordered showers and no interleaving.
60896 C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
60897 C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
60899 C APT (201). Old UE model, pT-ordered final-state showers,
60900 C CTEQ5L parton distributions
60901 C...Key feature: Rick Field's Tune A, but with new final-state showers
60903 C APT-Pro (211). Old UE model, pT-ordered final-state showers,
60904 C CTEQ5L parton distributions
60905 C...Key feature: APT revamped with the Professor pT-ordered final-state
60906 C...shower and fragmentation tunes presented by Hendrik Hoeth at the
60907 C...Perugia MPI workshop in October 2008.
60909 C Perugia-APT (221). Old UE model, pT-ordered final-state showers,
60910 C CTEQ5L parton distributions
60911 C...Key feature: APT-Pro with final-state showers off the MPI,
60912 C...lower ISR renormalization scale to improve agreement with the
60913 C...Tevatron Drell-Yan pT measurements and with improved energy scaling
60914 C...to min-bias at 630 GeV.
60916 C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
60917 C CTEQ6L1 parton distributions.
60918 C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
60919 C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
60920 C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
60922 C=======================================================================
60923 C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
60924 C=======================================================================
60926 C S0 (300) and S0A (303). CTEQ5L parton distributions
60927 C...Key feature: large amount of multiple interactions
60928 C...* Somewhat faster than the other colour annealing scenarios.
60929 C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
60930 C... from Tune A, leading to less UE at the LHC, but more at RHIC.
60931 C...* Small amount of radiation.
60932 C...* Large amount of low-pT MI
60933 C...* Low degree of proton lumpiness (broad matter dist.)
60934 C...* CR Type S (driven by free triplets), of medium strength.
60935 C...* See: Pythia6402 update notes or later.
60937 C S1 (301). CTEQ5L parton distributions
60938 C...Key feature: large amount of radiation.
60939 C...* Large amount of low-pT perturbative ISR
60940 C...* Large amount of FSR off ISR partons
60941 C...* Small amount of low-pT multiple interactions
60942 C...* Moderate degree of proton lumpiness
60943 C...* Least aggressive CR type (S+S Type I), but with large strength
60944 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60946 C S2 (302). CTEQ5L parton distributions
60947 C...Key feature: very lumpy proton + gg string cluster formation allowed
60948 C...* Small amount of radiation
60949 C...* Moderate amount of low-pT MI
60950 C...* High degree of proton lumpiness (more spiky matter distribution)
60951 C...* Most aggressive CR type (S+S Type II), but with small strength
60952 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60954 C NOCR (304). CTEQ5L parton distributions
60955 C...Key feature: no colour reconnections (NB: "Best fit" only).
60956 C...* NB: <pT>(Nch) problematic in this tune.
60957 C...* Small amount of radiation
60958 C...* Small amount of low-pT MI
60959 C...* Low degree of proton lumpiness
60960 C...* Large BR composite x enhancement factor
60961 C...* Most clever colour flow without CR ("Lambda ordering")
60963 C ATLAS-CSC (306). CTEQ6L parton distributions
60964 C...Key feature: 11-parameter ATLAS tune of the new framework.
60965 C...* Old (pre-annealing) colour reconnections a la 305.
60966 C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
60968 C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
60969 C...Key feature: the S0 family of tunes revamped with the Professor
60970 C...pT-ordered final-state shower and fragmentation tunes presented by
60971 C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
60972 C...Key feature: improved descriptions of LEP data.
60974 C Perugia-0 (320). CTEQ5L parton distributions.
60975 C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
60976 C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
60977 C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
60978 C...beam-remnant breakup (more baryon number transport), and suppression
60979 C...of CR in high-pT string pieces.
60981 C Perugia-HARD (321). CTEQ5L parton distributions.
60982 C...Key feature: More ISR, More FSR, Less MPI, Less BR
60983 C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
60984 C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
60985 C...baryon number transport), and more fragmentation pT.
60986 C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
60987 C...DY pT spectrum is HARD.
60989 C Perugia-SOFT (322). CTEQ5L parton distributions.
60990 C...Key feature: Less ISR, Less FSR, More MPI, More BR
60991 C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
60992 C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
60993 C...number transport), and less fragmentation pT.
60994 C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
60995 C...DY pT spectrum is SOFT
60997 C Perugia-3 (323). CTEQ5L parton distributions.
60998 C...Key feature: variant of Perugia-0 with more extreme energy scaling
60999 C...properties while still agreeing with Tevatron data from 630 to 1960.
61000 C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
61001 C...allows FSR off the active end of dipoles stretched to the remnant.
61003 C Perugia-NOCR (324). CTEQ5L parton distributions.
61004 C...Key feature: Retune of NOCR-Pro with better scaling properties to
61005 C...lower energies and somewhat better agreement with Tevatron data
61008 C Perugia-* (325). MRST LO* parton distributions for generators
61009 C...Key feature: first attempt at using the LO* distributions
61010 C...(external pdf library must be linked).
61012 C Perugia-6 (326). CTEQ6L1 parton distributions
61013 C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
61015 C Pro-pT0 (329). CTEQ5L parton distributions
61016 C...Key feature: Complete retune of new model by Professor, including
61017 C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
61019 C=======================================================================
61021 C=======================================================================
61023 C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
61024 C...with an unmodified Pythia distribution.
61025 C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
61027 C ::: + Future improvements?
61028 C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
61029 C (problem: K-factor affects everything so only works as
61030 C intended for min-bias, not for UE ... probably need a
61031 C better long-term solution to handle UE as well. Anyway,
61032 C Mark uses MSTP(33) and PARP(31)-PARP(33).)
61034 C...Global statements
61035 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61036 INTEGER PYK,PYCHGE,PYCOMP
61039 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61040 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
61042 C...SCI and GAL Commonblocks
61043 COMMON /SCIPAR/MSWI(2),PARSCI(2)
61045 C...SAVE statements
61046 SAVE /PYDAT1/,/PYPARS/
61049 C...Internal parameters
61050 PARAMETER(MXTUNS=500)
61051 CHARACTER*8 CHVERS, CHDOC
61052 PARAMETER (CHVERS='1.015 ',CHDOC='Jan 2009')
61053 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
61054 CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
61055 & CHPARJ(1:100), CH40
61058 DATA (CHNAMS(I),I=0,1)/'Default',' '/
61059 DATA (CHNAMS(I),I=100,119)/
61060 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
61061 & 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
61062 1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
61063 1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
61064 1 'Tune D6-Pro','Tune D6T-Pro'/
61065 DATA (CHNAMS(I),I=120,129)/
61067 DATA (CHNAMS(I),I=300,309)/
61068 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
61069 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
61070 DATA (CHNAMS(I),I=310,315)/
61071 & 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
61072 & 'NOCR-Pro','Old-Pro'/
61073 DATA (CHNAMS(I),I=320,329)/
61074 & 'Perugia 0','Perugia HARD','Perugia SOFT',
61075 & 'Perugia 3','Perugia NOCR','Perugia LO*',
61076 & 'Perugia 6',2*' ','Pro-pT0'/
61077 DATA (CHNAMS(I),I=200,229)/
61078 & 'IM Tune 1','Tune APT',8*' ',
61079 & ' ','Tune APT-Pro',8*' ',
61080 & ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
61081 DATA (CHNAMS(I),I=400,409)/
61082 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
61083 DATA (CHMSTJ(I),I=11,20)/
61084 & 'HAD choice of fragmentation function(s)',4*' ',
61085 & 'HAD treatment of small-mass systems',4*' '/
61086 DATA (CHMSTJ(I),I=41,50)/
61087 & 'FSR type (Q2 or pT) for old framework',9*' '/
61088 DATA (CHMSTP(I),I=51,100)/
61089 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
61090 6 'ISR master switch',2*' ','ISR alphaS type',2*' ',
61091 6 'ISR coherence option for 1st emission',
61092 6 'ISR phase space choice & ME corrections',' ',
61093 7 'ISR IR regularization scheme',' ',
61094 7 'ISR scheme for FSR off ISR',8*' ',
61096 8 'UE hadron transverse mass distribution',5*' ',
61097 8 'BR composite scheme','BR colour scheme',
61098 9 'BR primordial kT compensation',
61099 9 'BR primordial kT distribution',
61100 9 'BR energy partitioning scheme',2*' ',
61101 9 'FSI colour (re-)connection model',5*' '/
61102 DATA (CHPARP(I),I=61,100)/
61103 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
61104 6 2*' ','ISR Q2max factor',3*' ',
61105 7 'FSR Q2max factor for non-s-channel procs',5*' ',
61106 7 'FSI colour reco high-pT dampening strength',
61107 7 'FSI colour reconnection strength',
61108 7 'BR composite x enhancement','BR breakup suppression',
61109 8 2*'UE IR cutoff at reference ecm',
61110 8 2*'UE mass distribution parameter',
61111 8 'UE gg colour correlated fraction','UE total gg fraction',
61113 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
61114 9 'BR primordial kT width <|kT|>',' ',
61115 9 'BR primordial kT UV cutoff',7*' '/
61116 DATA (CHPARJ(I),I=1,30)/
61117 & 'HAD diquark suppression','HAD strangeness suppression',
61118 & 'HAD strange diquark suppression',
61119 & 'HAD vector diquark suppression',6*' ',
61120 1 'HAD P(vector meson), u and d only',
61121 1 'HAD P(vector meson), contains s',
61122 1 'HAD P(vector meson), heavy quarks',7*' ',
61123 2 'HAD fragmentation pT',' ',' ',' ',
61124 2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
61125 DATA (CHPARJ(I),I=41,90)/
61126 4 'HAD string parameter a','HAD string parameter b',3*' ',
61127 4 'HAD Lund(=0)-Bowler(=1) rQ (rc)',
61128 4 'HAD Lund(=0)-Bowler(=1) rb',3*' ',
61129 5 3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
61131 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
61133 C...1) Shorthand notation
61136 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
61137 CHNAME=CHNAMS(ITUNE)
61138 IF (ITUNE.EQ.0) GOTO 9999
61140 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
61145 IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
61147 C...3) Tune parameters
61149 C=======================================================================
61150 C...S0, S1, S2, S0A, NOCR, Rap,
61151 C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
61152 C...Perugia 0, HARD, SOFT, Perugia 3, Perugia LO*, Perugia 6
61154 IF ((ITUNE.GE.300.AND.ITUNE.LE.305)
61155 & .OR.(ITUNE.GE.310.AND.ITUNE.LE.315)
61156 & .OR.(ITUNE.GE.320.AND.ITUNE.LE.326).OR.ITUNE.EQ.329) THEN
61157 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
61158 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
61159 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61161 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326.AND.ITUNE.NE.324.AND.
61162 & (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419)))
61164 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61168 C...Use Professor's LEP pars if ITUNE >= 310
61169 C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
61170 IF (ITUNE.LT.310) THEN
61173 C...# Old default flavour parameters
61180 ELSEIF (ITUNE.GE.310) THEN
61181 C...# Tuned flavour parameters:
61191 C...# Always use pT-ordered shower:
61193 C...# Switch on Bowler:
61195 C...# Fragmentation
61204 C...Remove middle digit now for Professor variants, since identical pars
61206 IF (ITUNE.GE.310.AND.ITUNE.LE.319) THEN
61207 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
61210 C...PDFs: all use CTEQ5L as starting point
61213 IF (ITUNE.EQ.325) THEN
61214 C...MRST LO* for 325
61217 ELSEIF (ITUNE.EQ.326) THEN
61218 C...CTEQ6L1 for 326
61223 C...ISR: use Lambda_MSbar with default scale for S0(A)
61226 IF (ITUNE.EQ.320.OR.ITUNE.EQ.323.OR.ITUNE.EQ.324.OR.
61227 & ITUNE.EQ.326) THEN
61228 C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
61231 ELSEIF (ITUNE.EQ.321) THEN
61232 C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
61235 ELSEIF (ITUNE.EQ.322) THEN
61236 C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
61239 ELSEIF (ITUNE.EQ.325) THEN
61240 C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
61243 ELSEIF (ITUNE.EQ.329) THEN
61244 C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
61249 C...ISR : power-suppressed power showers above s_color (since 6.4.19)
61252 C...Perugia tunes have stronger suppression, except HARD
61253 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61255 IF (ITUNE.EQ.321) PARP(67)=4D0
61256 IF (ITUNE.EQ.322) PARP(67)=0.5D0
61259 C...ISR IR cutoff type and FSR off ISR setting:
61260 C...Smooth ISR, low FSR-off-ISR
61263 IF (ITUNEB.EQ.301) THEN
61264 C...S1, S1-Pro: sharp ISR, high FSR
61267 ELSEIF (ITUNE.EQ.320.OR.ITUNE.EQ.324.OR.ITUNE.EQ.326
61268 & .OR.ITUNE.EQ.325) THEN
61269 C...Perugia default is smooth ISR, high FSR-off-ISR
61272 ELSEIF (ITUNE.EQ.321) THEN
61273 C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
61277 ELSEIF (ITUNE.EQ.322) THEN
61278 C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
61282 ELSEIF (ITUNE.EQ.323) THEN
61283 C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
61289 C...FSR activity: Perugia tunes use a lower PARP(71) as indicated
61290 C...by Professor tunes (with HARD and SOFT variations)
61292 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61294 IF (ITUNE.EQ.321) PARP(71)=4D0
61295 IF (ITUNE.EQ.322) PARP(71)=1D0
61297 IF (ITUNE.EQ.329) PARP(71)=2D0
61299 C...FSR: Lambda_FSR scale (only if not using professor)
61300 IF (ITUNE.LT.310) PARJ(81)=0.23D0
61301 IF (ITUNE.EQ.321) PARJ(81)=0.30D0
61302 IF (ITUNE.EQ.322) PARJ(81)=0.20D0
61304 C...UE on, new model
61307 C...UE: hadron-hadron overlap profile (expOfPow for all)
61309 C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
61311 IF (ITUNEB.EQ.301) PARP(83)=1.4D0
61312 IF (ITUNEB.EQ.302) PARP(83)=1.2D0
61313 C...NOCR variants have very smooth distributions
61314 IF (ITUNEB.EQ.304) PARP(83)=1.8D0
61315 IF (ITUNEB.EQ.305) PARP(83)=2.0D0
61316 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61317 C...Perugia variants have slightly smoother profiles by default
61318 C...(to compensate for more tail by added radiation)
61319 C...Perugia-SOFT has more peaked distribution, NOCR less peaked
61321 IF (ITUNE.EQ.322) PARP(83)=1.5D0
61322 IF (ITUNE.EQ.324) PARP(83)=1.8D0
61324 C...Professor-pT0 also has very smooth distribution
61325 IF (ITUNE.EQ.329) PARP(83)=1.8
61327 C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
61329 IF (ITUNEB.EQ.301) PARP(82)=2.1D0
61330 IF (ITUNEB.EQ.302) PARP(82)=1.9D0
61331 IF (ITUNEB.EQ.304) PARP(82)=2.05D0
61332 IF (ITUNEB.EQ.305) PARP(82)=1.9D0
61333 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61334 C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
61335 C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
61336 C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
61337 C...slightly higher, due to increased activity.
61339 IF (ITUNE.EQ.321) PARP(82)=2.3D0
61340 IF (ITUNE.EQ.322) PARP(82)=1.9D0
61341 IF (ITUNE.EQ.323) PARP(82)=2.2D0
61342 IF (ITUNE.EQ.324) PARP(82)=1.95D0
61343 IF (ITUNE.EQ.325) PARP(82)=2.2D0
61344 IF (ITUNE.EQ.326) PARP(82)=1.95D0
61346 C...Professor-pT0 maintains low pT0 vaue
61347 IF (ITUNE.EQ.329) PARP(82)=1.85D0
61349 C...UE: IR cutoff reference energy and default energy scaling pace
61352 C...S0A, S0A-Pro have tune A energy scaling
61353 IF (ITUNEB.EQ.303) PARP(90)=0.25D0
61354 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61355 C...Perugia tunes explicitly include MB at 630 to fix energy scaling
61357 IF (ITUNE.EQ.321) PARP(90)=0.30D0
61358 IF (ITUNE.EQ.322) PARP(90)=0.24D0
61359 IF (ITUNE.EQ.323) PARP(90)=0.32D0
61360 IF (ITUNE.EQ.324) PARP(90)=0.24D0
61361 C...LO* and CTEQ6L1 tunes have slower energy scaling
61362 IF (ITUNE.EQ.325) PARP(90)=0.23D0
61363 IF (ITUNE.EQ.326) PARP(90)=0.22D0
61365 C...Professor-pT0 has intermediate scaling
61366 IF (ITUNE.EQ.329) PARP(90)=0.22D0
61368 C...BR: MPI initiator color connections rap-ordered by default
61369 C...NOCR variants are Lambda-ordered, Perugia SOFT is random-ordered
61371 IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89)=2
61372 IF (ITUNE.EQ.322) MSTP(89)=0
61374 C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
61376 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61377 C...Perugia tunes have more beam blowup by default
61379 IF (ITUNE.EQ.321) PARP(80)=0.01
61380 IF (ITUNE.EQ.323) PARP(80)=0.03
61381 IF (ITUNE.EQ.324) PARP(80)=0.01
61384 C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
61387 IF (ITUNEB.EQ.304) PARP(79)=3D0
61388 IF (ITUNE.EQ.329) PARP(79)=1.18
61390 C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
61394 C...Perugia-HARD only uses 1.0 GeV
61395 IF (ITUNE.EQ.321) PARP(91)=1.0D0
61396 C...Perugia-3 only uses 1.5 GeV
61397 IF (ITUNE.EQ.323) PARP(91)=1.5D0
61398 C...Professor-pT0 uses 7-GeV cutoff
61399 IF (ITUNE.EQ.329) PARP(93)=7.0
61401 C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
61403 C...S1, S1-Pro: use S1
61404 IF (ITUNEB.EQ.301) MSTP(95)=2
61405 C...S2, S2-Pro: use S2
61406 IF (ITUNEB.EQ.302) MSTP(95)=4
61407 C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
61408 IF (ITUNE.EQ.304.OR.ITUNE.EQ.314.OR.ITUNE.EQ.324) MSTP(95)=0
61409 C..."Old" and "Old"-Pro: use old CR
61410 IF (ITUNEB.EQ.305) MSTP(95)=1
61412 C...FSI: CR strength and high-pT dampening, default is S0
61413 IF (ITUNE.LT.320.OR.ITUNE.EQ.329) THEN
61416 IF (ITUNEB.EQ.301) PARP(78)=0.35D0
61417 IF (ITUNEB.EQ.302) PARP(78)=0.15D0
61418 IF (ITUNEB.EQ.304) PARP(78)=0.0D0
61419 IF (ITUNEB.EQ.305) PARP(78)=1.0D0
61420 IF (ITUNE.EQ.329) PARP(78)=0.17D0
61422 C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
61425 IF (ITUNE.EQ.321) THEN
61426 C...HARD has HIGH amount of CR
61429 ELSEIF (ITUNE.EQ.322) THEN
61430 C...SOFT has LOW amount of CR
61433 ELSEIF (ITUNE.EQ.323) THEN
61434 C...Scaling variant appears to need slightly more than default
61437 ELSEIF (ITUNE.EQ.324) THEN
61444 C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
61445 IF (ITUNE.EQ.321) PARJ(21)=0.34D0
61446 IF (ITUNE.EQ.322) PARJ(21)=0.28D0
61448 C...Switch off trial joinings
61451 C...S0 (300), S0A (303)
61452 IF (ITUNEB.EQ.300.OR.ITUNEB.EQ.303) THEN
61454 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
61455 WRITE(M11,5030) CH60
61456 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
61457 WRITE(M11,5030) CH60
61458 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61459 WRITE(M11,5030) CH60
61460 IF (ITUNE.GE.310) THEN
61461 CH60='LEP parameters tuned by Professor'
61462 WRITE(M11,5030) CH60
61467 ELSEIF(ITUNEB.EQ.301) THEN
61469 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61470 WRITE(M11,5030) CH60
61471 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61472 WRITE(M11,5030) CH60
61473 IF (ITUNE.GE.310) THEN
61474 CH60='LEP parameters tuned with Professor'
61475 WRITE(M11,5030) CH60
61480 ELSEIF(ITUNEB.EQ.302) THEN
61482 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61483 WRITE(M11,5030) CH60
61484 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61485 WRITE(M11,5030) CH60
61486 IF (ITUNE.GE.310) THEN
61487 CH60='LEP parameters tuned by Professor'
61488 WRITE(M11,5030) CH60
61493 ELSEIF(ITUNEB.EQ.304) THEN
61495 CH60='"best try" without colour reconnections'
61496 WRITE(M11,5030) CH60
61497 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
61498 WRITE(M11,5030) CH60
61499 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61500 WRITE(M11,5030) CH60
61501 IF (ITUNE.GE.310) THEN
61502 CH60='LEP parameters tuned by Professor'
61503 WRITE(M11,5030) CH60
61507 C..."Lo FSR" retune (305)
61508 ELSEIF(ITUNEB.EQ.305) THEN
61510 CH60='"Lo FSR retune" with primitive colour reconnections'
61511 WRITE(M11,5030) CH60
61512 CH60='see T. Sjostrand & P. Skands, hep-ph/0408302'
61513 WRITE(M11,5030) CH60
61514 IF (ITUNE.GE.310) THEN
61515 CH60='LEP parameters tuned by Professor'
61516 WRITE(M11,5030) CH60
61520 C...Perugia Tunes (320-326)
61521 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61523 CH60='P. Skands, Perugia MPI workshop October 2008'
61524 WRITE(M11,5030) CH60
61525 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61526 WRITE(M11,5030) CH60
61527 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
61528 WRITE(M11,5030) CH60
61529 CH60='LEP parameters tuned by Professor'
61530 WRITE(M11,5030) CH60
61531 IF (ITUNE.EQ.325) THEN
61532 CH70='NB! This tune requires MRST LO* pdfs to be '//
61533 & 'externally linked'
61534 WRITE(M11,5035) CH70
61535 ELSEIF (ITUNE.EQ.326) THEN
61536 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
61537 & 'externally linked'
61538 WRITE(M11,5035) CH70
61539 ELSEIF (ITUNE.EQ.321) THEN
61540 CH60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
61541 WRITE(M11,5030) CH60
61542 ELSEIF (ITUNE.EQ.322) THEN
61543 CH60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
61544 WRITE(M11,5030) CH60
61548 C...Professor-pT0 (329)
61549 ELSEIF(ITUNE.EQ.329) THEN
61551 CH60='See T. Sjostrand & P. Skands, hep-ph/0408302'
61552 WRITE(M11,5030) CH60
61553 CH60='and M. Sandhoff & P. Skands, in hep-ph/0604120'
61554 WRITE(M11,5030) CH60
61555 CH60='LEP/Tevatron parameters tuned by Professor'
61556 WRITE(M11,5030) CH60
61563 WRITE(M11,5030) ' '
61564 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
61565 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
61566 IF (MSTP(70).EQ.0) THEN
61567 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
61568 ELSEIF (MSTP(70).EQ.1) THEN
61569 WRITE(M11,5050) 81, PARP(81), CHPARP(62)
61570 CH60='(Note: PARP(81) replaces PARP(62).)'
61571 WRITE(M11,5030) CH60
61573 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
61574 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
61575 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
61576 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
61577 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
61578 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61579 WRITE(M11,5030) CH60
61580 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
61581 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
61582 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
61583 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
61584 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
61585 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
61586 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
61587 IF (MSTP(70).EQ.2) THEN
61588 CH60='(Note: PARP(82) replaces PARP(62).)'
61589 WRITE(M11,5030) CH60
61591 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
61592 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
61593 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
61594 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
61595 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
61596 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
61597 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
61598 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
61599 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
61600 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
61601 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
61602 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
61603 IF (MSTP(95).GE.1) THEN
61604 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
61605 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
61607 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
61608 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
61609 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
61610 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
61611 IF (MSTJ(11).LE.3) THEN
61612 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
61613 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
61615 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
61617 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
61620 C=======================================================================
61621 C...ATLAS-CSC 11-parameter tune (By A. Moraes)
61622 ELSEIF (ITUNE.EQ.306) THEN
61623 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
61624 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
61625 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61636 C...UE on, new model.
61641 C...Switch off trial joinings
61643 C...Primordial kT cutoff
61646 CH60='see presentations by A. Moraes (ATLAS),'
61647 WRITE(M11,5030) CH60
61648 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61649 WRITE(M11,5030) CH60
61650 WRITE(M11,5030) ' '
61651 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
61652 & 'externally linked'
61653 WRITE(M11,5035) CH70
61655 C...Smooth ISR, low FSR
61660 C...Transverse density profile.
61664 C...ISR & FSR in interactions after the first (default)
61667 C...No double-counting (default)
61669 C...Companion quark parent gluon (1-x) power
61671 C...Primordial kT compensation along chaings (default = 0 : uniform)
61673 C...Colour Reconnections
61676 C...Lambda_FSR scale.
61678 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
61683 C...Peterson charm frag, and c and b hadr parameters
61689 WRITE(M11,5030) ' '
61690 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
61691 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
61692 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
61693 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
61694 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61695 WRITE(M11,5030) CH60
61696 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
61697 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
61698 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
61699 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
61700 CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
61701 WRITE(M11,5030) CH60
61702 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
61703 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
61704 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
61705 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
61706 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
61707 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
61708 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
61709 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
61710 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
61711 WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
61712 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
61713 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
61714 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
61715 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
61716 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
61717 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
61718 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
61719 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
61720 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
61721 IF (MSTJ(11).LE.3) THEN
61722 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
61723 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
61725 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
61727 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
61730 C=======================================================================
61731 C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
61732 C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
61733 C...A-Pro, DW-Pro, etc (100-119), and Pro-Q20 (129)
61734 ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
61735 & ITUNE.EQ.109.OR.(ITUNE.GE.110.AND.ITUNE.LE.116).OR.
61736 & ITUNE.EQ.118.OR.ITUNE.EQ.119.OR.ITUNE.EQ.129) THEN
61737 IF (M13.GE.1.AND.ITUNE.NE.106.AND.ITUNE.NE.129) THEN
61738 WRITE(M11,5010) ITUNE, CHNAME
61739 CH60='see R.D. Field, in hep-ph/0610012'
61740 WRITE(M11,5030) CH60
61741 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61742 WRITE(M11,5030) CH60
61743 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
61744 CH60='LEP parameters tuned by Professor'
61745 WRITE(M11,5030) CH60
61747 ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN
61748 WRITE(M11,5010) ITUNE, CHNAME
61749 CH60='See T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61750 WRITE(M11,5030) CH60
61751 CH60='LEP/Tevatron parameters tuned by Professor'
61752 WRITE(M11,5030) CH60
61755 C...Make sure we start from old default fragmentation parameters
61759 C...Use Professor's LEP pars if ITUNE >= 110
61760 C...(i.e., for A-Pro, DW-Pro etc)
61761 IF (ITUNE.LT.110) THEN
61764 C...# Old default flavour parameters
61771 C...# Tuned flavour parameters:
61781 C...# Switch on Bowler:
61783 C...# Fragmentation
61792 C...Remove middle digit now for Professor variants, since identical pars
61794 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
61795 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
61798 C...Multiple interactions on, old framework
61800 C...Fast IR cutoff energy scaling by default
61803 C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
61806 IF (ITUNEB.EQ.105) THEN
61809 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
61815 C...Double Gaussian matter distribution.
61821 C...Fragmentation functions and c and b parameters
61822 C...(only if not using Professor)
61823 IF (ITUNE.LE.109) THEN
61830 IF(ITUNEB.EQ.100.OR.ITUNEB.EQ.101) THEN
61833 c...String drawing almost completely minimizes string length.
61836 C...ISR cutoff, muR scale factor, and phase space size
61840 C...Intrinsic kT, size, and max
61844 C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
61845 IF (ITUNEB.EQ.101) THEN
61852 C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
61853 ELSEIF (ITUNEB.EQ.102) THEN
61856 c...String drawing completely minimizes string length.
61859 C...ISR cutoff, muR scale factor, and phase space size
61863 C...Intrinsic kT, size, and max
61869 ELSEIF (ITUNEB.EQ.103) THEN
61872 c...String drawing completely minimizes string length.
61875 C...ISR cutoff, muR scale factor, and phase space size
61879 C...Intrinsic kT, size, and max
61885 ELSEIF (ITUNEB.EQ.104) THEN
61888 C...Run II ref scale and slow scaling
61891 c...String drawing completely minimizes string length.
61894 C...ISR cutoff, muR scale factor, and phase space size
61898 C...Intrinsic kT, size, and max
61904 ELSEIF(ITUNEB.EQ.105) THEN
61906 WRITE(M11,5030) ' '
61907 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
61908 & 'externally linked'
61909 WRITE(M11,5035) CH70
61913 c...String drawing completely minimizes string length.
61916 C...ISR cutoff, muR scale factor, and phase space size
61920 C...Intrinsic kT, size, and max
61925 C...Tune D6 and D6T
61926 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
61928 WRITE(M11,5030) ' '
61929 CH70='NB! This tune requires CTEQ6L pdfs to be '//
61930 & 'externally linked'
61931 WRITE(M11,5035) CH70
61933 C...The "Rick" proton, double gauss with 0.5/0.4
61937 c...String drawing completely minimizes string length.
61940 IF (ITUNEB.EQ.108) THEN
61941 C...D6: pT0, Run I ref scale, and fast energy scaling
61946 C...D6T: pT0, Run II ref scale, and slow energy scaling
61951 C...ISR cutoff, muR scale factor, and phase space size
61955 C...Intrinsic kT, size, and max
61960 C...Old ATLAS-DC2 5-parameter tune
61961 ELSEIF(ITUNEB.EQ.106) THEN
61963 WRITE(M11,5010) ITUNE, CHNAME
61964 CH60='see A. Moraes et al., SN-ATLAS-2006-057,'
61965 WRITE(M11,5030) CH60
61966 CH60=' R. Field in hep-ph/0610012,'
61967 WRITE(M11,5030) CH60
61968 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61969 WRITE(M11,5030) CH60
61973 C... Different ref and rescaling pacee
61976 C... Parameters of mass distribution
61979 C... Old default string drawing
61982 C... ISR, phase space equivalent to Tune B
61993 C...Professor's Pro-Q20 Tune
61994 ELSEIF(ITUNE.EQ.129) THEN
61996 CH60='see H. Hoeth, Perugia MPI workshop, Oct 2008'
61997 WRITE(M11,5030) CH60
62017 WRITE(M11,5030) ' '
62018 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62019 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62020 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62021 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62022 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62023 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62024 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62025 WRITE(M11,5030) CH60
62026 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62027 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62028 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62029 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62030 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62031 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62032 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62033 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62034 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62035 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62036 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62037 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62038 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62039 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62040 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62041 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62042 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62043 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62044 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62045 IF (MSTJ(11).LE.3) THEN
62046 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62047 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62049 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62051 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62054 C=======================================================================
62055 C... ACR, tune A with new CR (107)
62056 ELSEIF(ITUNE.EQ.107.OR.ITUNE.EQ.117) THEN
62058 WRITE(M11,5010) ITUNE, CHNAME
62059 CH60='Tune A modified with new colour reconnections'
62060 WRITE(M11,5030) CH60
62061 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
62062 WRITE(M11,5030) CH60
62063 CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
62064 WRITE(M11,5030) CH60
62065 CH60=' R. Field, in hep-ph/0610012 (Tune A),'
62066 WRITE(M11,5030) CH60
62067 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62068 WRITE(M11,5030) CH60
62069 IF (ITUNE.EQ.117) THEN
62070 CH60='LEP parameters tuned by Professor'
62071 WRITE(M11,5030) CH60
62074 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
62075 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62076 & ' with tune. Using defaults.')
62080 C...Make sure we start from old default fragmentation parameters
62084 C...Use Professor's LEP pars if ITUNE >= 110
62085 C...(i.e., for A-Pro, DW-Pro etc)
62086 IF (ITUNE.LT.110) THEN
62089 C...# Old default flavour parameters
62096 C...# Tuned flavour parameters:
62106 C...# Switch on Bowler:
62108 C...# Fragmentation
62136 C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
62138 C...Frag functions (only if not using Professor)
62139 IF (ITUNE.LE.109) THEN
62147 WRITE(M11,5030) ' '
62148 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62149 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62150 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62151 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62152 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62153 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62154 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62155 WRITE(M11,5030) CH60
62156 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62157 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62158 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62159 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62160 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62161 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62162 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62163 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62164 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62165 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62166 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62167 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62168 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62169 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62170 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62171 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62172 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62173 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62174 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62175 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62176 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62177 IF (MSTJ(11).LE.3) THEN
62178 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62179 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62181 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62183 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62186 C=======================================================================
62187 C...Intermediate model. Rap tune
62188 C...(retuned to post-6.406 IR factorization)
62189 ELSEIF(ITUNE.EQ.200) THEN
62191 WRITE(M11,5010) ITUNE, CHNAME
62192 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
62193 WRITE(M11,5030) CH60
62195 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62196 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62214 C... ExpOfPow(1.8) overlap profile
62221 C... Default diquark, BR-g-BR supp
62224 C... Final state reconnect.
62227 C...Fragmentation functions and c and b parameters
62233 WRITE(M11,5030) ' '
62234 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62235 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62236 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62237 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62238 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62239 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62240 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62241 WRITE(M11,5030) CH60
62242 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62243 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62244 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62245 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62246 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62247 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62248 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62249 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62250 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
62251 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
62252 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
62253 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
62254 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62255 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62256 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62257 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62258 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62259 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62260 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62261 IF (MSTJ(11).LE.3) THEN
62262 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62263 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62265 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62267 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62270 C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
62271 C...Old model for ISR and UE, new pT-ordered model for FSR
62272 ELSEIF(ITUNE.EQ.201.OR.ITUNE.EQ.211.OR.ITUNE.EQ.221.OR
62273 & .ITUNE.EQ.226) THEN
62275 WRITE(M11,5010) ITUNE, CHNAME
62276 CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
62277 WRITE(M11,5030) CH60
62278 CH60=' R.D. Field, in hep-ph/0610012 (Tune A)'
62279 WRITE(M11,5030) CH60
62280 CH60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62281 WRITE(M11,5030) CH60
62282 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
62283 WRITE(M11,5030) CH60
62284 IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN
62285 CH60='LEP parameters tuned by Professor'
62286 WRITE(M11,5030) CH60
62289 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
62290 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62293 C...First set as if Pythia tune A
62294 C...Multiple interactions on, old framework
62296 C...Fast IR cutoff energy scaling by default
62299 C...Default CTEQ5L (internal)
62302 C...Double Gaussian matter distribution.
62308 c...String drawing almost completely minimizes string length.
62311 C...ISR cutoff, muR scale factor, and phase space size
62315 C...Intrinsic kT, size, and max
62319 C...Use 2 GeV of primordial kT for "Perugia" version
62320 IF (ITUNE.EQ.221) THEN
62324 C...Use pT-ordered FSR
62326 C...Lambda_FSR scale for pT-ordering
62328 C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
62330 C...Fragmentation functions and c and b parameters
62331 C...(overwritten for 211, i.e., if using Professor pars)
62335 C...Use Professor's LEP pars if ITUNE == 211, 221, 226
62336 IF (ITUNE.LT.210) THEN
62339 C...# Old default flavour parameters
62346 C...# Tuned flavour parameters:
62356 C...# Always use pT-ordered shower:
62358 C...# Switch on Bowler:
62360 C...# Fragmentation
62361 PARJ(21) = 3.1327e-01
62362 PARJ(41) = 4.8989e-01
62363 PARJ(42) = 1.2018e+00
62364 PARJ(47) = 1.0000e+00
62365 PARJ(81) = 2.5696e-01
62366 PARJ(82) = 8.0000e-01
62369 C...221, 226 : Perugia-APT and Perugia-APT6
62370 IF (ITUNE.EQ.221.OR.ITUNE.EQ.226) THEN
62376 C...The Perugia variants use Steve's showers off the old MPI
62378 C...And use a lower PARP(71) as suggested by Professor tunings
62379 C...(although not certain that applies to Q2-pT2 hybrid)
62382 C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
62383 IF (ITUNE.EQ.226) THEN
62384 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
62385 & 'externally linked'
62386 WRITE(M11,5035) CH70
62396 WRITE(M11,5030) ' '
62397 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62398 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62399 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62400 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62401 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62402 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62403 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62404 WRITE(M11,5030) CH60
62405 WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
62406 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62407 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62408 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62409 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62410 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62411 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62412 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62413 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62414 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62415 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62416 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62417 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62418 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62419 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62420 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62421 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62422 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62423 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62424 IF (MSTJ(11).LE.3) THEN
62425 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62426 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62428 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62430 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62433 C======================================================================
62434 C...Uppsala models: Generalized Area Law and Soft Colour Interactions
62435 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
62437 WRITE(M11,5010) ITUNE, CHNAME
62438 CH60='see J. Rathsman, PLB452(1999)364'
62439 WRITE(M11,5030) CH60
62440 C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
62441 C ? WRITE(M11,5030)
62442 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62443 WRITE(M11,5030) CH60
62444 WRITE(M11,5030) ' '
62445 CH70='NB! The GAL model must be run with modified '//
62447 WRITE(M11,5035) CH70
62448 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
62449 WRITE(M11,5035) CH70
62450 WRITE(M11,5030) ' '
62452 C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
62465 IF(CHNAME.EQ.'GAL Tune 1') THEN
62466 C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
62472 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62473 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62474 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62475 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62476 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62480 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62481 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
62482 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62487 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62488 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62489 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
62490 CH40='FSI SCI/GAL selection'
62491 WRITE(M11,6040) 1, MSWI(1), CH40
62492 CH40='FSI SCI/GAL sea quark treatment'
62493 WRITE(M11,6040) 2, MSWI(2), CH40
62494 CH40='FSI SCI/GAL sea quark treatment parm'
62495 WRITE(M11,6050) 1, PARSCI(1), CH40
62496 CH40='FSI SCI/GAL string reco probability R_0'
62497 WRITE(M11,6050) 2, PARSCI(2), CH40
62498 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62499 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
62501 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
62503 WRITE(M11,5010) ITUNE, CHNAME
62504 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
62505 WRITE(M11,5030) CH60
62506 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62507 WRITE(M11,5030) CH60
62508 WRITE(M11,5030) ' '
62509 CH70='NB! The SCI model must be run with modified '//
62511 WRITE(M11,5035) CH70
62512 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
62513 WRITE(M11,5035) CH70
62514 WRITE(M11,5030) ' '
62516 C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
62526 IF (CHNAME.EQ.'SCI Tune 1') THEN
62527 C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
62535 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62536 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62537 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62538 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62539 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62543 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62544 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
62545 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62550 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
62551 CH40='FSI SCI/GAL selection'
62552 WRITE(M11,6040) 1, MSWI(1), CH40
62553 CH40='FSI SCI/GAL sea quark treatment'
62554 WRITE(M11,6040) 2, MSWI(2), CH40
62555 CH40='FSI SCI/GAL sea quark treatment parm'
62556 WRITE(M11,6050) 1, PARSCI(1), CH40
62557 CH40='FSI SCI/GAL string reco probability R_0'
62558 WRITE(M11,6050) 2, PARSCI(2), CH40
62559 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
62563 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
62567 100 IF (MSTU(13).GE.1) WRITE(M11,6000)
62571 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
62572 & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
62573 & 20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
62574 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
62575 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
62576 5030 FORMAT(' *',3x,10x,A60,3x,'*')
62577 5035 FORMAT(' *',3x,A70,3x,'*')
62578 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
62579 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
62580 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
62581 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
62582 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
62583 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
62584 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
62585 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
62586 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
62590 C*********************************************************************
62593 C...Administrates the fragmentation and decay chain.
62597 C...Double precision and integer declarations.
62598 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62599 IMPLICIT INTEGER(I-N)
62600 INTEGER PYK,PYCHGE,PYCOMP
62602 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62603 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62604 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62605 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62606 COMMON/PYINT1/MINT(400),VINT(400)
62607 COMMON/PYINT4/MWID(500),WIDS(500,5)
62608 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
62610 DIMENSION PS(2,6),IJOIN(100)
62612 C...Initialize and reset.
62614 IF(MSTU(12).NE.12345) CALL PYLIST(0)
62616 MSTU(31)=MSTU(31)+1
62620 IF(MSTU(17).LE.0) MSTU(90)=0
62623 C...Sum up momentum, energy and charge for starting entries.
62631 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
62633 PS(1,J)=PS(1,J)+P(I,J)
62635 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
62639 C...Start by all decays of coloured resonances involved in shower.
62642 IF(K(I,1).EQ.3) THEN
62644 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
62648 C...Prepare system for subsequent fragmentation/decay.
62650 IF(MINT(51).NE.0) RETURN
62652 C...Loop through jet fragmentation and particle decays.
62658 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
62661 C...Deal with any remaining undecayed resonance
62662 C...(normally the task of PYEVNT, so seldom used).
62663 ELSEIF(MWID(KC).NE.0) THEN
62665 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
62668 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
62669 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
62672 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
62673 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
62676 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
62684 IF(MINT(51).NE.0) RETURN
62686 C...Particle decay if unstable and allowed. Save long-lived particle
62687 C...decays until second pass after Bose-Einstein effects.
62688 ELSEIF(KCHG(KC,2).EQ.0) THEN
62689 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
62690 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
62693 C...Decay products may develop a shower.
62694 IF(MSTJ(92).GT.0) THEN
62696 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
62697 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
62699 CALL PYSHOW(IP1,IP1+1,QMAX)
62701 IF(MINT(51).NE.0) RETURN
62703 ELSEIF(MSTJ(92).LT.0) THEN
62706 CALL PYSHOW(IP1,-3,P(IP,5))
62708 IF(MINT(51).NE.0) RETURN
62712 C...Jet fragmentation: string or independent fragmentation.
62713 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
62715 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
62716 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
62717 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
62718 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
62719 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
62722 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
62723 IF(MFRAG.EQ.2) CALL PYINDF(IP)
62724 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
62725 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
62728 C...Loop back if enough space left in PYJETS and no error abort.
62729 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
62730 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
62732 ELSEIF(IP.LT.N) THEN
62733 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
62736 C...Include simple Bose-Einstein effect parametrization if desired.
62737 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
62742 C...Check that momentum, energy and charge were conserved.
62744 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
62746 PS(2,J)=PS(2,J)+P(I,J)
62748 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
62750 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
62751 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
62752 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
62753 &'(PYEXEC:) four-momentum was not conserved')
62754 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
62755 &'(PYEXEC:) charge was not conserved')
62760 C*********************************************************************
62763 C...Rearranges partons along strings.
62764 C...Special considerations for systems with junctions, with
62765 C...possibility of junction-antijunction annihilation.
62766 C...Allows small systems to collapse into one or two particles.
62767 C...Checks flavours and colour singlet invariant masses.
62769 SUBROUTINE PYPREP(IP)
62771 C...Double precision and integer declarations.
62772 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62773 INTEGER PYK,PYCHGE,PYCOMP
62775 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62776 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62777 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
62778 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62779 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62780 COMMON/PYINT1/MINT(400),VINT(400)
62781 C...The common block of colour tags.
62782 COMMON/PYCTAG/NCT,MCT(4000,2)
62783 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
62788 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
62789 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
62790 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
62791 &IJCP(0:6),TJUOLD(5)
62794 C...Function to give four-product.
62795 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)
62797 C...Rearrange parton shower product listing along strings: begin loop.
62805 DO 100 I=MAX(1,IP),N
62806 C...First store junction positions.
62807 IF(K(I,1).EQ.42) THEN
62815 DO 240 I=MAX(1,IP),N
62816 C...Special treatment for junctions
62817 IF (K(I,1).LE.0) GOTO 240
62818 IF(K(I,1).EQ.42) THEN
62819 C...MQGST=2: Look for junction-junction strings (not detected in the
62820 C...main search below).
62821 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
62822 IF (NJJSTR.EQ.0) THEN
62823 NJJSTR = (3*NJUNC-NPIECE)/2
62825 C...Check how many already identified strings end on this junction
62828 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
62830 C...If less than 3, remaining must be to another junction
62833 C...Multiple j-j connections not handled yet.
62835 & '(PYPREP:) Too many junction-junction strings.')
62839 C...The colour information in the junction is unreadable for the
62840 C...colour space search further down in this routine, so we must
62841 C...start on the colour mother of this junction and then "artificially"
62842 C...prevent the colour mother from connecting here again.
62843 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
62845 IF (MOD(ITJUNC,2).EQ.0) KCS=5
62846 C...Switch colour if the junction-junction leg is presumably a
62847 C...junction mother leg rather than a junction daughter leg.
62848 IF (ITJUNC.GE.3) KCS=9-KCS
62849 IF (MINT(33).EQ.0) THEN
62850 C...Find the unconnected leg and reorder junction daughter pointers so
62851 C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
62853 IA=MOD(K(I,4),MSTU(5))
62854 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
62855 ITMP=MOD(K(I,5),MSTU(5))
62856 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
62857 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
62858 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
62860 K(I,5)=K(I,5)+(IA-ITMP)
62862 K(I,4)=K(I,4)+(ITMP-IA)
62865 IF (ITJUNC.LE.2) THEN
62866 C...Beam baryon junction
62867 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
62868 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
62869 C...Else 1 -> 2 decay junction
62871 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
62872 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
62877 C...Alternatively use colour tag information.
62879 C...Find a final state parton with appropriate dangling colour tag.
62883 DO 140 J1=MAX(1,IP),N
62884 IF (K(J1,1).NE.3) GOTO 140
62885 C...Check for matching final-state colour tag
62887 DO 120 J2=MAX(1,IP),N
62888 IF (K(J2,1).NE.3) GOTO 120
62889 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
62891 IF (IMATCH.EQ.1) GOTO 140
62892 C...Check whether this colour tag belongs to the present junction
62893 C...by seeing whether any parton with this colour tag has the same
62894 C...mother as the junction.
62897 DO 130 J2=MINT(84)+1,N
62899 C...First scattering partons have IMO1 = 3 and 4.
62900 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
62902 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
62905 IF (IMATCH.EQ.0) GOTO 140
62908 C...Check for junction-junction strings without intermediate final state
62909 C...glue (not detected above).
62913 IF (IJU2.EQ.I) GOTO 160
62914 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
62915 C...Only opposite types of junctions can connect to each other.
62916 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
62919 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
62921 IF (IS.EQ.3) GOTO 160
62926 C...Switch to other side of adjacent parton and step from there.
62932 ELSE IF (ILC.NE.3) THEN
62937 C...Look for coloured string endpoint, or (later) leftover gluon.
62938 IF(K(I,1).NE.3) GOTO 240
62940 IF(KC.EQ.0) GOTO 240
62942 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
62944 C...Pick up loose string end.
62946 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
62952 IF(NSTP.GT.4*N) THEN
62953 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
62958 C...Copy undecayed parton. Finished if reached string endpoint.
62959 IF(K(IA,1).EQ.3) THEN
62960 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
62961 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
62968 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
62978 IF(K(I1,1).EQ.1) GOTO 240
62981 C...Also finished (for now) if reached junction; then copy to end.
62982 IF(K(IA,1).EQ.42) THEN
62984 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
62985 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
62990 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
62991 DO 200 ICOPY=1,NCOPY
62993 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
62994 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
62995 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
62999 C...For junction-junction strings, find end leg and reorder junction
63000 C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
63001 C...junction-junction string piece.
63002 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
63003 ITMP=MOD(K(IA,4),MSTU(5))
63004 IF (ITMP.NE.IB) THEN
63005 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
63006 K(IA,5)=K(IA,5)+(ITMP-IB)
63008 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
63010 K(IA,4)=K(IA,4)+(IB-ITMP)
63015 C...0: endpoint in original ER
63018 C...3: Parton immediately next to junction
63021 IPIECE(NPIECE,1)=MSTU32+1
63022 IPIECE(NPIECE,2)=MSTU32+NCOPY
63023 IPIECE(NPIECE,3)=IB
63024 IPIECE(NPIECE,4)=IA
63025 MSTU32=MSTU32+NCOPY
63030 C...GOTO next parton in colour space.
63032 IF (MINT(33).EQ.0) THEN
63033 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
63035 IA=MOD(K(IB,KCS),MSTU(5))
63036 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
63039 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
63040 & MSTU(5)).EQ.0) KCS=9-KCS
63041 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
63042 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
63045 IF(IA.LE.0.OR.IA.GT.N) THEN
63046 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
63047 IF(NERRPR.LT.5) THEN
63049 WRITE(MSTU(11),*) 'started at:', I
63050 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
63051 WRITE(MSTU(11),*) 'MQGST =',MQGST
63057 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
63058 & ,MSTU(5)).EQ.IB) THEN
63059 IF(MREV.EQ.1) KCS=9-KCS
63060 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
63061 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
63063 IF(MREV.EQ.0) KCS=9-KCS
63064 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
63065 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
63067 IF(IA.NE.I) GOTO 170
63068 C...Use colour tag information
63070 C...First create colour tags starting on IB if none already present.
63071 IF (MCT(IB,KCS-3).EQ.0) THEN
63072 CALL PYCTTR(IB,KCS,IB)
63073 IF(MINT(51).NE.0) RETURN
63077 C...Find final state tag partner
63078 DO 210 IT=MAX(1,IP),N
63079 IF (IT.EQ.IB) GOTO 210
63080 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
63086 C...Just copy and goto next if exactly one partner found.
63087 IF (IFOUND.EQ.1) THEN
63089 C...When no match found, match is presumably junction.
63090 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
63091 C...Check whether this colour tag matches a junction
63092 C...by seeing whether any parton with this colour tag has the same
63093 C...mother as a junction.
63094 C...NB: Only type 1 and 2 junctions handled presently.
63096 IJUMO=K(IJUNC(IJU,0),3)
63097 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
63098 C...Colours only connect to junctions, anti-colours to antijunctions:
63099 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
63101 DO 220 J1=MAX(1,IP),N
63102 IF (K(J1,1).LE.0) GOTO 220
63103 C...First scattering partons have IMO1 = 3 and 4.
63105 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
63107 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
63108 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
63110 C...Attempt at handling type > 3 junctions also. Not tested.
63111 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
63114 IF (IMATCH.EQ.0) GOTO 230
63119 IF (IFOUND.EQ.1) THEN
63121 ELSEIF (IFOUND.EQ.0) THEN
63123 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
63125 IF(NERRPR.LT.5) THEN
63132 ELSEIF (IFOUND.GE.2) THEN
63135 & ,'(PYPREP:) too many occurences of colour line: '//
63137 IF(NERRPR.LT.5) THEN
63149 C...Junction systems remain.
63155 260 IJUCNT=IJUCNT+1
63156 IF (IJUCNT.LE.NJUNC) THEN
63157 C...If we are not processing a j-j string, treat this junction as new.
63158 IF (IJJSTR.EQ.0) THEN
63159 IJU=IJUNC(IJUCNT,0)
63161 C...If junction has already been read, ignore it.
63162 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
63163 C...If we are on a j-j string, goto second j-j junction.
63168 C...Mark selected junction read.
63170 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
63172 C...Determine junction type
63173 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
63174 C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
63175 C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
63176 C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
63177 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
63180 C...Find which quarks belong to given junction.
63182 DO 290 IPC=1,NPIECE
63183 IF (IPIECE(IPC,4).EQ.IJU) THEN
63185 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
63187 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
63189 C...IHK = 3 is special. Either normal string piece, or j-j string.
63191 IF (MREV.NE.1) THEN
63192 DO 300 IPC=1,NPIECE
63193 C...If there is a j-j string starting on the present junction which has
63194 C...zero length, insert next junction immediately.
63195 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
63196 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
63202 C...If MREV is 1 and IHK is 3 we are finished with this system.
63209 C...If we've gotten this far, then either IHK < 3, or
63210 C...an interjunction string exists, or just a third normal string.
63211 IJUNC(IJUCNT,IHK)=0
63213 C..Order pieces belonging to this junction. Also look for j-j.
63214 DO 310 IPC=1,NPIECE
63215 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
63216 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
63217 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
63218 IJUNC(IJUCNT,IHK)=IPC
63223 C...Copy back chains in proper order. MREV=0/1 : descending/ascending
63224 IPC=IJUNC(IJUCNT,IHK)
63225 C...Temporary solution to cover for bug.
63227 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
63231 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
63234 K(I1,J)=K(MSTU(4)-ICP,J)
63235 P(I1,J)=P(MSTU(4)-ICP,J)
63236 V(I1,J)=V(MSTU(4)-ICP,J)
63240 C...Mark last quark.
63241 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
63242 C...Do not insert junctions at wrong places.
63243 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
63244 C...Insert junction.
63247 C...Shift to end junction if a j-j string has been processed.
63248 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
63258 K(IJUS,1)=K(IJUS,1)+10
63261 360 IF (IHK.LT.3) GOTO 280
63263 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
63267 IF (IJUCNT.NE.NJUNC) GOTO 260
63271 C...Rearrange three strings from junction, e.g. in case one has been
63272 C...shortened by shower, so the last is the largest-energy one.
63273 IF(NJUNC.GE.1) THEN
63274 C...Find systems with exactly one junction.
63278 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
63279 ELSEIF(K(I,1).EQ.41) THEN
63281 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
63286 C...Sum up energy-momentum in each junction string.
63293 DO 390 I1=NBEG,NEND
63294 IF(K(I1,2).NE.21) THEN
63299 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
63302 C...Find which of them has highest energy (minus mass) in rest frame.
63304 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
63306 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
63309 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
63310 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
63312 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
63313 C...Decide how to rearrange so that new last has highest energy.
63314 IF(PJU(1,6).LT.PJU(2,6)) THEN
63316 IRNG(1,2)=IJUR(2)-1
63318 IRNG(2,2)=IJUR(3)+1
63319 IRNG(4,1)=IJUR(3)-1
63323 IRNG(1,2)=IJUR(3)+1
63325 IRNG(2,2)=IJUR(3)-1
63326 IRNG(4,1)=IJUR(2)-1
63331 C...Copy in correct order below bottom of current event record.
63334 DO 430 I1=IRNG(II,1),IRNG(II,2),
63335 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
63337 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
63339 & '(PYPREP:) no more memory left in PYJETS')
63349 IF(K(I2,1).EQ.1) K(I2,1)=2
63353 C...Copy back up, overwriting but now in correct order.
63354 DO 460 I1=NBEG,NEND
63368 C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
63369 C...to two q-qbar systems.
63370 C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
63371 IF (MSTJ(19).NE.1) THEN
63375 C...Force collapse when MSTJ(19)=2.
63376 IF (MSTJ(19).EQ.2) THEN
63380 C...Find systems with exactly two junctions.
63382 C...Count junctions
63383 IF (K(I,1).EQ.41) THEN
63385 C...Check for interjunction gluons
63386 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
63389 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
63390 C...If end of system reached with either zero or one junction, restart
63391 C...with next system.
63395 ELSEIF(K(I,1).EQ.1) THEN
63396 C...If end of system reached with exactly two junctions, compute string
63397 C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
63398 C...length measure for the (q-qbar)(q-qbar) topology.
63400 C...Loop down through chain.
63402 DO 480 I1=NBEG,NEND
63403 C...Store string piece division locations in event record
63404 IF (K(I1,2).NE.21) THEN
63409 C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
63411 IF (PYR(0).LT.0.5D0) ISW=1
63412 C...Randomly choose which qqbar string gets the jj gluons.
63414 IF (PYR(0).GT.0.5D0) IGS=2
63415 C...Only compute string lengths when no topology forced.
63416 IF (MSTJ(19).EQ.0) THEN
63417 C...Repeat following for each junction
63419 C...Initialize iterative procedure for finding JRF
63425 C...Start iteration. Sum up momenta in string pieces
63427 C...JD=-1 for first junction, +1 for second junction.
63428 C...Find out where piece starts and ends and which direction to go.
63431 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
63432 IB = IJCP((IJU-1)*7 - JD*IJS)
63433 ELSEIF (IJS.EQ.3) THEN
63435 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
63436 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
63438 C...Initialize junction pull 4-vector.
63442 C...Initialize weight
63445 C...Sum up (weighted) momenta along each string piece
63446 DO 530 ISP=IA,IB,JD
63447 C...If present parton not last in chain
63448 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
63449 C...If last parton was a junction, store present weight
63450 IF (K(ISP-JD,2).EQ.88) THEN
63452 C...If last parton was a quark, reset to stored weight.
63453 ELSEIF (K(ISP-JD,2).NE.21) THEN
63457 C...Skip next parton if weight already large
63458 IF (PWT.GT.10D0) GOTO 530
63459 C...Compute momentum in TJUOLD frame:
63460 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
63462 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
63464 TMP=P(ISP,J)+TJUOLD(J)*BFC
63465 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
63468 TMP=TJUOLD(4)*P(ISP,4)+TDP
63469 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
63471 PWT=PWT+TMP/PARJ(48)
63472 C...Put |p| rather than m in 5th slot
63473 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
63480 C...Combine new boost (T) with old boost (TJUOLD)
63481 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
63483 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
63486 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
63488 C...If last boost small, accept JRF, else iterate.
63489 C...Also prevent possibility of infinite loop.
63490 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
63491 & IJRFIT.LT.MSTJ(18))THEN
63493 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
63494 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
63496 C...Store final boost, with change of sign since TJJ motion vector.
63498 TJJ(IJU,IX)=-TJUOLD(IX)
63500 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
63503 C...String length measure for (q-qbar)(q-qbar) topology.
63504 C...Note only momenta of nearest partons used (since rest of system
63506 IF (JJGLUE.EQ.0) THEN
63507 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
63508 & -1,IJCP(5-ISW)+1)
63510 C...Put jj gluons on selected string (IGS selected randomly above).
63512 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
63513 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
63515 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
63516 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
63520 C...String length measure for q-q-j-j-q-q topology.
63529 C...Note only momenta of nearest partons used (since rest of system
63532 IF (IX.EQ.4) ISGN=1
63533 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
63534 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
63535 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
63536 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
63537 IF (JJGLUE.EQ.0) THEN
63538 C...Junction motion vector dot product gives length when inter-junction
63540 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
63542 C...Junction motion vector dot products with gluon momenta give length
63543 C...when inter-junction gluons present.
63544 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
63545 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
63548 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
63549 IF (JJGLUE.EQ.0) THEN
63550 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
63552 DELMJJ=DELMJJ*4D0*T1G1*T2G2
63555 C...If delmjj > delmqq collapse string system to q-qbar q-qbar
63556 C...(Always the case for MSTJ(19)=2 due to initialization above)
63557 IF (DELMJJ.GT.DELMQQ) THEN
63558 C...Put new system at end of event record
63561 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
63564 P(NCOP,IX)=P(ICOP,IX)
63565 K(NCOP,IX)=K(ICOP,IX)
63568 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
63569 C...Insert inter-junction gluon string piece (reversed)
63571 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
63575 P(NCOP,IX)=P(ICOP,IX)
63576 K(NCOP,IX)=K(ICOP,IX)
63581 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
63584 P(NCOP,IX)=P(ICOP,IX)
63585 K(NCOP,IX)=K(ICOP,IX)
63590 C...Copy system back in right order
63591 DO 670 ICOP=NBEG,NEND-2
63593 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
63594 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
63597 C...Shift down rest of event record
63598 DO 690 ICOP=NEND+1,N
63600 P(ICOP-2,IX)=P(ICOP,IX)
63601 K(ICOP-2,IX)=K(ICOP,IX)
63604 C...Update length of event record.
63614 C...Done if no checks on small-mass systems.
63615 IF(MSTJ(14).LT.0) RETURN
63616 IF(MSTJ(14).EQ.0) GOTO 1140
63618 C...Find lowest-mass colour singlet jet system.
63623 DO 770 I=MAX(1,IP),N
63624 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
63625 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
63632 DPS(5)=PYMASS(K(I,2))
63633 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
63635 DPS(J)=DPS(J)+P(I,J)
63638 DPS(5)=DPS(5)+PYMASS(K(I,2))
63639 ELSEIF(K(I,1).EQ.2) THEN
63641 DPS(J)=DPS(J)+P(I,J)
63643 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
63645 DPS(J)=DPS(J)+P(I,J)
63648 DPS(5)=DPS(5)+PYMASS(K(I,2))
63649 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
63651 IF(PD.LT.PDMIN) THEN
63665 C...Done if lowest-mass system above threshold for string frag.
63666 IF(PDMIN.GE.PARJ(32)) GOTO 1140
63668 C...Fill small-mass system as cluster.
63670 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
63680 C...Set up history, assuming cluster -> 2 hadrons.
63686 IF(MSTU(16).NE.2) THEN
63701 C...Find total flavour content - complicated by presence of junctions.
63705 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
63708 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
63712 C...If several diquarks, split up one to give even number of flavours.
63713 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
63715 IF(IABS(KFQ(3)).LT.1000) I1=1
63716 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
63717 KFQ(I1)=KFQ(I1)/1000
63722 C...If four quark ends, join two to diquark.
63723 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
63726 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
63727 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
63728 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
63729 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
63730 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
63731 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
63737 C...If two quark ends, plus quark or diquark, join quarks to diquark.
63741 IF(IABS(KFQ(I1)).GT.1000) I1=3
63742 IF(IABS(KFQ(I2)).GT.1000) I2=3
63743 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
63744 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
63745 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
63746 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
63752 C...Form two particles from flavours of lowest-mass system, if feasible.
63754 790 NTRY = NTRY + 1
63756 C...Open string with two specified endpoint flavours.
63760 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
63761 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
63762 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
63763 IF(KQ1+KQ2.NE.0) GOTO 1140
63764 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
63766 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
63768 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
63769 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
63770 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
63772 C...Open string with four specified flavours.
63773 ELSEIF(NQ.EQ.4) THEN
63778 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
63779 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
63780 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
63781 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
63782 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
63783 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
63784 C...Combine flavours pairwise to form two hadrons.
63787 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
63788 & IABS(KFQ(2)).GT.1000)) I2=3
63789 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
63790 & IABS(KFQ(3)).GT.1000))) I2=4
63794 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
63795 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
63796 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
63800 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
63801 C...No room for popcorn mesons in closed string -> 2 hadrons.
63803 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
63804 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
63805 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
63806 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
63808 P(N+2,5)=PYMASS(K(N+2,2))
63809 P(N+3,5)=PYMASS(K(N+3,2))
63811 C...If it does not work: try again (a number of times), give up (if no
63812 C...place to shuffle momentum or too many flavours), or form one hadron.
63813 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
63814 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
63816 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
63823 C...Perform two-particle decay of jet system.
63824 C...First step: find reference axis in decaying system rest frame.
63825 C...(Borrow slot N+2 for temporary direction.)
63829 DO 850 I=IC1+1,IC2-1
63830 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
63831 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
63832 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
63834 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
63838 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
63840 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
63841 PHI1=PYANGL(P(N+2,1),P(N+2,2))
63843 C...Second step: generate isotropic/anisotropic decay.
63844 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
63845 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
63847 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
63848 PT2=(1D0-UE(3)**2)*PA**2
63849 IF(MSTJ(16).LE.0) THEN
63852 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
63853 PR1=P(N+2,5)**2+PT2
63854 PR2=P(N+3,5)**2+PT2
63855 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
63857 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
63858 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
63860 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
63862 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
63863 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
63868 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
63869 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
63871 C...Third step: move back to event frame and set production vertex.
63872 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
63882 C...Else form one particle, if possible.
63890 C...Select hadron flavour from available quark flavours.
63891 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
63893 ELSEIF(NQ.EQ.2) THEN
63894 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
63896 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
63897 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
63899 IF(K(N+2,2).EQ.0) GOTO 910
63900 P(N+2,5)=PYMASS(K(N+2,2))
63902 C...Use old algorithm for E/p conservation? (EN)
63903 IF (MSTJ(16).LE.0) GOTO 1080
63905 C...Find the string piece closest to the cluster by a loop
63906 C...over the undecayed partons not in present cluster. (EN)
63911 DO 940 I1=MAX(1,IP),N-1
63912 IF(K(I1,1).EQ.1) NJUNC=0
63913 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
63914 IF(K(I1,1).EQ.41) GOTO 940
63915 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
63917 ELSEIF(K(I1,1).EQ.2) THEN
63921 IF(K(I2,1).EQ.41) GOTO 940
63922 IF(K(I2,1).GT.10) GOTO 920
63923 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
63924 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
63925 & NJUNC.EQ.0) GOTO 940
63926 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
63927 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
63928 & K(I2,1).NE.1)) GOTO 940
63930 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
63932 E1(J)=P(I1,J)/P(I1,4)
63933 E2(J)=P(I2,J)/P(I2,4)
63934 ECL(J)=P(N+1,J)/P(N+1,4)
63939 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
63940 E3S=E3(1)**2+E3(2)**2+E3(3)**2
63941 E4S=E4(1)**2+E4(2)**2+E4(3)**2
63942 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
63943 IF(E34.LE.0D0) THEN
63945 ELSEIF(E34.LT.E3S) THEN
63946 DDMIN=E4S-E34**2/E3S
63948 DDMIN=E4S-2D0*E34+E3S
63951 C...Is this the smallest so far?
63952 IF(DDMIN.LT.DGLOMI) THEN
63957 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
63962 C... Check if there are any strings to connect to the new gluon. (EN)
63963 IF (IBEG.EQ.0) GOTO 1080
63965 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
63966 IF (P(N+1,5).GE.P(N+2,5)) THEN
63968 C...Construct 'gluon' that is needed to put hadron on the mass shell.
63969 FRAC=P(N+2,5)/P(N+1,5)
63971 P(N+2,J)=FRAC*P(N+1,J)
63972 PG(J)=(1D0-FRAC)*P(N+1,J)
63975 C... Copy string with new gluon put in.
63979 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
63980 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
64001 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
64004 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
64005 C...from string piece endpoints.
64008 C...Begin by copying string that should give energy to cluster.
64012 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
64013 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
64025 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
64028 C...Set initial Phad.
64030 P(NSAV+2,J)=P(NSAV+1,J)
64033 C...Calculate Pg, a part of which will be added to Phad later. (EN)
64034 1020 IF(MSTJ(16).EQ.1) THEN
64038 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
64039 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
64042 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
64044 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
64046 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
64047 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
64049 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
64050 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
64051 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
64053 C...If all gluon energy eaten, zero it and take a step back.
64055 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
64058 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
64064 IF(K(I1,1).EQ.41) ITER=-1
64066 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
64069 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
64075 IF(K(I2,1).EQ.41) ITER=-1
64077 IF(ITER.EQ.1) GOTO 1020
64079 C...If also all endpoint energy eaten, revert to old procedure.
64080 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
64081 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
64092 C... Construct the collapsed hadron and modified string partons.
64094 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
64095 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
64096 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
64098 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
64099 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
64101 C...Finished with string collapse in new scheme.
64105 C... Use old algorithm; by choice or when in trouble.
64107 C...Find parton/particle which combines to largest extra mass.
64112 IF(IR.NE.0) GOTO 1100
64113 DO 1090 I=MAX(1,IP),N
64114 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
64115 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
64116 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
64117 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
64118 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
64119 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
64121 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
64122 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
64123 IF(HSR.GT.HSM) THEN
64131 C...Shuffle energy and momentum to put new particle on mass shell.
64136 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
64137 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
64138 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
64140 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
64141 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
64145 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
64149 C...Mark collapsed system and store daughter pointers. Iterate.
64150 1120 DO 1130 I=IC1,IC2
64151 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
64152 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
64154 IF(MSTU(16).NE.2) THEN
64159 K(I,5)=NSAV+1+NBODY
64162 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
64164 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
64166 C...Check flavours and invariant masses in parton systems.
64174 DO 1180 I=MAX(1,IP),N
64175 IF(K(I,1).EQ.41) NJU=NJU+1
64176 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
64178 IF(KC.EQ.0) GOTO 1180
64179 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
64180 IF(KQ.EQ.0) GOTO 1180
64186 DPS(5)=DPS(5)+PYMASS(K(I,2))
64189 DPS(J)=DPS(J)+P(I,J)
64191 IF(K(I,1).EQ.1) THEN
64193 IF(NJU.EQ.0.AND.NP.NE.1) THEN
64194 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
64195 ELSEIF(NJU.EQ.1) THEN
64196 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
64197 ELSEIF(NJU.EQ.2) THEN
64198 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
64199 ELSEIF(NJU.GE.3) THEN
64202 IF(NFERR.EQ.1) THEN
64203 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
64207 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
64208 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
64209 & '(PYPREP:) too small mass in jet system')
64223 C*********************************************************************
64226 C...Handles the fragmentation of an arbitrary colour singlet
64227 C...jet system according to the Lund string fragmentation model.
64229 SUBROUTINE PYSTRF(IP)
64231 C...Double precision and integer declarations.
64232 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64233 IMPLICIT INTEGER(I-N)
64234 INTEGER PYK,PYCHGE,PYCOMP
64236 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64237 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64238 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64239 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
64240 C...Local arrays. All MOPS variables ends with MO
64241 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
64242 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
64243 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
64244 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
64245 &PBST(3,5),TJUOLD(5)
64247 C...Function: four-product of two vectors.
64248 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)
64249 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
64252 C...Reset counters.
64267 C...Identify parton system.
64270 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
64271 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
64272 IF(MSTU(21).GE.1) RETURN
64274 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
64276 IF(KC.EQ.0) GOTO 110
64277 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
64278 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
64279 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
64280 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
64281 IF(MSTU(21).GE.1) RETURN
64284 C...Take copy of partons to be considered. Check flavour sum.
64289 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
64291 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
64293 IF(KQ.NE.2) KQSUM=KQSUM+KQ
64294 IF(K(I,1).EQ.41) THEN
64295 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
64303 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
64304 IF(MOD(KQSUM,3).NE.0) THEN
64305 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
64306 IF(MSTU(21).GE.1) RETURN
64308 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
64310 C...Boost copied system to CM frame (for better numerical precision).
64311 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
64314 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
64318 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
64320 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
64321 IF(P(I,3).GT.0D0) THEN
64322 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
64323 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
64324 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
64326 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
64327 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
64328 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
64333 C...Search for very nearby partons that may be recombined.
64342 IF(MJU(1).GT.0) NRMIN=NRMIN+2
64343 IF(MJU(2).GT.0) NRMIN=NRMIN+2
64344 140 IF(NR.GT.NRMIN) THEN
64347 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
64349 IF(I.EQ.N+NR) I1=N+1
64350 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
64351 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
64353 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
64355 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
64356 & P(I1,2)**2+P(I1,3)**2))
64357 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
64358 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
64359 IF(PDR.LT.PDRMIN) THEN
64365 C...Recombine very nearby partons to avoid machine precision problems.
64366 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
64368 P(N+1,J)=P(N+1,J)+P(N+NR,J)
64370 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
64374 ELSEIF(PDRMIN.LT.PARU12) THEN
64376 P(IR,J)=P(IR,J)+P(IR+1,J)
64378 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
64380 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
64381 DO 190 I=IR+1,N+NR-1
64388 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
64390 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
64391 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
64397 C...Reset particle counter. Skip ahead if no junctions are present;
64398 C...this is usually the case!
64399 NRS=MAX(5*NR+11,NP)
64402 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64406 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
64407 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64408 IF(MSTU(21).GE.1) RETURN
64412 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
64413 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
64414 & ' junction strings not handled by MSTJ(12)>3 options')
64417 IF(MJU(JT).EQ.0) GOTO 640
64421 C...Find and sum up momentum on three sides of junction.
64422 C...Begin with previous boost = zero.
64427 C...Prevent IJU (specifically IJU(5)) from containing junk below
64433 C...Beginning and end of string system in event record.
64434 I1BEG=N+1+(JT-1)*(NR-1)
64435 I1END=N+NR+(JT-1)*(1-NR)
64436 C...Look for junction string piece end points
64437 DO 230 I1=I1BEG,I1END,JS
64438 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
64439 C...Store junction string piece end points.
64440 C 1-junction systems 2-junction systems
64441 C IU : 1 2 3 4 1 2 3 4 5 6
64442 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
64446 C...Sum over momenta, from junction outwards.
64450 C...Initialize junction drag and string piece 4-vectors.
64455 C...First two branches. Inwards out means opposite direction to JS.
64456 C...(JS is 1 for JT=1, -1 for JT=2)
64461 C...Last branch (gq or gjgqgq). Direction now reversed.
64467 DO 270 I1=I1A,I1B,IDIR
64468 C...Sum up momentum directions with exponential suppression
64469 C...for use in finding junction rest frame below.
64470 IF (K(I1,2).EQ.88) THEN
64471 C...gjgqgq type system encountered. Use current PWT as start
64472 C...for both strings.
64475 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
64476 C...Sum up string piece (boosted) 4-momenta.
64478 PJU(IU,J)=PJU(IU,J)+P(I1,J)
64480 C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
64481 C...boost is zero, see above). Skip parton if suppression factor large.
64482 IF (PWT.GT.10D0) GOTO 270
64483 C...Compute momentum in current frame:
64484 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
64485 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
64487 PTMP=P(I1,J)+TJUOLD(J)*BFC
64488 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
64491 PTMP=TJUOLD(4)*P(I1,4)+TDP
64492 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
64493 PWT=PWT+PTMP/PARJ(48)
64496 C...Put |p| rather than m in 5th slot.
64497 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
64498 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
64501 C...Calculate boost from present frame to next JRF candidate.
64503 CALL PYJURF(PBST,TJU)
64505 C...After some iterations do not take full step in new direction.
64506 IF(IJRFIT.GT.5) THEN
64507 REDUCE=0.8D0**(IJRFIT-5)
64508 TJU(1)=REDUCE*TJU(1)
64509 TJU(2)=REDUCE*TJU(2)
64510 TJU(3)=REDUCE*TJU(3)
64511 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
64514 C...Combine new boost (TJU) with old boost (TJUOLD)
64515 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
64517 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
64519 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
64521 C...If last boost small, accept JRF, else iterate.
64522 C...Also prevent possibility of infinite loop.
64523 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
64524 & IJRFIT.LT.MSTJ(18)) THEN
64526 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
64527 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
64530 C...Now store total boost in TJU and change perception.
64531 C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
64532 C...TJU = junction motion vector in string CM, so the sign changes.
64536 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
64540 C...Calculate string piece energies in junction rest frame.
64542 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
64544 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
64545 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
64548 C...Start preparing for fragmentation of two strings from junction.
64551 320 NTRYER=NTRYER+1
64554 NS=IABS(IJU(IU+1)-IJU(IU))
64556 C...Junction strings: find longitudinal string directions.
64558 IS1=IJU(IU)+JS*(IS-1)
64561 DP(1,J)=0.5D0*P(IS1,J)
64562 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
64563 DP(2,J)=0.5D0*P(IS2,J)
64564 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
64565 & (PJU(IU,5)/PBST(IU,5))
64567 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
64568 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
64572 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
64573 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64574 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64579 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
64580 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
64581 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
64583 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
64585 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
64586 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
64590 C...Junction strings: initialize flavour, momentum and starting pos.
64594 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64598 ELSEIF(NTRY.GT.100) THEN
64599 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64600 IF(MSTU(21).GE.1) RETURN
64605 IE(1)=K(N+1+(JT/2)*(NP-1),3)
64606 IF (MOD(JT+IU,2).NE.0) THEN
64608 IF (NP-NR.NE.0) THEN
64609 C...If gluons have disappeared. Original IJU must be used.
64613 IF (K(IT,2).NE.21) THEN
64616 IF (NE.EQ.IU+4*(JT-1)) THEN
64618 ELSEIF (IT.LE.IP+NP) THEN
64621 CALL PYERRM(14,'(PYSTRF:) '//
64622 & 'Original IJU could not be reconstructed!')
64630 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
64636 KFL(1)=K(IJU(IU),2)
64644 C...Junction strings: find initial transverse directions.
64647 DP(2,J)=P(IN(4)+1,J)
64651 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64652 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64653 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
64654 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
64655 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
64656 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
64657 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
64658 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
64659 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
64661 DHCX1=DFOUR(3,1)/DHC12
64662 DHCX2=DFOUR(3,2)/DHC12
64663 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
64664 DHCY1=DFOUR(4,1)/DHC12
64665 DHCY2=DFOUR(4,2)/DHC12
64666 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
64667 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
64669 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
64671 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
64675 C...Junction strings: produce new particle, origin.
64677 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
64678 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
64679 IF(MSTU(21).GE.1) RETURN
64687 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
64688 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
64689 IF(K(I,2).EQ.0) GOTO 360
64690 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
64691 & IABS(KFL(3)).GT.10) THEN
64692 IF(PYR(0).GT.PARJ(19)) GOTO 440
64694 P(I,5)=PYMASS(K(I,2))
64695 CALL PYPTDI(KFL(1),PX(3),PY(3))
64696 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
64697 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
64698 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
64699 & MSTU(90).LT.8) THEN
64700 MSTU(90)=MSTU(90)+1
64701 MSTU(90+MSTU(90))=I
64702 PARU(90+MSTU(90))=Z
64704 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
64709 C...Junction strings: stepping within 'low' string region.
64710 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
64711 & P(IN(1),5)**2.GE.PR(1)) THEN
64712 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
64713 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
64715 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
64718 C...Has used up energy of junction string, i.e. no more hadrons in it.
64719 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
64724 C...Stepping from 'low' string region
64725 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
64726 P(IN(2)+2,4)=P(IN(2)+2,3)
64729 IF(IN(2).GT.N+NR+4*NS) GOTO 360
64730 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
64731 P(IN(1)+2,4)=P(IN(1)+2,3)
64737 C...Junction strings: find new transverse directions.
64738 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
64739 & IN(1).GT.IN(2)) GOTO 360
64740 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
64747 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64748 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64750 IF(DHC12.LE.1D-2) THEN
64751 P(IN(1)+2,4)=P(IN(1)+2,3)
64757 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
64758 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
64759 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
64760 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
64761 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
64762 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
64763 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
64764 DHCX1=DFOUR(3,1)/DHC12
64765 DHCX2=DFOUR(3,2)/DHC12
64766 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
64767 DHCY1=DFOUR(4,1)/DHC12
64768 DHCY2=DFOUR(4,2)/DHC12
64769 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
64770 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
64772 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
64774 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
64777 C...Express pT with respect to new axes, if sensible.
64778 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
64779 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
64780 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
64786 C...Junction strings: sum up known four-momentum, coefficients for m2.
64789 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
64790 & PY(3)*P(IN(3)+1,J)
64791 DO 510 IN1=IN(4),IN(1)-4,4
64792 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
64794 DO 520 IN2=IN(5),IN(2)-4,4
64795 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
64799 DHM(2)=2D0*FOUR(I,IN(1))
64800 DHM(3)=2D0*FOUR(I,IN(2))
64801 DHM(4)=2D0*FOUR(IN(1),IN(2))
64803 C...Junction strings: find coefficients for Gamma expression.
64804 DO 550 IN2=IN(1)+1,IN(2),4
64805 DO 540 IN1=IN(1),IN2-1,4
64806 DHC=2D0*FOUR(IN1,IN2)
64807 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
64808 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
64809 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
64810 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
64814 C...Junction strings: solve (m2, Gamma) equation system for energies.
64815 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
64816 IF(ABS(DHS1).LT.1D-4) GOTO 360
64817 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
64818 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
64819 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
64820 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
64821 & ABS(DHS1)-DHS2/DHS1)
64822 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
64823 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
64824 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
64826 C...Junction strings: step to new region if necessary.
64827 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
64828 P(IN(2)+2,4)=P(IN(2)+2,3)
64831 IF(IN(2).GT.N+NR+4*NS) GOTO 360
64832 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
64833 P(IN(1)+2,4)=P(IN(1)+2,3)
64838 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
64839 P(IN(1)+2,4)=P(IN(1)+2,3)
64845 C...Junction strings: particle four-momentum, remainder, loop back.
64847 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
64848 & P(IN(2)+2,4)*P(IN(2),J)
64849 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
64851 IF(P(I,4).LT.P(I,5)) GOTO 360
64852 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
64853 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
64854 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
64859 IF(IN(3).NE.IN(6)) THEN
64861 P(IN(6),J)=P(IN(3),J)
64862 P(IN(6)+1,J)=P(IN(3)+1,J)
64867 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
64868 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
64873 C...Junction strings: save quantities left after each string.
64874 IF(IABS(KFL(1)).GT.10) GOTO 360
64878 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
64881 C...Junction strings: loopback if much unused energy in both strings.
64882 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
64883 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
64884 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
64886 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
64887 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
64888 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
64889 & .AND.NTRYER.LT.10) GOTO 320
64891 C...Junction strings: put together to new effective string endpoint.
64893 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
64894 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
64895 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
64896 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
64898 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
64899 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
64901 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
64906 C...Open versus closed strings. Choose breakup region for latter.
64907 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
64910 ELSEIF(MJU(1).NE.0) THEN
64913 ELSEIF(MJU(2).NE.0) THEN
64916 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
64923 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
64924 W2SUM=W2SUM+P(N+NR+IS,1)
64929 W2SUM=W2SUM-P(N+NR+NB,1)
64930 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
64933 C...Find longitudinal string directions (i.e. lightlike four-vectors).
64935 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
64936 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
64939 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
64940 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
64942 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
64943 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
64945 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
64946 & DP(1,2)**2-DP(1,3)**2))
64947 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
64948 & DP(2,2)**2-DP(2,3)**2))
64952 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
64953 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
64954 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
64955 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
64957 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
64959 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
64960 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
64964 C...Begin initialization: sum up energy, set starting position.
64968 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64972 ELSEIF(NTRY.GT.100) THEN
64973 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64974 IF(MSTU(21).GE.1) RETURN
64981 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
64986 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
64987 IF(NS.GT.NR) IRANK(JT)=1
64989 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
64990 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
64991 IN(3*JT+2)=IN(3*JT+1)+1
64992 IN(3*JT+3)=N+NR+4*NS+2*JT-1
64993 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
65000 C.. MOPS variables and switches
65006 C...Initialize flavour and pT variables for open string.
65010 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
65014 KFL(JT)=K(IE(JT),2)
65015 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
65016 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
65018 PMQ(JT)=PYMASS(KFL(JT))
65022 C...Closed string: random initial breakup flavour, pT and vertex.
65024 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65026 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
65027 C.. Closed string: first vertex diq attempt => enforced second
65029 IF(IABS(KFL(1)).GT.10)THEN
65034 IF(IBMO.EQ.1) MSTU(121)=-1
65036 CALL PYPTDI(KFL(1),PX(1),PY(1))
65039 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
65040 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
65041 ZR=PR3/(Z*P(N+NR+1,5)**2)
65042 IF(ZR.GE.1D0) GOTO 780
65045 PMQ(JT)=PYMASS(KFL(JT))
65046 GAM(JT)=PR3*(1D0-Z)/Z
65047 IN1=N+NR+3+4*(JT/2)*(NS-1)
65050 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
65053 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
65059 PM2QMO(JT)=PMQ(JT)**2
65060 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
65063 C...Find initial transverse directions (i.e. spacelike four-vectors).
65065 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
65074 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
65075 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
65076 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
65077 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
65078 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
65079 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
65080 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
65081 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
65082 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
65084 DHCX1=DFOUR(3,1)/DHC12
65085 DHCX2=DFOUR(3,2)/DHC12
65086 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
65087 DHCY1=DFOUR(4,1)/DHC12
65088 DHCY2=DFOUR(4,2)/DHC12
65089 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
65090 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
65092 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
65094 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
65099 P(IN3+2,J)=P(IN3,J)
65100 P(IN3+3,J)=P(IN3+1,J)
65105 C...Remove energy used up in junction string fragmentation.
65106 IF(MJU(1)+MJU(2).GT.0) THEN
65108 IF(NJS(JT).EQ.0) GOTO 860
65110 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
65114 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
65115 WMIN=PARJST+PMQ(1)+PMQ(2)
65116 WREM2=FOUR(N+NRS,N+NRS)
65117 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
65119 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
65124 C...Produce new particle: side, origin.
65126 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
65127 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
65128 IF(MSTU(21).GE.1) RETURN
65130 C.. New side priority for popcorn systems
65131 IF(MSTU(121).LE.0)THEN
65133 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
65134 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
65138 IRANK(JT)=IRANK(JT)+1
65143 C...Generate flavour, hadron and pT.
65145 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
65146 IF(K(I,2).EQ.0) GOTO 710
65148 IF(MSTU(121).EQ.-1) GOTO 910
65149 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
65150 &IABS(KFL(3)).GT.10) THEN
65151 IF(PYR(0).GT.PARJ(19)) GOTO 880
65153 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65155 P(I,5)=PYMASS(K(I,2))
65156 CALL PYPTDI(KFL(JT),PX(3),PY(3))
65157 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
65159 C...Final hadrons for small invariant mass.
65161 PMQ(3)=PYMASS(KFL(3))
65163 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
65164 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
65165 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
65166 &WMIN-0.5D0*PARJ(36)*PMQ(3)
65167 WREM2=FOUR(N+NRS,N+NRS)
65168 IF(WREM2.LT.0.10D0) GOTO 710
65169 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
65170 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
65172 C...Choose z, which gives Gamma. Shift z for heavy flavours.
65173 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
65174 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
65175 &MSTU(90).LT.8) THEN
65176 MSTU(90)=MSTU(90)+1
65177 MSTU(90+MSTU(90))=I
65178 PARU(90+MSTU(90))=Z
65182 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
65183 &MOD(KFL2A/1000,10)).GE.4) THEN
65184 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65185 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
65186 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
65187 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65188 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
65190 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
65192 C.. MOPS baryon model modification
65193 XTMO3=(1D0-Z)*XTMO(JT)
65194 IF(IABS(KFL(3)).LE.10) NRVMO=0
65195 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
65199 IF(IABS(KFL(JT)).LE.10)THEN
65200 XBMO=MIN(XTMO3,1D0-(2D-10))
65203 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
65204 GTSTMO=1D0-PARF(192)**PGMO
65206 IF(IRANK(JT).EQ.1) THEN
65211 IF(XBMO.LT.1D0-(1D-10))THEN
65212 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
65213 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
65216 IF(MSTJ(12).GE.5)THEN
65217 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
65218 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
65219 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
65224 C.. MOPS Accepting popcorn system hadron.
65225 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
65226 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
65228 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
65230 & '(PYSTRF:) no more memory left in PYJETS')
65231 IF(MSTU(21).GE.1) RETURN
65243 DO 890 LINE=1,I-N-NR
65244 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
65245 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
65252 C..Reject popcorn system, flag=-1 if enforcing new one
65254 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
65259 C..Lift restoring string outside MOPS block
65260 910 IF(MSTU(121).LT.0) THEN
65261 IF(MSTU(121).EQ.-2) MSTU(121)=0
65264 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
65275 DO 920 LINE=1,I-N-NR
65276 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
65277 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
65285 C.. MOPS end of modification
65291 C...Stepping within or from 'low' string region easy.
65292 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
65293 &P(IN(1),5)**2.GE.PR(JT)) THEN
65294 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
65295 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
65297 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
65300 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
65301 P(IN(JR)+2,4)=P(IN(JR)+2,3)
65304 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
65305 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
65306 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65312 C...Find new transverse directions (i.e. spacelike string vectors).
65313 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
65314 &IN(1).GT.IN(2)) GOTO 710
65315 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
65322 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
65323 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
65325 IF(DHC12.LE.1D-2) THEN
65326 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65332 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
65333 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
65334 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
65335 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
65336 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
65337 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
65338 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
65339 DHCX1=DFOUR(3,1)/DHC12
65340 DHCX2=DFOUR(3,2)/DHC12
65341 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
65342 DHCY1=DFOUR(4,1)/DHC12
65343 DHCY2=DFOUR(4,2)/DHC12
65344 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
65345 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
65347 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
65349 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
65352 C...Express pT with respect to new axes, if sensible.
65353 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
65354 & FOUR(IN(3*JT+3)+1,IN(3)))
65355 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
65356 & FOUR(IN(3*JT+3)+1,IN(3)+1))
65357 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
65363 C...Sum up known four-momentum. Gives coefficients for m2 expression.
65366 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
65367 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
65368 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
65369 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
65371 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
65372 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
65376 DHM(2)=2D0*FOUR(I,IN(1))
65377 DHM(3)=2D0*FOUR(I,IN(2))
65378 DHM(4)=2D0*FOUR(IN(1),IN(2))
65380 C...Find coefficients for Gamma expression.
65381 DO 1030 IN2=IN(1)+1,IN(2),4
65382 DO 1020 IN1=IN(1),IN2-1,4
65383 DHC=2D0*FOUR(IN1,IN2)
65384 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
65385 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
65386 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
65387 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
65391 C...Solve (m2, Gamma) equation system for energies taken.
65392 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
65393 IF(ABS(DHS1).LT.1D-4) GOTO 710
65394 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
65395 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
65396 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
65397 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
65398 &ABS(DHS1)-DHS2/DHS1)
65399 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
65400 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
65401 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
65403 C...Step to new region if necessary.
65404 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
65405 P(IN(JR)+2,4)=P(IN(JR)+2,3)
65408 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
65409 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
65410 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65415 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
65416 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65422 C...Four-momentum of particle. Remaining quantities. Loop back.
65424 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
65425 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
65427 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
65428 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
65430 IF(P(I,4).LT.P(I,5)) GOTO 710
65436 IF(IN(3).NE.IN(3*JT+3)) THEN
65438 P(IN(3*JT+3),J)=P(IN(3),J)
65439 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
65444 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
65445 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
65447 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65451 C...Final hadron: side, flavour, hadron, mass.
65457 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
65458 IF(K(I,2).EQ.0) GOTO 710
65459 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
65461 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65463 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65465 P(I,5)=PYMASS(K(I,2))
65466 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65468 C...Final two hadrons: find common setup of four-vectors.
65470 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
65471 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
65472 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
65473 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
65474 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
65475 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
65476 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
65477 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
65478 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
65479 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
65482 C...Solve kinematics for final two hadrons, if possible.
65483 WREM2=2D0*DHR1*DHR2*DHC12
65484 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
65485 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
65486 IF(FD.GE.1D0) GOTO 710
65487 FA=WREM2+PR(JT)-PR(JR)
65488 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
65490 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
65491 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
65492 FB=SIGN(FB,JS*(PYR(0)-PREV))
65495 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
65496 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
65497 &4D0*WREM2*PR(JT))),DBLE(JS))
65499 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
65500 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
65501 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
65502 P(I,J)=P(N+NRS,J)-P(I-1,J)
65504 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
65505 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
65506 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
65507 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
65509 IF(NTRYFN.LT.100) GOTO 140
65510 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
65513 C...Mark jets as fragmented and give daughter pointers.
65515 DO 1100 I=NSAV+1,NSAV+NP
65518 IF(MSTU(16).NE.2) THEN
65527 C...Document string system. Move up particles.
65538 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
65542 K(I,J)=K(I+NRS-1,J)
65543 P(I,J)=P(I+NRS-1,J)
65548 DO 1140 IZ=MSTU90+1,MSTU91
65549 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
65550 PARU9T(IZ)=PARU(90+IZ)
65554 C...Order particles in rank along the chain. Update mother pointer.
65557 K(I-NSAV+N,J)=K(I,J)
65558 P(I-NSAV+N,J)=P(I,J)
65562 DO 1190 I=N+1,2*N-NSAV
65563 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
65569 IF(MSTU(16).NE.2) K(I1,3)=NSAV
65570 DO 1180 IZ=MSTU90+1,MSTU91
65571 IF(MSTU9T(IZ).EQ.I) THEN
65572 MSTU(90)=MSTU(90)+1
65573 MSTU(90+MSTU(90))=I1
65574 PARU(90+MSTU(90))=PARU9T(IZ)
65578 DO 1220 I=2*N-NSAV,N+1,-1
65579 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
65585 IF(MSTU(16).NE.2) K(I1,3)=NSAV
65586 DO 1210 IZ=MSTU90+1,MSTU91
65587 IF(MSTU9T(IZ).EQ.I) THEN
65588 MSTU(90)=MSTU(90)+1
65589 MSTU(90+MSTU(90))=I1
65590 PARU(90+MSTU(90))=PARU9T(IZ)
65595 C...Boost back particle system. Set production vertices.
65598 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
65602 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
65603 IF(P(I,3).GT.0D0) THEN
65604 HHPEZ=(P(I,4)+P(I,3))*HHBZ
65605 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
65606 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65608 HHPEZ=(P(I,4)-P(I,3))/HHBZ
65609 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
65610 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65623 C*********************************************************************
65626 C...From three given input vectors in PJU the boost VJU from
65627 C...the "lab frame" to the junction rest frame is constructed.
65629 SUBROUTINE PYJURF(PJU,VJU)
65631 C...Double precision and integer declarations.
65632 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65633 IMPLICIT INTEGER(I-N)
65635 C...Input, output and local arrays.
65636 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
65637 DATA TWOPI/6.283186D0/
65639 C...Calculate masses and other invariants.
65641 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
65643 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
65644 PSUM(5)=SQRT(PSUM2)
65647 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
65648 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
65652 C...Pick I to be most massive parton and J to be the one closest to I.
65655 IF(A(2,2).GT.A(1,1)) I=2
65656 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
65660 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
65671 C...Trivial find new parton energies if all three partons are massless.
65672 IF(PMI2.LT.1D-4) THEN
65673 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
65674 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
65675 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
65677 C...Else find momentum range for parton I and values at extremes.
65683 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
65684 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
65685 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
65686 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
65687 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
65688 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
65689 HI=PEIMAX**2-0.25D0*PAIMAX**2
65690 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
65691 & 0.5D0*PAIMAX*AIJ)/HI
65692 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
65693 & 0.5D0*PAIMAX*AIK)/HI
65694 PEJMAX=SQRT(PAJMAX**2+PMJ2)
65695 PEKMAX=SQRT(PAKMAX**2+PMK2)
65696 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
65698 C...If unexpected values at upper endpoint then pick another parton.
65699 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
65701 IF(A(I1,I1).GE.1D-4) THEN
65707 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
65713 C..Start binary + linear search to find solution inside range.
65717 PAI=0.5D0*(PAIMIN+PAIMAX)
65720 C...Derive momentum of other two partons and distance to root.
65721 PEI=SQRT(PAI**2+PMI2)
65722 HI=PEI**2-0.25D0*PAI**2
65723 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
65724 PEJ=SQRT(PAJ**2+PMJ2)
65725 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
65726 PEK=SQRT(PAK**2+PMK2)
65727 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
65729 C...Pick next I momentum to explore, hopefully closer to root.
65730 IF(FNOW.GT.0D0) THEN
65739 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
65741 PAI=0.5D0*(PAIMIN+PAIMAX)
65743 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
65744 & ABS(FNOW).GT.1D-12*PSUM2) THEN
65745 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
65750 C...Now know energies in junction rest frame.
65755 C...Boost (copy of) partons to their rest frame.
65756 VXCM=-PSUM(1)/PSUM(5)
65757 VYCM=-PSUM(2)/PSUM(5)
65758 VZCM=-PSUM(3)/PSUM(5)
65759 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
65761 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
65762 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
65763 PCM(I,1)=PJU(I,1)+FAC2*VXCM
65764 PCM(I,2)=PJU(I,2)+FAC2*VYCM
65765 PCM(I,3)=PJU(I,3)+FAC2*VZCM
65766 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
65767 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
65770 C...Construct difference vectors and boost to junction rest frame.
65772 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
65773 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
65775 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
65776 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
65777 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
65778 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
65779 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
65780 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
65781 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
65782 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
65783 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
65784 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
65785 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
65787 C...Add two boosts, giving final result.
65788 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
65789 VJU(1)=VXJU+FCM*VXCM
65790 VJU(2)=VYJU+FCM*VYCM
65791 VJU(3)=VZJU+FCM*VZCM
65792 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
65795 C...In case of error in reconstruction: revert to CM frame of system.
65796 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
65797 &(PCM(1,5)*PCM(2,5))
65798 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
65799 &(PCM(1,5)*PCM(3,5))
65800 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
65801 &(PCM(2,5)*PCM(3,5))
65802 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
65803 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
65805 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
65806 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
65807 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
65808 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
65809 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
65810 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
65811 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
65813 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
65814 &(PCM(1,5)*PCM(2,5))
65815 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
65816 &(PCM(1,5)*PCM(3,5))
65817 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
65818 &(PCM(2,5)*PCM(3,5))
65819 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
65820 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
65821 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
65831 C*********************************************************************
65834 C...Handles the fragmentation of a jet system (or a single
65835 C...jet) according to independent fragmentation models.
65837 SUBROUTINE PYINDF(IP)
65839 C...Double precision and integer declarations.
65840 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65841 IMPLICIT INTEGER(I-N)
65842 INTEGER PYK,PYCHGE,PYCOMP
65844 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65845 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65846 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65847 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
65849 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
65850 &KFLO(2),PXO(2),PYO(2),WO(2)
65852 C.. MOPS error message
65853 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
65854 &' are not treated as expected in independent fragmentation')
65856 C...Reset counters. Identify parton system and take copy. Check flavour.
65866 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
65867 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
65868 IF(MSTU(21).GE.1) RETURN
65870 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
65872 IF(KC.EQ.0) GOTO 110
65873 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
65874 IF(KQ.EQ.0) GOTO 110
65876 IF(KQ.NE.2) KQSUM=KQSUM+KQ
65878 K(NSAV+NJET,J)=K(I,J)
65879 P(NSAV+NJET,J)=P(I,J)
65880 DPS(J)=DPS(J)+P(I,J)
65883 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
65884 &K(I+1,1).EQ.2)) GOTO 110
65885 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
65886 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
65887 IF(MSTU(21).GE.1) RETURN
65890 C...Boost copied system to CM frame. Find CM energy and sum flavours.
65893 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
65894 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
65900 DO 140 I=NSAV+1,NSAV+NJET
65904 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
65905 ELSEIF(KFA.GT.1000) THEN
65906 KFLA=MOD(KFA/1000,10)
65907 KFLB=MOD(KFA/100,10)
65908 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
65909 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
65913 C...Loop over attempts made. Reset counters.
65916 IF(NTRY.GT.200) THEN
65917 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
65918 IF(MSTU(21).GE.1) RETURN
65928 C...Loop over jets to be fragmented.
65929 DO 230 IP1=NSAV+1,NSAV+NJET
65934 C...Initial flavour and momentum values. Jet along +z axis.
65935 KFLH=IABS(K(IP1,2))
65936 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
65938 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
65940 C...Initial values for quark or diquark jet.
65941 170 IF(IABS(K(IP1,2)).NE.21) THEN
65944 CALL PYPTDI(0,PXO(1),PYO(1))
65947 C...Initial values for gluon treated like random quark jet.
65948 ELSEIF(MSTJ(2).LE.2) THEN
65950 IF(MSTJ(2).EQ.2) MSTJ(91)=1
65951 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65952 CALL PYPTDI(0,PXO(1),PYO(1))
65955 C...Initial values for gluon treated like quark-antiquark jet pair,
65956 C...sharing energy according to Altarelli-Parisi splitting function.
65959 IF(MSTJ(2).EQ.4) MSTJ(91)=1
65960 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65962 CALL PYPTDI(0,PXO(1),PYO(1))
65965 WO(1)=WF*PYR(0)**(1D0/3D0)
65969 C...Initial values for rank, flavour, pT and W+.
65979 C...New hadron. Generate flavour and hadron species.
65981 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
65982 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
65983 IF(MSTU(21).GE.1) RETURN
65990 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
65991 IF(K(I,2).EQ.0) GOTO 180
65992 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
65993 IF(PYR(0).GT.PARJ(19)) GOTO 200
65996 C...Find hadron mass. Generate four-momentum.
65997 P(I,5)=PYMASS(K(I,2))
65998 CALL PYPTDI(KFL1,PX2,PY2)
66001 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
66002 CALL PYZDIS(KFL1,KFL2,PR,Z)
66004 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
66006 MSTU(90)=MSTU(90)+1
66007 MSTU(90+MSTU(90))=I
66008 PARU(90+MSTU(90))=Z
66010 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
66011 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
66012 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
66013 & P(I,3).LE.0.001D0) THEN
66014 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
66020 C...Remaining flavour and momentum.
66029 C...Check if pL acceptable. Go back for new hadron if enough energy.
66030 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
66032 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
66034 IF(W.GT.PARJ(31)) GOTO 190
66037 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
66038 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
66040 C...Rotate jet to new direction.
66041 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
66042 PHI=PYANGL(P(IP1,1),P(IP1,2))
66044 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
66045 K(K(IP1,3),4)=NSAV1+1
66048 C...End of jet generation loop. Skip conservation in some cases.
66050 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
66051 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
66053 C...Subtract off produced hadron flavours, finished if zero.
66054 DO 240 I=NSAV+NJET+1,N
66056 KFLA=MOD(KFA/1000,10)
66057 KFLB=MOD(KFA/100,10)
66058 KFLC=MOD(KFA/10,10)
66060 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
66061 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
66063 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
66064 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
66065 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
66068 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66069 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66070 IF(NREQ.EQ.0) GOTO 320
66072 C...Take away flavour of low-momentum particles until enough freedom.
66076 DO 260 I=NSAV+NJET+1,N
66077 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
66078 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
66079 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
66081 IF(IREM.EQ.0) GOTO 150
66083 KFA=IABS(K(IREM,2))
66084 KFLA=MOD(KFA/1000,10)
66085 KFLB=MOD(KFA/100,10)
66086 KFLC=MOD(KFA/10,10)
66087 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
66088 IF(K(IREM,1).EQ.8) GOTO 250
66090 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
66091 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
66092 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
66094 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
66095 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
66096 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
66099 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66100 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66101 IF(NREQ.GT.NREM) GOTO 250
66102 DO 270 I=NSAV+NJET+1,N
66103 IF(K(I,1).EQ.8) K(I,1)=1
66106 C...Find combination of existing and new flavours for hadron.
66108 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
66109 IF(NREQ.LT.NREM) NFET=1
66110 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
66112 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
66113 KFLF(J)=ISIGN(1,NFL(1))
66114 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
66115 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
66117 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
66119 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
66120 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
66121 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
66122 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
66123 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
66124 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
66125 IF(NFET.LE.2) KFLF(3)=0
66126 IF(KFLF(3).NE.0) THEN
66127 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
66128 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
66129 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
66130 & KFLFC=KFLFC+ISIGN(2,KFLFC)
66134 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
66135 IF(KF.EQ.0) GOTO 280
66136 DO 300 J=1,MAX(2,NFET)
66137 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
66140 C...Store hadron at random among free positions.
66141 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
66142 DO 310 I=NSAV+NJET+1,N
66143 IF(K(I,1).EQ.7) NPOS=NPOS-1
66144 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
66147 P(I,5)=PYMASS(K(I,2))
66148 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66151 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66152 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66153 IF(NREM.GT.0) GOTO 280
66155 C...Compensate for missing momentum in global scheme (3 options).
66156 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
66159 DO 330 I=NSAV+NJET+1,N
66160 PSI(J)=PSI(J)+P(I,J)
66163 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
66165 DO 350 I=NSAV+NJET+1,N
66166 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
66167 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
66168 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
66169 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
66171 DO 370 I=NSAV+NJET+1,N
66172 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
66173 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
66174 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
66175 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
66177 P(I,J)=P(I,J)-PSI(J)*PW/PWS
66179 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66182 C...Compensate for missing momentum withing each jet separately.
66183 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
66184 DO 390 I=N+1,N+NJET
66190 DO 410 I=NSAV+NJET+1,N
66193 K(IR2,1)=K(IR2,1)+1
66194 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
66195 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
66197 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
66199 P(IR2,4)=P(IR2,4)+P(I,4)
66200 P(IR2,5)=P(IR2,5)+PLS
66203 DO 420 I=N+1,N+NJET
66204 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
66206 DO 440 I=NSAV+NJET+1,N
66209 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
66210 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
66212 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
66215 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66219 C...Scale momenta for energy conservation.
66220 IF(MOD(MSTJ(3),5).NE.0) THEN
66224 DO 450 I=NSAV+NJET+1,N
66227 PQS=PQS+P(I,5)**2/P(I,4)
66229 IF(PMS.GE.PECM) GOTO 150
66232 PFAC=(PECM-PQS)/(PES-PQS)
66235 DO 480 I=NSAV+NJET+1,N
66239 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66241 PQS=PQS+P(I,5)**2/P(I,4)
66243 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
66246 C...Origin of produced particles and parton daughter pointers.
66247 490 DO 500 I=NSAV+NJET+1,N
66248 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
66249 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
66251 DO 510 I=NSAV+1,NSAV+NJET
66254 IF(MSTU(16).NE.2) THEN
66258 K(I1,4)=K(I1,4)-NJET+1
66259 K(I1,5)=K(I1,5)-NJET+1
66260 IF(K(I1,5).LT.K(I1,4)) THEN
66267 C...Document independent fragmentation system. Remove copy of jets.
66278 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
66280 DO 540 I=NSAV+NJET,N
66282 K(I-NJET+1,J)=K(I,J)
66283 P(I-NJET+1,J)=P(I,J)
66284 V(I-NJET+1,J)=V(I,J)
66288 DO 550 IZ=MSTU90+1,MSTU(90)
66289 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
66292 C...Boost back particle system. Set production vertices.
66293 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
66294 &DPS(2)/DPS(4),DPS(3)/DPS(4))
66304 C*********************************************************************
66307 C...Handles the decay of unstable particles.
66309 SUBROUTINE PYDECY(IP)
66311 C...Double precision and integer declarations.
66312 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
66313 IMPLICIT INTEGER(I-N)
66314 INTEGER PYK,PYCHGE,PYCOMP
66316 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
66317 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
66318 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
66319 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
66320 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
66322 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
66323 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
66325 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
66327 C...Functions: momentum in two-particle decays and four-product.
66328 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
66329 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)
66331 C...Initial values.
66335 KFS=ISIGN(1,K(IP,2))
66339 C...Choose lifetime and determine decay vertex.
66340 IF(K(IP,1).EQ.5) THEN
66342 ELSEIF(K(IP,1).NE.4) THEN
66343 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
66346 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
66349 C...Determine whether decay allowed or not.
66351 IF(MSTJ(22).EQ.2) THEN
66352 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
66353 ELSEIF(MSTJ(22).EQ.3) THEN
66354 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
66355 ELSEIF(MSTJ(22).EQ.4) THEN
66356 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
66357 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
66359 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
66364 C...Interface to external tau decay library (for tau polarization).
66365 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
66367 C...Starting values for pointers and momenta.
66371 PCMTAU(J)=P(ITAU,J)
66374 C...Iterate to find position and code of mother of tau.
66376 120 IMTAU=K(IMTAU,3)
66378 IF(IMTAU.EQ.0) THEN
66379 C...If no known origin then impossible to do anything further.
66383 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
66384 C...If tau -> tau + gamma then add gamma energy and loop.
66385 IF(K(K(IMTAU,4),2).EQ.22) THEN
66387 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
66389 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
66391 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
66396 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
66397 C...If coming from weak decay of hadron then W is not stored in record,
66398 C...but can be reconstructed by adding neutrino momentum.
66399 KFORIG=-ISIGN(24,K(ITAU,2))
66401 DO 160 II=K(IMTAU,4),K(IMTAU,5)
66402 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
66404 PCMTAU(J)=PCMTAU(J)+P(II,J)
66410 C...If coming from resonance decay then find latest copy of this
66411 C...resonance (may not completely agree).
66414 DO 170 II=IMTAU+1,IP-1
66415 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
66416 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
66419 PCMTAU(J)=P(IORIG,J)
66423 C...Boost tau to rest frame of production process (where known)
66424 C...and rotate it to sit along +z axis.
66426 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
66428 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
66429 & -DBETAU(2),-DBETAU(3))
66430 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
66431 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
66432 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
66433 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
66435 C...Call tau decay routine (if meaningful) and fill extra info.
66436 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
66437 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
66438 DO 200 II=NSAV+1,NSAV+NDECAY
66447 C...Boost back decay tau and decay products.
66451 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
66452 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
66453 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
66454 & DBETAU(2),DBETAU(3))
66456 C...Skip past ordinary tau decay treatment.
66464 C...B-Bbar mixing: flip sign of meson appropriately.
66466 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
66468 IF(KFA.EQ.531) XBBMIX=PARJ(77)
66469 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
66470 IF(MMIX.EQ.1) KFS=-KFS
66473 C...Check existence of decay channels. Particle/antiparticle rules.
66475 IF(MDCY(KC,2).GT.0) THEN
66476 MDMDCY=MDME(MDCY(KC,2),2)
66477 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
66479 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
66480 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
66483 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
66484 IF(KCHG(KC,3).EQ.0) THEN
66487 IF(PYR(0).GT.0.5D0) KFS=-KFS
66488 ELSEIF(KFS.GT.0) THEN
66496 C...Sum branching ratios of allowed decay channels.
66499 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
66500 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
66501 & KFSN*MDME(IDL,1).NE.3) GOTO 230
66502 IF(MDME(IDL,2).GT.100) GOTO 230
66504 BRSU=BRSU+BRAT(IDL)
66507 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
66511 C...Select decay channel among allowed ones.
66512 240 RBR=BRSU*PYR(0)
66515 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
66516 &KFSN*MDME(IDL,1).NE.3) THEN
66517 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
66518 ELSEIF(MDME(IDL,2).GT.100) THEN
66519 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
66523 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
66526 C...Start readout of decay channel: matrix element, reset counters.
66529 IF(MOD(NTRY,200).EQ.0) THEN
66530 WRITE(CIDC,'(I4)') IDC
66531 C...Do not print warning for some well-known special cases.
66532 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
66533 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
66537 IF(NTRY.GT.1000) THEN
66538 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
66539 IF(MSTU(21).GE.1) RETURN
66545 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
66548 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
66550 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
66556 IF(KFA.GT.80) MHADDY=1
66557 C.. Random flavour and popcorn system memory.
66563 C...Read out decay products. Convert to standard flavour code.
66565 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
66567 IF(JT.LE.5) KP=KFDP(IDC,JT)
66568 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
66569 IF(KP.EQ.0) GOTO 280
66572 IF(KPA.GT.80) MHADDY=1
66573 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
66575 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
66577 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
66578 KFP=-KFS*MOD(KFA/10,10)
66579 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
66580 KFP=KFS*(100*MOD(KFA/10,100)+3)
66581 ELSEIF(KPA.EQ.81) THEN
66582 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
66583 ELSEIF(KP.EQ.82) THEN
66584 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
66585 IF(KFP.EQ.0) GOTO 260
66589 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
66590 ELSEIF(KP.EQ.-82) THEN
66593 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
66595 C...Add decay product to event record or to quark flavour list.
66598 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
66601 C...set rndmflav popcorn system pointer
66602 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
66604 PSQ=PSQ+PYMASS(KFLO(NQ))
66605 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
66606 & MOD(NQ,2).EQ.1) THEN
66611 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
66612 IF(K(I,2).EQ.0) GOTO 260
66614 P(I,5)=PYMASS(K(I,2))
66619 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
66620 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
66622 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
66623 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
66633 C...Check masses for resonance decays.
66634 IF(MHADDY.EQ.0) THEN
66635 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
66638 C...Choose decay multiplicity in phase space model.
66639 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
66641 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
66642 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
66644 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
66645 IF(IRNDMO.EQ.0) THEN
66648 ELSEIF(IRNDMO.EQ.1) THEN
66653 IF(NTRY.GT.1000) THEN
66654 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
66655 IF(MSTU(21).GE.1) RETURN
66657 IF(MMAT.LE.20) THEN
66658 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
66659 & SIN(PARU(2)*PYR(0))
66660 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
66661 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
66662 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
66663 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
66664 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
66668 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
66670 IF(MSTU(121).GT.MSTU(125)) GOTO 300
66672 C...Form hadrons from flavour content.
66676 IF(ND.EQ.NP+NQ/2) GOTO 330
66677 DO 320 I=N+NP+1,N+ND-NQ/2
66678 C.. Stick to started popcorn system, else pick side at random
66680 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
66681 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
66682 IF(K(I,2).EQ.0) GOTO 300
66683 MSTU(125)=MSTU(125)-1
66685 IF(MSTU(121).GT.0) JTMO=JT
66691 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
66692 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
66693 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
66696 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
66697 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
66698 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
66699 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
66701 C...Check that sum of decay product masses not too large.
66703 DO 340 I=N+NP+1,N+ND
66708 P(I,5)=PYMASS(K(I,2))
66711 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
66713 C...Rescale energy to subtract off spectator quark mass.
66714 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
66715 & .AND.NP.GE.3) THEN
66717 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
66719 P(N+NP,J)=PQT*PV(1,J)
66720 PV(1,J)=(1D0-PQT)*PV(1,J)
66722 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
66726 C...Fully specified final state: check mass broadening effects.
66728 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
66732 C...Determine position of grandmother, number of sisters.
66738 IF(IM.LT.0.OR.IM.GE.IP) IM=0
66739 IF(IM.NE.0) KFAM=IABS(K(IM,2))
66741 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
66742 IF(K(IL,3).EQ.IM) NM=NM+1
66743 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
66745 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
66746 & MOD(KFAM/1000,10).NE.0) NM=0
66748 KFAS=IABS(K(ISIS,2))
66749 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
66750 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
66755 C...Kinematics of one-particle decays.
66763 C...Calculate maximum weight ND-particle decay.
66766 WTMAX=1D0/WTCOR(ND-2)
66767 PMAX=PV(1,5)-PS+P(N+ND,5)
66769 DO 380 IL=ND-1,1,-1
66770 PMAX=PMAX+P(N+IL,5)
66771 PMIN=PMIN+P(N+IL+1,5)
66772 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
66776 C...Find virtual gamma mass in Dalitz decay.
66777 390 IF(ND.EQ.2) THEN
66778 ELSEIF(MMAT.EQ.2) THEN
66779 PMES=4D0*PMAS(11,1)**2
66780 PMRHO2=PMAS(131,1)**2
66781 PGRHO2=PMAS(131,2)**2
66782 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
66783 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
66784 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
66785 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
66786 IF(WT.LT.PYR(0)) GOTO 400
66787 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
66789 C...M-generator gives weight. If rejected, try again.
66794 DO 420 IL2=IL1-1,1,-1
66795 IF(RSAV.LE.RORD(IL2)) GOTO 430
66796 RORD(IL2+1)=RORD(IL2)
66798 430 RORD(IL2+1)=RSAV
66802 DO 450 IL=ND-1,1,-1
66803 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
66805 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
66807 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
66810 C...Perform two-particle decays in respective CM frame.
66811 460 DO 480 IL=1,ND-1
66812 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
66813 UE(3)=2D0*PYR(0)-1D0
66815 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
66816 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
66819 PV(IL+1,J)=-PA*UE(J)
66821 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
66822 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
66825 C...Lorentz transform decay products to lab frame.
66829 DO 530 IL=ND-1,1,-1
66831 BE(J)=PV(IL,J)/PV(IL,4)
66833 GA=PV(IL,4)/PV(IL,5)
66835 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
66837 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
66839 P(I,4)=GA*(P(I,4)+BEP)
66843 C...Check that no infinite loop in matrix element weight.
66845 IF(NTRY.GT.800) GOTO 560
66847 C...Matrix elements for omega and phi decays.
66849 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
66850 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
66851 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
66852 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
66854 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
66855 ELSEIF(MMAT.EQ.2) THEN
66856 FOUR12=FOUR(N+1,N+2)
66857 FOUR13=FOUR(N+1,N+3)
66858 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
66859 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
66860 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
66862 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
66863 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
66864 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
66865 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
66867 FOUR12=FOUR(IP,N+1)
66868 FOUR02=FOUR(IM,N+1)
66872 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
66873 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
66874 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
66875 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
66876 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
66877 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
66879 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
66880 ELSEIF(MMAT.EQ.4) THEN
66881 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
66882 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
66883 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
66884 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
66885 & ((1D0-HX3)/(HX1*HX2))**2
66886 IF(WT.LT.2D0*PYR(0)) GOTO 390
66887 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
66890 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
66891 ELSEIF(MMAT.EQ.41) THEN
66892 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
66893 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
66894 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
66895 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
66897 C...Matrix elements for weak decays (only semileptonic for c and b)
66898 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
66899 & .AND.ND.EQ.3) THEN
66900 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
66901 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
66902 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
66903 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
66907 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
66910 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
66911 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
66912 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
66915 C...Scale back energy and reattach spectator.
66916 560 IF(MREM.EQ.1) THEN
66918 PV(1,J)=PV(1,J)/(1D0-PQT)
66924 C...Low invariant mass for system with spectator quark gives particle,
66925 C...not two jets. Readjust momenta accordingly.
66926 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
66928 PM2=PYMASS(K(N+2,2))
66930 PM3=PYMASS(K(N+3,2))
66931 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
66932 & (PARJ(32)+PM2+PM3)**2) GOTO 630
66935 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
66936 IF(K(N+2,2).EQ.0) GOTO 260
66937 P(N+2,5)=PYMASS(K(N+2,2))
66938 PS=P(N+1,5)+P(N+2,5)
66943 ELSEIF(MMAT.EQ.44) THEN
66945 PM3=PYMASS(K(N+3,2))
66947 PM4=PYMASS(K(N+4,2))
66948 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
66949 & (PARJ(32)+PM3+PM4)**2) GOTO 600
66952 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
66953 IF(K(N+3,2).EQ.0) GOTO 260
66954 P(N+3,5)=PYMASS(K(N+3,2))
66956 P(N+3,J)=P(N+3,J)+P(N+4,J)
66958 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)
66959 HA=P(N+1,4)**2-P(N+2,4)**2
66960 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
66961 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
66962 & (P(N+1,3)-P(N+2,3))**2
66963 HD=(PV(1,4)-P(N+3,4))**2
66964 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
66967 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
66969 PCOR=HH*(P(N+1,J)-P(N+2,J))
66970 P(N+1,J)=P(N+1,J)+PCOR
66971 P(N+2,J)=P(N+2,J)-PCOR
66973 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)
66974 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)
66978 C...Check invariant mass of W jets. May give one particle or start over.
66979 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
66980 &.AND.IABS(K(N+1,2)).LT.10) THEN
66981 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
66983 PM1=PYMASS(K(N+1,2))
66985 PM2=PYMASS(K(N+2,2))
66986 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
66987 KFLDUM=INT(1.5D0+PYR(0))
66988 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
66989 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
66990 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
66991 PSM=PYMASS(KF1)+PYMASS(KF2)
66992 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
66993 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
66994 IF(MMAT.EQ.48) GOTO 390
66995 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
66998 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
66999 IF(K(N+1,2).EQ.0) GOTO 260
67000 P(N+1,5)=PYMASS(K(N+1,2))
67003 PS=P(N+1,5)+P(N+2,5)
67004 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
67011 C...Phase space decay of partons from W decay.
67012 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
67018 PV(1,J)=P(N+1,J)+P(N+2,J)
67027 PSQ=PYMASS(KFLO(1))
67029 PSQ=PSQ+PYMASS(KFLO(2))
67034 C...Boost back for rapidly moving particle.
67038 BE(J)=P(IP,J)/P(IP,4)
67042 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
67044 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
67046 P(I,4)=GA*(P(I,4)+BEP)
67050 C...Fill in position of decay vertex.
67058 C...Set up for parton shower evolution from jets.
67059 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
67063 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
67064 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
67065 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
67066 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
67067 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
67068 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
67070 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
67073 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
67074 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
67075 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
67076 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
67078 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
67079 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
67082 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
67083 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
67084 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
67085 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
67087 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
67088 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
67090 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
67095 KCP=PYCOMP(K(NSAV+1,2))
67096 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
67098 IF(KQP.LT.0) JCON=5
67099 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
67100 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
67101 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
67102 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
67104 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
67107 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
67108 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
67109 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
67110 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
67114 C...Mark decayed particle; special option for B-Bbar mixing.
67115 IF(K(IP,1).EQ.5) K(IP,1)=15
67116 IF(K(IP,1).LE.10) K(IP,1)=11
67117 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
67125 C*********************************************************************
67128 C...Handles flavour production in the decay of unstable particles
67129 C...and small string clusters.
67131 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
67133 C...Double precision and integer declarations.
67134 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67135 IMPLICIT INTEGER(I-N)
67136 INTEGER PYK,PYCHGE,PYCOMP
67138 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67139 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67140 SAVE /PYDAT1/,/PYDAT2/
67143 C.. Call PYKFDI directly if no popcorn option is on
67144 IF(MSTJ(12).LT.2) THEN
67145 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
67152 IF(KFL1.EQ.0) RETURN
67157 NMAX=MIN(MSTU(125),10)
67159 C.. Identify rank 0 cluster qq
67161 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
67164 C.. Join jets: Fails if store not empty
67165 IF(MSTU(121).GT.0) THEN
67169 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
67170 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
67171 C.. Pick popcorn meson from store, return same qq, decrease store
67172 KF=MSTU(NSTO+MSTU(121))
67174 MSTU(121)=MSTU(121)-1
67176 C.. Generate new flavour. Then done if no diquark is generated
67177 100 CALL PYKFDI(KFL1,0,KFL3,KF)
67178 IF(MSTU(121).EQ.-1) GOTO 100
67180 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
67182 C.. Simple case if no dynamical popcorn suppressions are considered
67183 IF(MSTJ(12).LT.4) THEN
67184 IF(MSTU(121).EQ.0) RETURN
67187 CALL PYKFDI(KFPREV,0,KFL3,KFM)
67188 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
67189 IF(IABS(KFL3).LE.10)THEN
67196 C test output qq against fake Gamma, then return if no popcorn.
67199 CALL PYZDIS(1,2103,5D0,Z)
67201 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
67206 IF(MSTU(121).EQ.0) RETURN
67208 C..Set store size memory. Pick fake dynamical variables of qq.
67210 CALL PYPTDI(1,PX3,PY3)
67216 C.. Pick next popcorn meson, test with fake dynamical variables
67220 CALL PYKFDI(KFPREV,0,KFL3,KFM)
67221 IF(MSTU(121).EQ.-1) GOTO 100
67222 CALL PYPTDI(KFL3,PX3,PY3)
67223 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
67224 CALL PYZDIS(KFPREV,KFL3,PM,Z)
67231 IF(MSTJ(12).GT.4)THEN
67232 POPMN=SQRT((1D0-X)*(G/X-GB))
67233 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
67234 PTST=EXP((POPM-POPMN)*PARF(193))
67239 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
67242 IF(RTST.GT.PTST*GTST)THEN
67244 IF(RTST.GT.PTST) MSTU(121)=-1
67249 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
67250 IF(MSTU(121).GT.0) GOTO 110
67252 C.. Test accepted system size. If OK set global popcorn size variable.
67253 IF(NMES.GT.NMAX)THEN
67264 C********************************************************************
67267 C...Generates a new flavour pair and combines off a hadron
67269 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
67271 C...Double precision and integer declarations.
67272 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67273 IMPLICIT INTEGER(I-N)
67274 INTEGER PYK,PYCHGE,PYCOMP
67276 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67277 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67278 SAVE /PYDAT1/,/PYDAT2/
67282 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
67284 C...Default flavour values. Input consistency checks.
67289 IF(KF1A.EQ.0) RETURN
67291 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
67292 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
67293 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
67296 C...Check if tabulated flavour probabilities are to be used.
67297 IF(MSTJ(15).EQ.1) THEN
67298 IF(MSTJ(12).GE.5) CALL PYERRM(29,
67299 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
67300 & ' together with MSTJ(12)>=5 modification')
67302 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
67303 KFL1A=MOD(KF1A/1000,10)
67304 KFL1B=MOD(KF1A/100,10)
67306 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
67307 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
67308 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
67309 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
67313 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
67314 KFL2A=MOD(KF2A/1000,10)
67315 KFL2B=MOD(KF2A/100,10)
67317 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
67318 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
67319 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
67321 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
67324 C.. Recognize rank 0 diquark case
67326 KFDIQ=MAX(KF1A,KF2A)
67327 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
67329 C.. Join two flavours to meson or baryon. Test for popcorn.
67332 IF(KFDIQ.GT.10) THEN
67333 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
67334 & CALL PYNMES(KFDIQ)
67335 IF(MSTU(121).NE.0) THEN
67346 C.. Separate incoming flavours, curtain flavour consistency check
67352 KFL1A=MOD(KF1A/1000,10)
67353 KFL1B=MOD(KF1A/100,10)
67356 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
67357 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
67358 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
67360 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
67364 KFQOLD=KFL1A+KFL1B-KFQPOP
67367 C...Meson/baryon choice. Set number of mesons if starting a popcorn
67370 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
67371 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
67375 ELSEIF(KF1A.GT.10)THEN
67377 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
67378 IF(MSTU(121).GT.0) MBARY=-1
67381 C..x->H+q: Choose single vertex quark. Jump to form hadron.
67382 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
67383 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
67384 KFL3=ISIGN(KFQVER,-KFIN)
67388 C..x->H+qq: (IDW=proper PARF position for diquark weights)
67391 IF(MSTU(121).EQ.0) IDW=150
67393 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
67394 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
67395 C.. Shift to s-curtain parameters if needed
67396 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
67397 PARF(194)=PARF(138)*PARF(139)
67398 PARF(193)=PARJ(8)+PARJ(9)
67402 C.. x->H+qq: Get vertex quark
67403 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
67405 MSTU(121)=MSTU(121)-1
67406 IF(IDW.EQ.170) THEN
67407 IF(MSTU(121).EQ.0)THEN
67408 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
67410 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
67413 IF(MSTU(121).EQ.0)THEN
67414 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
67416 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
67422 RMES=PYR(0)*PARF(194)
67424 RMES=RMES-PARF(IPOS+IMES)
67425 IF(IMES.EQ.30) THEN
67430 IF(RMES.GT.0D0) GOTO 120
67433 IF(KMUL.EQ.2) KFJ=10003
67434 IF(KMUL.EQ.3) KFJ=10001
67435 IF(KMUL.EQ.4) KFJ=20003
67436 IF(KMUL.EQ.5) KFJ=5
67438 KFQVER=MOD(IMES,5)+1
67439 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
67440 IF(KFQVER.GT.3)THEN
67445 IF(MBARY.EQ.-1) IDW=170
67447 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
67448 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
67449 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
67450 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
67452 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
67456 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
67458 IF(KFQPOP.NE.KFQVER)THEN
67460 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
67461 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
67462 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
67464 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
67466 KFL3=ISIGN(KFDIQ,KFIN)
67468 C..x->M+y: flavour for meson.
67469 130 IF(MBARY.LE.0)THEN
67470 KFLA=MAX(KFQOLD,KFQVER)
67471 KFLB=MIN(KFQOLD,KFQVER)
67473 IF(KFLA.NE.KFQOLD) KFS=-KFS
67474 C... Form meson, with spin and flavour mixing for diagonal states.
67475 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
67476 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
67477 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
67480 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
67481 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
67482 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
67483 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
67484 IF(PYR(0).LT.PARJ(14)) KMUL=2
67485 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
67487 IF(RMUL.LT.PARJ(15)) KMUL=3
67488 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
67489 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
67492 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
67493 IF(KMUL.EQ.5) KFLS=5
67494 IF(KFLA.NE.KFLB)THEN
67495 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
67498 IMIX=2*KFLA+10*KMUL
67499 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
67500 & INT(RMIX+PARF(IMIX)))+KFLS
67501 IF(KFLA.GE.4) KF=110*KFLA+KFLS
67503 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
67504 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
67506 C..Optional extra suppression of eta and eta'.
67507 C..Allow shift to qq->B+q in old version (set IRANK to 0)
67508 IF(KF.EQ.221.OR.KF.EQ.331)THEN
67509 IF(PYR(0).GT.PARJ(25+KF/300))THEN
67510 IF(KF2A.GT.0) GOTO 130
67511 IF(MSTJ(12).LT.4) IRANK=0
67517 C.. x->B+y: Flavour for baryon
67520 IF(KF1A.LE.10) KFLA=KFQOLD
67521 KFLB=MOD(KFDIQ/1000,10)
67522 KFLC=MOD(KFDIQ/100,10)
67523 KFLDS=MOD(KFDIQ,10)
67524 KFLD=MAX(KFLA,KFLB,KFLC)
67525 KFLF=MIN(KFLA,KFLB,KFLC)
67526 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
67528 C... SU(6) factors for formation of baryon.
67532 IF(KFLB.NE.KFLC)THEN
67535 IF(KFLB.GT.2) KDMAX=KDMAX+2
67537 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
67542 SU6MAX=PARF(140+KDMAX)
67545 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
67550 SU6OCT=PARF(60+KBARY)
67551 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
67552 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
67553 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
67555 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
67557 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
67559 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
67560 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
67562 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
67566 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
67569 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
67570 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
67572 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
67574 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
67575 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
67579 C...Use tabulated probabilities to select new flavour and hadron.
67580 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
67583 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
67586 ELSEIF(KTAB2.EQ.0) THEN
67595 DO 150 KT3=KT3L,KT3U
67596 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
67602 DO 170 KT3=KT3L,KT3U
67604 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
67605 IF(RFL.LE.0D0) GOTO 190
67610 C...Reconstruct flavour of produced quark/diquark.
67611 IF(KTAB3.LE.6) THEN
67614 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
67617 IF(KTAB3.GE.8) KFL3A=2
67618 IF(KTAB3.GE.11) KFL3A=3
67619 IF(KTAB3.GE.16) KFL3A=4
67620 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
67621 KFL3=1000*KFL3A+100*KFL3B+1
67622 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
67624 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
67627 C...Reconstruct meson code.
67628 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
67630 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
67631 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
67633 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
67634 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
67635 & 25*KTABS)) KF=330+2*KTABS+1
67636 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
67637 KFLA=MAX(KTAB1,KTAB3)
67638 KFLB=MIN(KTAB1,KTAB3)
67640 IF(KFLA.NE.KF1A) KFS=-KFS
67641 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
67642 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
67644 IF(KFL1A.EQ.KFL3A) THEN
67645 KFLA=MAX(KFL1B,KFL3B)
67646 KFLB=MIN(KFL1B,KFL3B)
67647 IF(KFLA.NE.KFL1B) KFS=-KFS
67648 ELSEIF(KFL1A.EQ.KFL3B) THEN
67652 ELSEIF(KFL1B.EQ.KFL3A) THEN
67655 ELSEIF(KFL1B.EQ.KFL3B) THEN
67656 KFLA=MAX(KFL1A,KFL3A)
67657 KFLB=MIN(KFL1A,KFL3A)
67658 IF(KFLA.NE.KFL1A) KFS=-KFS
67660 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
67663 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
67665 C...Reconstruct baryon code.
67667 IF(KTAB1.GE.7) THEN
67676 KFLD=MAX(KFLA,KFLB,KFLC)
67677 KFLF=MIN(KFLA,KFLB,KFLC)
67678 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
67679 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
67680 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
67683 C...Check that constructed flavour code is an allowed one.
67684 IF(KFL2.NE.0) KFL3=0
67687 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
67695 C*********************************************************************
67698 C...Generates number of popcorn mesons and stores some relevant
67701 SUBROUTINE PYNMES(KFDIQ)
67703 C...Double precision and integer declarations.
67704 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67705 IMPLICIT INTEGER(I-N)
67706 INTEGER PYK,PYCHGE,PYCOMP
67708 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67709 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67710 SAVE /PYDAT1/,/PYDAT2/
67713 IF(MSTJ(12).LT.2) RETURN
67715 C..Old version: Get 1 or 0 popcorn mesons
67716 IF(MSTJ(12).LT.5)THEN
67718 IF(KFDIQ.NE.0) THEN
67720 KFA=MOD(KFDIQA/1000,10)
67721 KFB=MOD(KFDIQA/100,10)
67724 IF(KFA.EQ.3) POPWT=PARF(133)
67725 IF(KFB.EQ.3) POPWT=PARF(134)
67726 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
67728 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
67732 C..New version: Store popcorn- or rank 0 diquark parameters
67735 PARF(194)=PARF(139)
67736 IF(KFDIQ.NE.0) THEN
67739 PARF(194)=PARF(140)
67741 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
67742 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
67743 & '(PYNMES:) Neglecting too large popcorn possibility')
67747 C..New version: Get number of popcorn mesons
67750 110 MSTU(121)=MSTU(121)+1
67751 RTST=RTST/PARF(194)
67752 IF(RTST.LT.1D0) GOTO 110
67753 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
67754 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
67758 C***************************************************************
67761 C...Precalculates a set of diquark and popcorn weights.
67765 C...Double precision and integer declarations.
67766 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67767 IMPLICIT INTEGER(I-N)
67768 INTEGER PYK,PYCHGE,PYCOMP
67770 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67771 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67772 SAVE /PYDAT1/,/PYDAT2/
67774 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
67778 C..Diquark indices for dimensional variables
67787 C.. *** SU(6) factors **
67788 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
67790 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
67791 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
67792 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
67795 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
67797 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
67798 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
67800 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
67801 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
67804 C..SU(6)max q q' s,c,b
67805 SU6MUD =MAX(SU6(1) , SU6(8) )
67806 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
67807 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
67808 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
67809 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
67810 SU6M(IUS0)=SU6M(ISU0)
67811 SU6M(ISS1)=SU6M(IUU1)
67812 SU6M(IUS1)=SU6M(ISU1)
67814 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
67816 PARF(142)=SU6M(IUD1)
67817 PARF(143)=SU6M(ISU0)
67818 PARF(144)=SU6M(ISU1)
67819 PARF(145)=SU6M(ISS1)
67821 C..diquark SU(6) survival =
67822 C..sum over quark (quark tunnel weight)*(SU(6)).
67823 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
67824 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
67825 DMB(IUS0)=DMB(ISU0)
67826 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
67827 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
67828 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
67829 DMB(IUS1)=DMB(ISU1)
67830 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
67832 C.. *** Tunneling factors for Diquark production***
67833 C.. T: half a curtain pair = sqrt(curtain pair factor)
67834 IF(MSTJ(12).GE.5) THEN
67836 PMUD1=PYMASS(2103)-PMUD0
67837 PMUS0=PYMASS(3201)-PMUD0
67838 PMUS1=PYMASS(3203)-PMUS0-PMUD0
67839 PMSS1=PYMASS(3303)-PMUS0-PMUD0
67840 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
67841 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
67842 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
67843 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
67844 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
67845 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
67846 QBB(IUD1)=QBB(IUU1)
67848 PAR2M=SQRT(PARJ(2))
67849 PAR3M=SQRT(PARJ(3))
67850 PAR4M=SQRT(PARJ(4))
67851 QBB(ISU0)=PAR2M*PAR3M
67853 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
67855 QBB(ISU1)=PAR4M*QBB(ISU0)
67856 QBB(IUS1)=PAR4M*QBB(IUS0)
67860 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
67861 QBM(ISU0)=QBB(ISU0)
67862 QBM(IUS0)=PARJ(2)*QBB(IUS0)
67863 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
67864 QBM(IUU1)=6D0*QBB(IUU1)
67865 QBM(ISU1)=3D0*QBB(ISU1)
67866 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
67867 QBM(IUD1)=3D0*QBB(IUD1)
67869 C.. Combine T and tau to diquark weight for q-> B+B+..
67871 QBB(I)=QBB(I)*QBM(I)
67874 IF(MSTJ(12).GE.5)THEN
67875 C..New version: tau for rank 0 diquark.
67876 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
67877 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
67878 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
67879 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
67880 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
67881 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
67882 DMB(7+IUD1)=DMB(7+IUU1)/2D0
67884 C..New version: curtain flavour ratios.
67885 C.. s/u for q->B+M+...
67886 C.. s/u for rank 0 diquark: su -> ...M+B+...
67887 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67888 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
67889 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
67890 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
67891 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
67892 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
67893 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
67895 C..Old version: reset unused rank 0 diquark weights and
67896 C.. unused diquark SU(6) survival weights
67898 IF(MSTJ(12).LT.3) DMB(I)=1D0
67902 C..Old version: Shuffle PARJ(7) into tau
67903 QBM(IUS0)=QBM(IUS0)*PARJ(7)
67904 QBM(ISS1)=QBM(ISS1)*PARJ(7)
67905 QBM(IUS1)=QBM(IUS1)*PARJ(7)
67907 C..Old version: curtain flavour ratios.
67908 C.. s/u for q->B+M+...
67909 C.. s/u for rank 0 diquark: su -> ...M+B+...
67910 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67911 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
67912 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
67913 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
67914 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
67917 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
67918 C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
67920 DMB(7+I)=DMB(7+I)*DMB(I)
67921 DMB(I)=DMB(I)*QBM(I)
67922 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
67923 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
67926 C.. *** Popcorn factors ***
67928 IF(MSTJ(12).LT.5)THEN
67929 C.. Old version: Resulting popcorn weights.
67931 WS=PARF(135)*PARF(138)
67933 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
67935 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
67936 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
67937 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
67938 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
67939 & (1D0+QBB(IUD1)+QBB(IUU1)+
67940 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
67942 C..New version: Store weights for popcorn mesons,
67943 C..get prel. popcorn weights.
67944 DO 150 IPOS=201,1400
67953 IF(MR.EQ.7) PARF(193)=PARJ(10)
67954 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
67955 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
67956 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
67958 IF(NMES.EQ.1) SQWT=PARJ(2)
67960 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
67961 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
67962 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
67964 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
67965 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
67968 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
67970 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
67971 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
67977 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
67978 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
67979 IF(PJWT.LE.0D0) GOTO 190
67980 IF(PJWT.GT.1D0) PJWT=1D0
67982 IMIX=2*KFQOLD+10*KMUL
67984 IF(KMUL.EQ.2) KFJ=10003
67985 IF(KMUL.EQ.3) KFJ=10001
67986 IF(KMUL.EQ.4) KFJ=20003
67987 IF(KMUL.EQ.5) KFJ=5
67989 KFLA=MAX(KFQOLD,KFQVER)
67990 KFLB=MIN(KFQOLD,KFQVER)
67991 SWT=PARJ(11+KFLA/3+KFLA/4)
67992 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
67994 QWT=SQWT/(2D0+SQWT)
67995 IF(KFQVER.LT.3)THEN
67996 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
67997 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
67999 IF(KFQVER.NE.KFQOLD)THEN
68001 KFM=100*KFLA+10*KFLB+KFJ
68002 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68003 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
68004 WTTOT=WTTOT+PARF(IPOS+IMES)
68007 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
68008 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
68009 IF(ID.EQ.5) DWT=PARF(IMIX)
68011 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68012 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
68013 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
68014 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
68015 PARF(IPOS+5*KMUL+ID)=
68016 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
68018 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
68024 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
68026 IF(MR.EQ.7) PARF(140)=
68027 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
68028 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
68029 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
68035 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
68040 C..Recombine diquark weights to flavour and spin ratios
68041 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
68042 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
68043 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
68044 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
68045 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
68046 PARF(155)=QBB(ISU1)/QBB(ISU0)
68047 PARF(156)=QBB(IUS1)/QBB(IUS0)
68048 PARF(157)=QBB(IUD1)
68050 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
68051 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
68052 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
68053 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
68054 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
68055 PARF(165)=QBM(ISU1)/QBM(ISU0)
68056 PARF(166)=QBM(IUS1)/QBM(IUS0)
68057 PARF(167)=QBM(IUD1)
68059 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
68060 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
68061 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
68062 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
68063 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
68064 PARF(175)=DMB(ISU1)/DMB(ISU0)
68065 PARF(176)=DMB(IUS1)/DMB(IUS0)
68066 PARF(177)=DMB(IUD1)
68068 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
68069 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
68070 PARF(187)=DMB(7+IUD1)
68076 C*********************************************************************
68079 C...Generates transverse momentum according to a Gaussian.
68081 SUBROUTINE PYPTDI(KFL,PX,PY)
68083 C...Double precision and integer declarations.
68084 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68085 IMPLICIT INTEGER(I-N)
68086 INTEGER PYK,PYCHGE,PYCOMP
68088 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68091 C...Generate p_T and azimuthal angle, gives p_x and p_y.
68093 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
68094 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
68095 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
68096 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
68104 C*********************************************************************
68107 C...Generates the longitudinal splitting variable z.
68109 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
68111 C...Double precision and integer declarations.
68112 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68113 IMPLICIT INTEGER(I-N)
68114 INTEGER PYK,PYCHGE,PYCOMP
68116 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68117 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68118 SAVE /PYDAT1/,/PYDAT2/
68120 C...Check if heavy flavour fragmentation.
68124 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
68126 C...Lund symmetric scaling function: determine parameters of shape.
68127 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
68128 &MSTJ(11).GE.4) THEN
68130 IF(MSTJ(91).EQ.1) FA=PARJ(43)
68131 IF(KFLB.GE.10) FA=FA+PARJ(45)
68133 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
68136 IF(KFLA.GE.10) FC=FC-PARJ(45)
68137 IF(KFLB.GE.10) FC=FC+PARJ(45)
68138 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
68140 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
68141 FC=FC+FRED*FBB*PARF(100+KFLH)**2
68144 IF(ABS(FC-1D0).GT.0.01D0) MC=2
68146 C...Determine position of maximum. Special cases for a = 0 or a = c.
68147 IF(FA.LT.0.02D0) THEN
68150 IF(FC.GT.FB) ZMAX=FB/FC
68151 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
68156 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
68157 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
68160 C...Subdivide z range if distribution very peaked near endpoint.
68162 IF(ZMAX.LT.0.1D0) THEN
68168 ZDIVC=ZDIV**(1D0-FC)
68169 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
68171 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
68173 FSCB=SQRT(4D0+(FC/FB)**2)
68174 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
68175 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
68176 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
68177 FINT=1D0+FB*(1D0-ZDIV)
68180 C...Choice of z, preweighted for peaks at low or high z.
68184 IF(FINT*PYR(0).LE.1D0) THEN
68186 ELSEIF(MC.EQ.1) THEN
68190 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
68193 ELSEIF(MMAX.EQ.3) THEN
68194 IF(FINT*PYR(0).LE.1D0) THEN
68196 FPRE=EXP(FB*(Z-ZDIV))
68198 Z=ZDIV+Z*(1D0-ZDIV)
68202 C...Weighting according to correct formula.
68203 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
68204 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
68205 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
68206 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
68207 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
68209 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
68211 FC=PARJ(50+MAX(1,KFLH))
68212 IF(MSTJ(91).EQ.1) FC=PARJ(59)
68214 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
68215 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
68216 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
68217 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
68220 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
68221 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
68228 C*********************************************************************
68231 C...Generates timelike parton showers from given partons.
68233 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
68235 C...Double precision and integer declarations.
68236 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68237 IMPLICIT INTEGER(I-N)
68238 INTEGER PYK,PYCHGE,PYCOMP
68239 C...Parameter statement to help give large particle numbers.
68240 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
68241 &KEXCIT=4000000,KDIMEN=5000000)
68242 PARAMETER (MAXNUR=1000)
68244 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
68245 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
68246 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68247 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68248 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
68249 COMMON/PYINT1/MINT(400),VINT(400)
68250 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
68252 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
68253 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
68254 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
68255 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
68258 C...Check that QMAX not too low.
68259 IF(MSTJ(41).LE.0) THEN
68261 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
68262 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
68264 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
68268 C...Store positions of shower initiating partons.
68270 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
68273 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
68278 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
68279 & .AND.IP2.GE.-80) THEN
68284 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
68292 & '(PYSHOW:) failed to reconstruct showering system')
68293 IF(MSTU(21).GE.1) RETURN
68296 C...Send off to PYPTFS for pT-ordered evolution if requested,
68297 C...if at least 2 partons, and without predefined shower branchings.
68298 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
68303 PTPART(II)=0.5D0*QMAX
68305 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
68309 C...Initialization of cutoff masses etc.
68317 PMTH(1,21)=PYMASS(21)
68318 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
68319 PMTH(3,21)=2D0*PMTH(2,21)
68320 PMTH(4,21)=PMTH(3,21)
68321 PMTH(5,21)=PMTH(3,21)
68322 PMTH(1,22)=PYMASS(22)
68323 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
68324 PMTH(3,22)=2D0*PMTH(2,22)
68325 PMTH(4,22)=PMTH(3,22)
68326 PMTH(5,22)=PMTH(3,22)
68328 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
68329 PMQT1E=MIN(PMQTH1,PARJ(90))
68331 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
68332 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
68335 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
68337 PMTH(1,IFL)=PYMASS(IFL)
68338 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
68339 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
68340 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
68341 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
68344 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
68345 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
68346 PMTH(1,IFL)=PYMASS(IFL)
68347 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
68348 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
68349 PMTH(4,IFL)=PMTH(3,IFL)
68350 PMTH(5,IFL)=PMTH(3,IFL)
68352 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
68354 ALFM=LOG(PT2MIN/ALAMS)
68356 C...Check on phase space available for emission.
68364 KFLA(I)=IABS(K(IPA(I),2))
68366 C...Special cutoff masses for initial partons (may be a heavy quark,
68367 C...squark, ..., and need not be on the mass shell).
68369 IF(NPA.LE.1) IREF(I)=IR
68370 IF(NPA.GE.2) IREF(I+1)=IR
68374 IF(KFLA(I).LE.8) THEN
68376 IF(MSTJ(41).GE.2) ISCHG(IR)=1
68377 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
68378 & KFLA(I).EQ.17) THEN
68379 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
68380 ELSEIF(KFLA(I).EQ.21) THEN
68382 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
68383 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
68385 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
68388 C...same for QQ~[3S18]
68389 ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
68390 & KFLA(I).EQ.9900553)) THEN
68395 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
68396 C...(only intended for studying the effects of switching such rad on/off)
68397 IF (MSTJ(39).GT.0.AND.KFLA(I).EQ.MSTJ(39)) THEN
68402 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
68404 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
68405 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
68406 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
68407 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
68408 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
68409 ELSEIF(ISCOL(IR).EQ.1) THEN
68410 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
68411 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
68412 PMTH(4,IR)=PMTH(3,IR)
68413 PMTH(5,IR)=PMTH(3,IR)
68414 ELSEIF(ISCHG(IR).EQ.1) THEN
68415 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
68416 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
68417 PMTH(4,IR)=PMTH(3,IR)
68418 PMTH(5,IR)=PMTH(3,IR)
68420 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
68422 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
68424 PS(J)=PS(J)+P(IPA(I),J)
68427 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
68428 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
68429 IF(NPA.EQ.1) PS(5)=PS(4)
68430 IF(PS(5).LE.PM+PMQT1E) RETURN
68432 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
68435 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
68436 KFSRCE=IABS(K(K(IP1,3),2))
68438 IPAR1=MAX(1,K(IP1,3))
68439 IPAR2=MAX(1,K(IP2,3))
68440 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
68441 & KFSRCE=IABS(K(K(IPAR1,3),2))
68444 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
68445 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
68446 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
68447 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
68448 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
68449 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
68450 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
68451 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
68453 C...Identify two primary showerers.
68455 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
68456 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
68457 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
68458 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
68459 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
68460 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
68461 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
68462 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
68464 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
68465 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
68466 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
68467 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
68468 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
68469 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
68470 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
68471 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
68473 C...Order of showerers. Presence of gluino.
68474 ITYPMN=MIN(ITYPE1,ITYPE2)
68475 ITYPMX=MAX(ITYPE1,ITYPE2)
68477 IF(ITYPE1.GT.ITYPE2) IORD=2
68479 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
68481 C...Check if 3-jet matrix elements to be used.
68484 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
68485 IF(MSTJ(38).NE.0) THEN
68489 ELSEIF(MSTJ(47).GE.6) THEN
68495 C...Vector/axial vector -> q + qbar; q -> q + V.
68496 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
68497 & ITYPES.EQ.3)) THEN
68499 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
68501 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
68502 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
68503 C...gamma*/Z0: assume e+e- initial state if unknown.
68505 IF(KFSRCE.EQ.23) THEN
68506 IANNFL=K(K(IP1,3),3)
68507 IF(IANNFL.NE.0) THEN
68508 KANNFL=IABS(K(IANNFL,2))
68509 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
68512 AI=SIGN(1D0,EI+0.1D0)
68513 VI=AI-4D0*EI*PARU(102)
68514 EF=KCHG(KFLA(1),1)/3D0
68515 AF=SIGN(1D0,EF+0.1D0)
68516 VF=AF-4D0*EF*PARU(102)
68517 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
68520 SQWZ=PS(5)*PMAS(23,2)
68521 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
68522 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
68523 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
68524 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
68526 ALPHA=VECT/(VECT+AXIV)
68527 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
68530 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
68531 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
68533 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
68534 & ITYPES.EQ.1)) THEN
68537 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
68538 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
68540 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
68542 ELSEIF(KFSRCE.EQ.36) THEN
68545 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
68546 & ITYPES.EQ.1)) THEN
68549 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
68550 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
68551 & ITYPES.EQ.3)) THEN
68553 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
68554 & ITYPES.EQ.2)) THEN
68556 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
68558 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
68559 & ITYPES.EQ.2)) THEN
68562 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
68563 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
68564 & ITYPES.EQ.5)) THEN
68566 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
68567 & ITYPES.EQ.2)) THEN
68569 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
68570 & ITYPES.EQ.1)) THEN
68573 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
68574 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
68576 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
68577 & ITYPES.EQ.2)) THEN
68579 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
68580 & ITYPES.EQ.1)) THEN
68583 C...g -> ~g + ~g (eikonal approximation).
68584 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
68587 M3JC=5*ICLASS+ICOMBI
68591 C...Find if interference with initial state partons.
68593 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
68594 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
68595 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
68600 KCA=PYCOMP(KFLA(I))
68601 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
68603 IF(KCII(I).NE.0) THEN
68605 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
68606 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
68607 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
68609 IIIS(I,NIIS(I))=ICSI
68614 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
68617 C...Boost interfering initial partons to rest frame
68618 C...and reconstruct their polar and azimuthal angles.
68622 K(N+I,J)=K(IPA(I),J)
68623 P(N+I,J)=P(IPA(I),J)
68627 DO 230 I=3,2+NIIS(1)
68629 K(N+I,J)=K(IIIS(1,I-2),J)
68630 P(N+I,J)=P(IIIS(1,I-2),J)
68634 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
68636 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
68637 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
68641 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
68642 & -PS(2)/PS(4),-PS(3)/PS(4))
68643 PHI=PYANGL(P(N+1,1),P(N+1,2))
68644 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
68645 THE=PYANGL(P(N+1,3),P(N+1,1))
68646 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
68647 DO 260 I=3,2+NIIS(1)
68648 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
68649 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
68651 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
68652 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
68653 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
68654 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
68658 C...Boost 3 or more partons to their rest frame.
68659 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
68660 &-PS(2)/PS(4),-PS(3)/PS(4))
68662 C...Define imagined single initiator of shower for parton system.
68664 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
68665 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
68666 IF(MSTU(21).GE.1) RETURN
68685 C...Loop over partons that may branch.
68688 IF(NPA.EQ.1) IM=NS-1
68691 IF(IM.GT.N) GOTO 600
68694 IF(KSH(IR).EQ.0) GOTO 290
68695 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
68700 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
68701 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
68702 IF(MSTU(21).GE.1) RETURN
68705 C...Position of aunt (sister to branching parton).
68706 C...Origin and flavour of daughters.
68709 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
68710 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
68722 K(N+I,2)=K(IPA(I),2)
68724 ELSEIF(KFLM.NE.21) THEN
68727 IREF(N+1-NS)=IREF(IM-NS)
68728 IREF(N+2-NS)=IABS(K(N+2,2))
68729 ELSEIF(K(IM,5).EQ.21) THEN
68737 IREF(N+1-NS)=IABS(K(N+1,2))
68738 IREF(N+2-NS)=IABS(K(N+2,2))
68741 C...Reset flags on daughters and tries made.
68746 KFLD(IP)=IABS(K(N+IP,2))
68747 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
68751 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
68755 C...Maximum virtuality of daughters.
68758 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
68759 P(N+I,5)=MIN(QMAX,PS(5))
68761 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
68762 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
68765 IF(MSTJ(43).LE.2) PEM=V(IM,2)
68766 IF(MSTJ(43).GE.3) PEM=P(IM,4)
68767 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
68768 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
68769 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
68773 IF(ISI(I).EQ.1) THEN
68775 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
68777 V(N+I,5)=P(N+I,5)**2
68780 C...Choose one of the daughters for evolution.
68782 IF(NEP.EQ.1) INUM=1
68784 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
68787 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
68789 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
68795 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
68796 RPM=P(N+I,5)/PMSD(I)
68798 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
68806 C...Cancel choice of predetermined daughter already treated.
68809 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
68810 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
68811 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
68812 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
68813 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
68816 C...Store information on choice of evolving daughter.
68820 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
68823 KFL(I)=IABS(K(IEP(I),2))
68825 ITRY(INUM)=ITRY(INUM)+1
68826 IF(ITRY(INUM).GT.200) THEN
68827 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
68828 IF(MSTU(21).GE.1) RETURN
68832 IF(KSH(IR).EQ.0) GOTO 450
68833 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
68835 C...Check if evolution already predetermined for daughter.
68837 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
68838 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
68839 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
68840 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
68841 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
68843 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
68845 IF(IPSPD.NE.0) ISSET(INUM)=1
68848 C...Select side for interference with initial state partons.
68849 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
68852 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
68854 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
68855 IF(PYR(0).GT.0.5D0) ISII(III)=1
68856 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
68858 IF(PYR(0).GT.0.5D0) ISII(III)=2
68862 C...Calculate allowed z range.
68865 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
68868 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
68869 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
68871 IF(MOD(MSTJ(43),2).EQ.1) THEN
68873 ZCE=PMTH(2,22)/PMED
68874 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
68876 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
68877 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
68879 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
68880 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
68881 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
68884 ZCE=MIN(ZCE,0.49991D0)
68885 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
68886 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
68887 P(IEP(1),5)=PMTH(1,IR)
68888 V(IEP(1),5)=P(IEP(1),5)**2
68892 C...Integral of Altarelli-Parisi z kernel for QCD.
68893 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
68894 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
68895 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
68897 C...Evolution of QQ~[3S18] state if MSTP(148)=1.
68898 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
68899 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
68900 FBR=6D0*LOG((1D0-ZC)/ZC)
68902 ELSEIF(MSTJ(49).EQ.0) THEN
68903 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
68904 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
68906 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
68907 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
68908 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
68909 ELSEIF(MSTJ(49).EQ.1) THEN
68910 FBR=(1D0-2D0*ZC)/3D0
68911 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
68913 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
68914 ELSEIF(KFL(1).EQ.21) THEN
68915 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
68917 FBR=2D0*LOG((1D0-ZC)/ZC)
68920 C...Reset QCD probability for colourless.
68921 IF(ISCOL(IR).EQ.0) FBR=0D0
68923 C...Integral of Altarelli-Parisi kernel for photon emission.
68925 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
68926 IF(KFL(1).LE.18) THEN
68927 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
68929 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
68932 C...Inner veto algorithm starts. Find maximum mass for evolution.
68933 410 PMS=V(IEP(1),5)
68938 IRI=IREF(IEP(I)-NS)
68939 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
68942 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
68945 C...Select mass for daughter in QCD evolution.
68947 DO 430 IFF=4,MSTJ(45)
68948 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
68950 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
68951 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
68952 C...Already predetermined choice.
68953 IF(IPSPD.NE.0) THEN
68954 PMSQCD=P(IPSPD,5)**2
68955 ELSEIF(FBR.LT.1D-3) THEN
68957 ELSEIF(MSTJ(44).LE.0) THEN
68958 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
68959 ELSEIF(MSTJ(44).EQ.1) THEN
68960 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
68962 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
68964 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
68965 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
68966 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
68970 C...Select mass for daughter in QED evolution.
68971 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
68972 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
68973 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
68974 IF(FBRE.LT.1D-3) THEN
68977 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
68978 & (PARU(101)*FBRE)))
68980 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
68981 PMSQED=PMSQED+PMTH(1,IR)**2
68982 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
68984 IF(PMSQED.GT.PMSQCD) THEN
68990 C...Check whether daughter mass below cutoff.
68991 P(IEP(1),5)=SQRT(V(IEP(1),5))
68992 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
68993 P(IEP(1),5)=PMTH(1,IR)
68994 V(IEP(1),5)=P(IEP(1),5)**2
68998 C...Already predetermined choice of z, and flavour in g -> qqbar.
68999 IF(IPSPD.NE.0) THEN
69002 PMSGD1=P(IPSGD1,5)**2
69003 PMSGD2=P(IPSGD2,5)**2
69004 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
69005 & 4D0*PMSGD1*PMSGD2))
69006 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
69007 & PMSGD1+PMSGD2)/ALAMPS
69008 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
69009 IF(KFL(1).NE.21) THEN
69012 K(IEP(1),5)=IABS(K(IPSGD1,2))
69015 C...Select z value of branching: q -> qgamma.
69016 ELSEIF(MCE.EQ.2) THEN
69017 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
69018 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
69022 C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
69023 ELSEIF(MSTJ(49).EQ.0.AND.
69024 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
69025 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69026 C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
69027 IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
69028 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
69032 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
69033 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
69034 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69035 C...Only do z weighting when no ME correction afterwards.
69036 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
69038 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
69039 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69040 IF(PYR(0).GT.0.5D0) Z=1D0-Z
69041 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
69043 ELSEIF(MSTJ(49).NE.1) THEN
69045 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
69046 KFLB=1+INT(MSTJ(45)*PYR(0))
69047 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
69048 IF(PMQ.GE.1D0) GOTO 410
69049 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
69050 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
69051 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
69052 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
69053 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
69055 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
69059 C...Ditto for scalar gluon model.
69060 ELSEIF(KFL(1).NE.21) THEN
69061 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
69063 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
69064 Z=ZC+(1D0-2D0*ZC)*PYR(0)
69067 Z=ZC+(1D0-2D0*ZC)*PYR(0)
69068 KFLB=1+INT(MSTJ(45)*PYR(0))
69069 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
69070 IF(PMQ.GE.1D0) GOTO 410
69074 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
69075 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
69076 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
69077 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69078 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
69080 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
69081 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
69082 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
69083 IF(PT2APP.LT.PT2MIN) GOTO 410
69084 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
69088 C...Check if z consistent with chosen m.
69089 IF(KFL(1).EQ.21) THEN
69090 IRGD1=IABS(K(IEP(1),5))
69094 IRGD2=IABS(K(IEP(1),5))
69098 ELSEIF(NEP.GE.3) THEN
69100 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
69101 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
69103 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
69104 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
69106 IF(MOD(MSTJ(43),2).EQ.1) THEN
69107 PMQTH3=0.5D0*PARJ(82)
69108 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
69109 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
69110 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
69111 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
69112 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
69116 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
69119 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
69120 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69121 ELSEIF(IPSPD.NE.0) THEN
69125 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
69127 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
69129 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
69131 C...Width suppression for q -> q + g.
69132 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
69134 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
69138 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
69139 IF(MSTJ(40).EQ.1) THEN
69140 IF(CHI.LT.PYR(0)) GOTO 410
69141 ELSEIF(MSTJ(40).EQ.2) THEN
69142 IF(1D0-CHI.LT.PYR(0)) GOTO 410
69146 C...Three-jet matrix element correction.
69151 C...QED matrix elements: only for massless case so far.
69152 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
69153 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
69154 X2=1D0-V(IEP(1),5)/V(NS+1,5)
69155 X3=(1D0-X1)+(1D0-X2)
69157 KI2=K(IPA(3-INUM),2)
69158 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
69159 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
69160 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
69161 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
69162 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
69163 ELSEIF(MCE.EQ.2) THEN
69165 C...QCD matrix elements, including mass effects.
69166 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
69170 IF(IR.GE.31.AND.IGM.EQ.0) THEN
69171 C...QCD ME: original parton, first branching.
69172 PM2ME=PMTH(1,63-IR)
69174 ELSEIF(IR.GE.31) THEN
69175 C...QCD ME: original parton, subsequent branchings.
69176 PM2ME=PMTH(1,63-IR)
69177 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
69178 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69179 ELSEIF(K(IM,2).EQ.21) THEN
69180 C...QCD ME: secondary partons, first branching.
69183 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
69184 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
69185 & 4D0*PS1ME*PM2ME**2))
69186 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
69188 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69191 C...QCD ME: secondary partons, subsequent branchings.
69193 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
69194 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69197 C...Construct ME variables.
69200 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
69201 X2=1D0+R2ME**2-PS1ME/ECMME**2
69202 C...Call ME, with right order important for two inequivalent showerers.
69203 IF(IR.EQ.IORD+30) THEN
69204 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
69206 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
69208 C...Split up total ME when two radiating partons.
69210 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
69211 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
69212 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
69213 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
69214 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
69215 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
69216 & MAX(1D-10,2D0-X1-X2)
69217 C...Evaluate shower rate to be compared with.
69218 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
69219 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
69220 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
69221 ELSEIF(MSTJ(49).NE.1) THEN
69223 C...Toy model scalar theory matrix elements; no mass effects.
69225 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
69226 X2=1D0-V(IEP(1),5)/V(NS+1,5)
69227 X3=(1D0-X1)+(1D0-X2)
69228 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
69230 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
69234 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
69237 C...Impose angular ordering by rejection of nonordered emission.
69238 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
69239 PEMAO=V(IM,1)*P(IM,4)
69240 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
69241 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
69243 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
69244 & .OR.MSTJ(42).EQ.7)) THEN
69246 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
69247 & .OR.MSTJ(42).EQ.6)) THEN
69249 PMDAO=PMTH(2,K(IEP(1),5))
69250 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
69253 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
69254 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
69255 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
69259 440 IF(K(IAOM,5).EQ.22) THEN
69261 IF(K(IAOM,3).LE.NS) MAOM=0
69262 IF(MAOM.EQ.1) GOTO 440
69264 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
69265 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
69266 IF(THE2ID.LT.THE2IM) GOTO 410
69270 C...Impose user-defined maximum angle at first branching.
69271 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
69272 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
69273 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
69274 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
69275 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
69276 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
69277 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
69278 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
69279 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
69280 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
69284 C...Impose angular constraint in first branching from interference
69285 C...with initial state partons.
69286 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
69287 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
69288 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
69289 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
69290 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
69291 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
69295 C...End of inner veto algorithm. Check if only one leg evolved so far.
69299 IF(NEP.EQ.1) GOTO 490
69300 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
69303 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
69304 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
69308 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
69312 PMSUM=PMSUM+P(N+I,5)
69314 IF(PMSUM.GE.PS(5)) GOTO 350
69315 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
69318 IF(KSH(IRDA).EQ.0) GOTO 480
69319 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
69320 IF(IRDA.EQ.21) THEN
69321 IRGD1=IABS(K(I1,5))
69325 IRGD2=IABS(K(I1,5))
69328 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
69329 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
69331 IF(I1.EQ.N+1) ZM=V(IM,1)
69332 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
69333 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
69334 & 4D0*V(N+1,5)*V(N+2,5))
69335 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
69338 IF(MOD(MSTJ(43),2).EQ.1) THEN
69339 PMQTH3=0.5D0*PARJ(82)
69340 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
69341 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
69342 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
69343 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
69344 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
69348 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
69351 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
69352 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69356 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
69357 & ISSET(1).EQ.0) THEN
69359 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
69360 & ISSET(2).EQ.0) THEN
69364 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
69366 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
69368 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
69371 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
69372 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
69373 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
69374 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
69375 IF(ISL(1).EQ.1) ISL(2)=0
69376 IF(ISL(1).EQ.0) ISLM=1
69377 IF(ISL(2).EQ.0) ISLM=2
69379 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
69384 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
69385 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
69386 PMQ1=V(N+1,5)/V(IM,5)
69387 PMQ2=V(N+2,5)/V(IM,5)
69388 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
69393 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
69397 C...Accepted branch. Construct four-momentum for initial partons.
69403 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
69405 P(N+1,4)=P(IPA(1),4)
69407 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
69408 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
69411 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
69416 P(N+2,4)=P(IM,5)-PED1
69419 ELSEIF(NEP.GE.3) THEN
69420 C...Rescale all momenta for energy conservation.
69426 P(N+I,J)=P(IPA(I),J)
69429 PQS=PQS+P(N+I,5)**2/P(N+I,4)
69432 FAC=(PS(5)-PQS)/(PES-PQS)
69437 P(N+I,J)=FAC*P(N+I,J)
69439 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)
69442 PQS=PQS+P(N+I,5)**2/P(N+I,4)
69444 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
69446 C...Construct transverse momentum for ordinary branching in shower.
69450 550 LOOPPT=LOOPPT+1
69451 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
69452 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
69453 IF(PZM.LE.0D0) THEN
69455 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69456 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69457 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
69458 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
69459 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
69460 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
69462 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
69464 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
69467 ELSEIF(PTS.LT.0D0) THEN
69470 PT=SQRT(MAX(0D0,PTS))
69472 C...Global statistics.
69473 MINT(353)=MINT(353)+1
69474 VINT(353)=VINT(353)+PT
69475 IF (MINT(353).EQ.1) VINT(358)=PT
69477 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
69479 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
69480 & .AND.IAU.NE.0) THEN
69481 IF(K(IGM,3).NE.0) MAZIP=1
69483 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
69484 IF(MAZIP.EQ.0) ZAU=0D0
69485 IF(K(IGM,2).NE.21) THEN
69486 HAZIP=2D0*ZAU/(1D0+ZAU**2)
69488 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
69490 IF(K(N+1,2).NE.21) THEN
69491 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
69493 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
69497 C...Find coefficient of azimuthal asymmetry due to soft gluon
69500 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
69501 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
69502 IF(K(IGM,3).NE.0) MAZIC=N+1
69503 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
69504 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
69505 & ZM.GT.0.5D0) MAZIC=N+2
69506 IF(K(IAU,2).EQ.22) MAZIC=0
69508 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
69510 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
69511 IF(MAZIC.EQ.0) ZGM=1D0
69512 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
69513 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
69514 HAZIC=MIN(0.95D0,HAZIC)
69518 C...Construct energies for ordinary branching in shower.
69519 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
69520 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69521 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69522 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
69523 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
69524 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
69525 P(N+1,4)=PEM*V(IM,1)
69527 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
69528 & SQRT(PMLS)*ZM)/V(IM,5)
69531 C...Already predetermined choice of phi angle or not
69533 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
69535 IF(K(IPSPD,4).GT.0) THEN
69537 IF(IM.EQ.NS+2) THEN
69538 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
69540 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
69543 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
69545 IF(K(IPSPD,4).GT.0) THEN
69547 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
69548 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
69549 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
69550 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
69551 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
69552 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
69556 C...Construct momenta for ordinary branching in shower.
69557 P(N+1,1)=PT*COS(PHI)
69558 P(N+1,2)=PT*SIN(PHI)
69559 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69560 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69561 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
69562 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
69563 ELSEIF(PZM.GT.0D0) THEN
69564 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
69565 & 2D0*PEM*P(N+1,4))/PZM
69571 P(N+2,3)=PZM-P(N+1,3)
69572 P(N+2,4)=PEM-P(N+1,4)
69573 IF(MSTJ(43).LE.2) THEN
69574 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
69575 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
69579 C...Rotate and boost daughters.
69581 IF(MSTJ(43).LE.2) THEN
69582 BEX=P(IGM,1)/P(IGM,4)
69583 BEY=P(IGM,2)/P(IGM,4)
69584 BEZ=P(IGM,3)/P(IGM,4)
69585 GA=P(IGM,4)/P(IGM,5)
69586 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
69595 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
69596 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
69597 IF(PTIMB.GT.1D-4) THEN
69598 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
69603 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
69604 & SIN(THE)*COS(PHI)*P(I,3)
69605 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
69606 & SIN(THE)*SIN(PHI)*P(I,3)
69607 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
69609 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
69610 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
69611 P(I,1)=DP(1)+DGABP*BEX
69612 P(I,2)=DP(2)+DGABP*BEY
69613 P(I,3)=DP(3)+DGABP*BEZ
69614 P(I,4)=GA*(DP(4)+DBP)
69618 C...Weight with azimuthal distribution, if required.
69619 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
69625 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
69626 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
69627 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
69629 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
69630 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
69632 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
69633 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
69634 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
69635 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
69636 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
69637 IF(MAZIP.NE.0) THEN
69638 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
69641 IF(MAZIC.NE.0) THEN
69642 IF(MAZIC.EQ.N+2) CAD=-CAD
69643 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
69644 & .LT.PYR(0)) GOTO 560
69649 C...Azimuthal anisotropy due to interference with initial state partons.
69650 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
69651 &K(N+2,2).EQ.21)) THEN
69653 IF(ISII(III).GE.1) THEN
69655 IF(K(N+1,2).NE.21) IAZIID=N+2
69656 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
69657 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
69658 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
69659 IF(III.EQ.2) THEIID=PARU(1)-THEIID
69660 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
69661 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
69662 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
69663 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
69664 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
69665 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
69666 & .LT.PYR(0)) GOTO 560
69670 C...Continue loop over partons that may branch, until none left.
69671 IF(IGM.GE.0) K(IM,1)=14
69674 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
69675 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
69676 IF(MSTU(21).GE.1) N=NS
69677 IF(MSTU(21).GE.1) RETURN
69681 C...Set information on imagined shower initiator.
69682 600 IF(NPA.GE.2) THEN
69686 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
69694 C...Reconstruct string drawing information.
69695 DO 610 I=NS+1+IIM,N
69696 KQ=KCHG(PYCOMP(K(I,2)),2)
69697 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
69699 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
69700 & IABS(K(I,2)).LE.18) THEN
69702 ELSEIF(K(I,1).LE.10) THEN
69703 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
69704 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
69705 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
69706 ID1=MOD(K(I,4),MSTU(5))
69707 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
69708 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
69709 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
69710 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
69711 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
69712 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
69713 K(ID1,4)=K(ID1,4)+MSTU(5)*I
69714 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
69715 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
69716 K(ID2,5)=K(ID2,5)+MSTU(5)*I
69718 ID1=MOD(K(I,4),MSTU(5))
69720 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
69721 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
69722 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
69723 K(ID1,4)=K(ID1,4)+MSTU(5)*I
69724 K(ID1,5)=K(ID1,5)+MSTU(5)*I
69734 C...Transformation from CM frame.
69736 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
69737 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
69739 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
69740 ELSEIF(NPA.EQ.2) THEN
69745 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
69746 & /(1D0+GA)-P(IPA(1),4))
69747 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
69748 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
69749 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
69751 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
69753 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
69756 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
69759 C...Decay vertex of shower.
69766 C...Delete trivial shower, else connect initiators.
69767 IF(N.LE.NS+NPA+IIM) THEN
69772 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
69773 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
69774 K(NS+IIM+IP,3)=IPA(IP)
69775 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
69776 IF(K(NS+IIM+IP,1).NE.1) THEN
69777 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
69778 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
69786 C*********************************************************************
69789 C...Generates pT-ordered timelike final-state parton showers.
69791 C...MODE defines how to find radiators and recoilers.
69792 C... = 0 : based on colour flow between undecayed partons.
69793 C... = 1 : for IPART <= NPARTD only consider primary partons,
69794 C... whether decayed or not; else as above.
69795 C... = 2 : based on common history, whether decayed or not.
69796 C... = 3 : use (or create) MCT color information to shower partons
69798 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
69800 C...Double precision and integer declarations.
69801 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69802 IMPLICIT INTEGER(I-N)
69803 INTEGER PYK,PYCHGE,PYCOMP
69804 C...Parameter statement to help give large particle numbers.
69805 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69806 &KEXCIT=4000000,KDIMEN=5000000)
69807 C...Parameter statement for maximum size of showers.
69808 PARAMETER (MAXNUR=1000)
69810 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
69811 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69812 COMMON/PYCTAG/NCT,MCT(4000,2)
69813 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69814 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69815 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69816 COMMON/PYINT1/MINT(400),VINT(400)
69817 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
69820 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
69821 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
69822 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
69823 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
69824 C...Statement functions.
69825 SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
69826 &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
69828 C...Initial values. Check that valid system.
69830 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
69831 &MSTJ(41).NE.12) RETURN
69832 IF(NPART.LE.0) THEN
69833 CALL PYERRM(2,'(PYPTFS:) showering system too small')
69839 C...Mass thresholds and Lambda for QCD evolution.
69843 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
69844 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
69851 C...Cutoff scale for QCD evolution. Starting pT2.
69852 NFLAV=MAX(0,MIN(5,MSTJ(45)))
69853 PT0C=0.5D0*PARJ(82)
69854 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
69856 C...Parameters for QED evolution.
69857 AEM2PI=PARU(101)/PARU(2)
69858 PT0EQ=0.5D0*PARJ(83)
69859 PT0EL=0.5D0*PARJ(90)
69861 C...Reset. Remove irrelevant colour tags.
69866 DO 110 I=MINT(84)+1,N
69867 IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
69871 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
69878 C...Begin loop to set up showering partons. Sum four-momenta.
69881 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
69882 IF(K(I,1).GT.10) GOTO 230
69883 ELSEIF(K(I,3).GT.MINT(84)) THEN
69884 IF(K(I,3).GT.MINT(84)+2) GOTO 230
69886 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 230
69889 PSUM(J)=PSUM(J)+P(I,J)
69892 C...Find colour and charge, but skip diquarks.
69893 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 230
69894 KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
69895 KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
69898 IF (IABS(K(I,2)).GE.9900101.AND.IABS(K(I,2)).LE.9910555) THEN
69899 IF (MSTP(148).GE.1) THEN
69900 C...Temporary: force no radiation from quarkonia since not yet treated
69901 CALL PYERRM(11,'(PYPTFS:) quarkonia showers not yet in'
69902 & //' PYPTFS, switched off')
69903 CALL PYGIVE('MSTP(148)=0')
69905 IF (MSTP(148).EQ.0) THEN
69906 C...Skip quarkonia if radiation switched off
69912 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
69913 C...(only intended for studying the effects of switching such rad on/off)
69914 IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) THEN
69918 C...Either colour or anticolour charge radiates; for gluon both.
69919 DO 180 JSGCOL=1,-1,-2
69920 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
69921 JCOL=4+(1-JSGCOL)/2
69924 C...Basic info about radiating parton.
69928 ISCOL(NEVOL)=JSGCOL
69930 PTSCA(NEVOL)=PTPART(IP)
69932 C...Begin search for colour recoiler when MODE = 0 or 1.
69934 C...Find sister with matching anticolour to the radiating parton.
69936 IRNEW=K(IROLD,JCOL)/MSTU(5)
69939 C...Skip radiation off loose colour ends.
69940 130 IF(IRNEW.EQ.0) THEN
69944 C...Optionally skip radiation on dipole to beam remnant.
69945 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
69949 C...For now always skip radiation on dipole to junction.
69950 ELSEIF(K(IRNEW,2).EQ.88) THEN
69954 C...For MODE=1: if reached primary then done.
69955 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
69956 & IRNEW.LE.NPARTD) THEN
69958 C...If sister stable and points back then done.
69959 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
69961 IF(K(IRNEW,1).LT.10) THEN
69963 C...If sister unstable then go to her daughter.
69966 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
69971 C...If found mother then look for aunt.
69972 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
69975 IRNEW=K(IROLD,JCOL)/MSTU(5)
69978 C...If daughter stable then done.
69979 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
69981 IF(K(IRNEW,1).LT.10) THEN
69983 C...If daughter unstable then go to granddaughter.
69986 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
69991 C...If daughter points to another daughter then done or move up.
69992 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
69994 IF(K(IRNEW,1).LT.10) THEN
69997 IRNEW=K(IRNEW,JCOL)/MSTU(5)
70003 C...Begin search for colour recoiler when MODE = 2.
70004 ELSEIF (MODE.EQ.2) THEN
70006 IRNEW=K(IROLD,JCOL)/MSTU(5)
70007 140 IF (IRNEW.LE.0.OR.IRNEW.GT.N) THEN
70008 C...If no color partner found, pick at random among other primaries
70009 C...(e.g., when the color line is traced all the way to the beam)
70010 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70011 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70012 ELSEIF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
70013 C...Step up to mother if radiating parton already branched.
70014 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
70016 IRNEW=K(IROLD,JCOL)/MSTU(5)
70018 C...Pick sister by history if no anticolour available.
70020 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
70022 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
70025 C...Last resort: pick at random among other primaries.
70027 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70028 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70032 C...Trace down if sister branched.
70033 150 IF(K(IRNEW,1).GT.10) THEN
70034 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
70035 C...If no correct color-daughter found, swap.
70036 IF (IRTMP.EQ.0) THEN
70039 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
70044 ELSEIF (MODE.EQ.3) THEN
70045 C...The following will add MCT colour tracing for unprepped events
70046 C...If not done, trace Les Houches colour tags for this dipole
70048 IF (MCT(I,JCOL-3).EQ.0) THEN
70049 C...Special end code -1 : trace to color partner or 0, return in IEND
70051 CALL PYCTTR(I,JCOL,IEND)
70052 C...Clean up mother/daughter 'read' tags set by PYCTTR
70055 K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
70056 K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
70063 IF (K(IR,1).GT.0.AND.MCT(IR,6-JCOL).EQ.MCT(I,JCOL-3))
70067 C...If no color partner, then we hit beam
70068 IF (IEND.LE.0) THEN
70069 C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate
70070 IF (MSTP(72).LE.1) THEN
70074 C...Else try a random partner
70075 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70076 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70079 C...Else save recoiling colour partner
70085 C...Now found other end of colour dipole.
70090 C...Also electrical charge may radiate; so far only quarks and leptons.
70091 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
70092 & IABS(K(I,2)).LE.18) THEN
70094 C...Basic info about radiating parton.
70100 PTSCA(NEVOL)=PTPART(IP)
70102 C...Pick nearest (= smallest invariant mass) charged particle
70103 C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
70107 DO 190 IP2=1,NPART+N-MINT(53)
70108 IF(IP2.EQ.IP) GOTO 190
70109 IF(IP2.LE.NPART) THEN
70111 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
70112 IF(K(I2,1).GT.10) GOTO 190
70113 ELSEIF(K(I2,3).GT.MINT(84)) THEN
70114 IF(K(I2,3).GT.MINT(84)+2) GOTO 190
70116 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 190
70119 I2=MINT(53)+IP2-NPART
70121 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 190
70122 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
70123 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
70124 IF(PM2INV.LT.PM2MIN) THEN
70129 IF(IRNEW.EQ.0) THEN
70134 C...Begin search for charge recoiler when MODE = 2.
70137 C...Pick sister by history; step up if parton already branched.
70138 200 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
70142 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
70144 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
70146 C...Last resort: pick at random among other primaries.
70148 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70149 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70151 C...Trace down if sister branched.
70152 210 IF(K(IRNEW,1).GT.10) THEN
70153 DO 220 IR=IRNEW+1,N
70154 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
70164 C...End loop to set up showering partons. System invariant mass.
70166 IF(NEVOL.LE.0) RETURN
70167 IF (MODE.EQ.3.AND.NEVOL.LE.1) RETURN
70168 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
70170 C...Check if 3-jet matrix elements to be used.
70174 IF(MSTJ(47).GE.1) THEN
70176 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
70178 IPART1=K(IPART(1),3)
70179 IPART2=K(IPART(2),3)
70180 240 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
70181 KFSRCE=IABS(K(IPART1,2))
70182 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
70185 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
70190 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
70191 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
70192 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
70193 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
70194 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
70195 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
70196 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
70197 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
70199 C...Identify two primary showerers.
70200 KFLA1=IABS(K(IPART(1),2))
70202 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
70203 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
70204 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
70205 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
70206 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
70207 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
70208 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
70209 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
70210 KFLA2=IABS(K(IPART(2),2))
70212 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
70213 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
70214 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
70215 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
70216 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
70217 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
70218 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
70219 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
70221 C...Order of showerers. Presence of gluino.
70222 ITYPMN=MIN(ITYPE1,ITYPE2)
70223 ITYPMX=MAX(ITYPE1,ITYPE2)
70225 IF(ITYPE1.GT.ITYPE2) IORD=2
70227 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
70229 C...Require exactly two primary showerers for ME corrections.
70231 IF(IPART1.GT.0) THEN
70233 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
70236 IF(NPRIM.NE.2) THEN
70238 C...Predetermined and default matrix element kinds.
70239 ELSEIF(MSTJ(38).NE.0) THEN
70243 ELSEIF(MSTJ(47).GE.6) THEN
70249 C...Vector/axial vector -> q + qbar; q -> q + V.
70250 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
70251 & ITYPES.EQ.3)) THEN
70253 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
70255 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
70256 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
70257 C...gamma*/Z0: assume e+e- initial state if unknown.
70259 IF(KFSRCE.EQ.23) THEN
70261 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
70262 IF(IANNFL.GT.0) THEN
70263 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
70265 IF(IANNFL.NE.0) THEN
70266 KANNFL=IABS(K(IANNFL,2))
70267 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
70270 AI=SIGN(1D0,EI+0.1D0)
70271 VI=AI-4D0*EI*PARU(102)
70272 EF=KCHG(KFLA1,1)/3D0
70273 AF=SIGN(1D0,EF+0.1D0)
70274 VF=AF-4D0*EF*PARU(102)
70275 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
70278 SQWZ=PSUM(5)*PMAS(23,2)
70279 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
70280 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
70281 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
70282 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
70284 ALPHA=VECT/(VECT+AXIV)
70285 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
70288 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
70289 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
70291 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70292 & ITYPES.EQ.1)) THEN
70295 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
70296 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
70298 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
70300 ELSEIF(KFSRCE.EQ.36) THEN
70303 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70304 & ITYPES.EQ.1)) THEN
70307 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
70308 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70309 & ITYPES.EQ.3)) THEN
70311 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70312 & ITYPES.EQ.2)) THEN
70314 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
70316 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70317 & ITYPES.EQ.2)) THEN
70320 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
70321 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70322 & ITYPES.EQ.5)) THEN
70324 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70325 & ITYPES.EQ.2)) THEN
70327 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70328 & ITYPES.EQ.1)) THEN
70331 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
70332 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
70334 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70335 & ITYPES.EQ.2)) THEN
70337 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70338 & ITYPES.EQ.1)) THEN
70341 C...g -> ~g + ~g (eikonal approximation).
70342 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
70345 M3JC=5*ICLASS+ICOMBI
70348 C...Store pair that together define matrix element treatment.
70351 MESYS(NMESYS,0)=M3JC
70352 MESYS(NMESYS,1)=IPART(1)
70353 MESYS(NMESYS,2)=IPART(2)
70356 C...Store qqbar or l+l- pairs for QED radiation.
70357 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
70359 MESYS(NMESYS,0)=101
70360 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
70361 MESYS(NMESYS,1)=IPART(1)
70362 MESYS(NMESYS,2)=IPART(2)
70365 C...Store other qqbar/l+l- pairs from g/gamma branchings.
70367 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 290
70369 260 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
70373 C...Move up this check to avoid out-of-bounds.
70374 IF(I1M.EQ.0) GOTO 290
70375 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 290
70377 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 280
70379 270 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
70383 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
70389 MESYS(NMESYS,0)=102
70397 C..Loopback point for counting number of emissions.
70401 C...Begin loop to evolve all existing partons, if required.
70404 DO 380 IEVOL=1,NEVOL
70405 IF(IFLG(IEVOL).EQ.0) THEN
70407 C...Basic info on radiator and recoil.
70414 C...Invariant mass of "dipole".Starting value for pT evolution.
70415 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
70416 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
70418 C...Case of evolution by QCD branching.
70419 IF(ISCOL(IEVOL).NE.0) THEN
70421 C...Parton-by-parton maximum scale from initial conditions.
70422 IF(MSTP(72).EQ.0) THEN
70423 DO 320 IPRT=1,NPARTS
70424 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
70428 C...If kinematically impossible then do not evolve.
70429 IF(PT2.LT.PT2CMN) THEN
70434 C...Check if part of system for which ME corrections should be applied.
70436 DO 330 IME=1,NMESYS
70437 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
70438 & MESYS(IME,0).LT.100) IMESYS=IME
70441 C...Special flag for colour octet states.
70442 C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot.
70444 IF(K(I,2).EQ.21) MOCT=1
70446 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
70448 IF(K(I,2).EQ.5100021) MOCT=2
70450 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).EQ.9900101.AND.
70451 & IABS(K(I,2)).LE.9910555) MOCT=2
70455 C...Upper estimate for matrix element weighting and colour factor.
70456 C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
70459 IF(MOCT.GE.1) COLFAC=3D0/2D0
70460 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
70461 WTPSQQ=0.5D0*0.5D0*NFLAV
70463 C...Determine overestimated z range: switch at c and b masses.
70468 IF(PT2.GT.1.01D0*PMCS) THEN
70474 IF(PT2.GT.1.01D0*PMBS) THEN
70480 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
70481 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
70483 C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
70484 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
70487 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
70488 EVCOEF=EVCOEF+EVEMQQ
70491 C...Pick pT2 (in overestimated z range).
70492 350 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
70494 C...Loopback if crossed c/b mass thresholds.
70495 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
70499 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
70504 C...Finish if below lower cutoff.
70505 IF(PT2.LT.PT2CMN) THEN
70510 C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
70511 C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting
70513 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
70515 C...Pick z: dz/(1-z) or dz.
70516 IF(IFLAG.EQ.1) THEN
70517 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
70519 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
70522 C...Loopback if outside allowed range for given pT2.
70523 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
70524 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
70525 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
70526 PM2=PM2I+PT2/(Z*(1D0-Z))
70527 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
70529 C...No weighting for primary partons; to be done later on.
70530 IF(IMESYS.GT.0) THEN
70532 C...Weighting of q->qg/X->Xg branching.
70533 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
70534 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 350
70536 C...Weighting of g->gg branching.
70537 ELSEIF(IFLAG.EQ.1) THEN
70538 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 350
70540 C...Flavour choice and weighting of g->qqbar branching.
70542 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
70544 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
70545 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
70546 IF(WTME.LT.PYR(0)) GOTO 350
70550 C...Case of evolution by QED branching.
70551 ELSEIF(ISCHG(IEVOL).NE.0) THEN
70553 C...If kinematically impossible then do not evolve.
70555 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
70556 IF(PT2.LT.PT2EMN) THEN
70561 C...Check if part of system for which ME corrections should be applied.
70563 DO 360 IME=1,NMESYS
70564 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
70565 & MESYS(IME,0).GT.100) IMESYS=IME
70568 C...Charge. Matrix element weighting factor.
70569 CHG=ISCHG(IEVOL)/3D0
70572 C...Determine overestimated z range. Find evolution coefficient.
70573 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
70574 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
70575 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
70577 C...Pick pT2 (in overestimated z range).
70578 370 PT2=PT2*PYR(0)**(1D0/EVCOEF)
70580 C...Finish if below lower cutoff.
70581 IF(PT2.LT.PT2EMN) THEN
70586 C...Pick z: dz/(1-z).
70587 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
70589 C...Loopback if outside allowed range for given pT2.
70590 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
70591 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
70592 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 370
70593 PM2=PM2I+PT2/(Z*(1D0-Z))
70594 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 370
70596 C...Weighting by branching kernel, except if ME weighting later.
70597 IF(IMESYS.EQ.0) THEN
70598 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 370
70603 C...Save acceptable branching.
70605 IMESAV(IEVOL)=IMESYS
70611 C...Check if branching has highest pT.
70612 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
70614 PT2MX=PT2SAV(IEVOL)
70618 C...Finished if no more branchings to be done.
70619 IF(IMX.EQ.0) GOTO 500
70621 C...Restore info on hardest branching to be processed.
70632 PM2=PM2I+PT2/(Z*(1D0-Z))
70634 C...Special flag for colour octet states.
70636 IF(K(I,2).EQ.21) MOCT=1
70637 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
70638 IF(K(I,2).EQ.5100021) MOCT=2
70640 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).GE.9900101.AND.
70641 & IABS(K(I,2)).LE.9910555) MOCT=2
70644 C...Restore further info for g->qqbar branching.
70646 IF(IFLG(IMX).GT.10) THEN
70649 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
70652 C...For branching g include azimuthal asymmetries from polarization.
70654 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
70655 C...Trace grandmother via intermediate recoil copies.
70658 390 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
70659 & K(IM,3).GT.0) THEN
70661 IF(IM.GT.MINT(84)) GOTO 390
70664 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
70665 & KFGM=IABS(K(IGM,2))
70666 C...Define approximate energy sharing by identifying aunt.
70668 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
70669 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
70670 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
70671 C...Coefficient from gluon production.
70673 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
70675 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
70677 C...Coefficient from gluon decay.
70679 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
70681 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
70686 C...Create new slots for branching products and recoil.
70692 C...Set status, flavour and mother of new ones.
70695 IF(KCHA.NE.0) K(IGNEW,1)=1
70700 IF(KCHA.NE.0) K(IGNEW,2)=22
70702 K(INEW,2)=-ISIGN(KFQ,KCOL)
70703 K(IGNEW,2)=-K(INEW,2)
70710 C...Find rest frame and angles of branching+recoil.
70716 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
70717 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
70718 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
70719 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
70720 PHI=PYANGL(P(INEW,1),P(INEW,2))
70721 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
70723 C...Derive kinematics of branching: generics (like g->gg).
70728 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
70729 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
70730 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
70731 PTCOR=SQRT(MAX(0D0,PT2COR))
70732 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
70733 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
70734 C...Specific kinematics reduction for q->qg with m_q > 0.
70736 PTCOR=(1D0-PM2I/PM2)*PTCOR
70737 PZN=PZN+PM2I*PZG/PM2
70738 PZG=(1D0-PM2I/PM2)*PZG
70739 C...Specific kinematics reduction for g->qqbar with m_q > 0.
70740 ELSEIF(KFQ.NE.0) THEN
70744 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
70748 C...Pick phi and construct kinematics of branching.
70749 420 PHIROT=PARU(2)*PYR(0)
70750 P(INEW,1)=PTCOR*COS(PHIROT)
70751 P(INEW,2)=PTCOR*SIN(PHIROT)
70753 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
70754 P(IGNEW,1)=-P(INEW,1)
70755 P(IGNEW,2)=-P(INEW,2)
70757 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
70761 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
70763 C...Boost branching system to lab frame.
70764 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
70766 C...Renew choice of phi angle according to polarization asymmetry.
70767 IF(ABS(ASYPOL).GT.1D-3) THEN
70773 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
70774 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
70775 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
70777 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
70778 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
70780 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
70781 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
70782 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
70783 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
70784 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
70785 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
70790 C...Matrix element corrections for primary partons when requested.
70791 IF(IMESYS.GT.0) THEN
70792 M3JC=MESYS(IMESYS,0)
70794 C...Identify recoiling partner and set up three-body kinematics.
70795 IRP=MESYS(IMESYS,1)
70796 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
70797 IF(IRP.EQ.IR) IRP=IRNEW
70799 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
70801 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
70803 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
70804 & PSUM(3)*P(INEW,3))/PSUM(5)**2
70805 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
70806 & PSUM(3)*P(IRP,3))/PSUM(5)**2
70808 R1ME=P(INEW,5)/PSUM(5)
70809 R2ME=P(IRP,5)/PSUM(5)
70811 C...Matrix elements for gluon emission.
70812 IF(M3JC.LT.100) THEN
70814 C...Call ME, with right order important for two inequivalent showerers.
70815 IF(MESYS(IMESYS,IORD).EQ.I) THEN
70816 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
70818 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
70821 C...Split up total ME when two radiating partons.
70823 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
70824 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
70825 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
70826 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
70827 & MAX(1D-10,2D0-X1-X2)
70829 C...Evaluate shower rate.
70830 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
70831 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70832 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
70834 C...Matrix elements for photon emission: still rather primitive.
70837 C...For generic charge combination currently only massless expression.
70838 IF(M3JC.EQ.101) THEN
70839 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
70840 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
70841 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
70842 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
70844 C...For flavour neutral system assume vector source and include masses.
70846 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
70847 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
70848 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
70849 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70853 C...Perform weighting with W_ME/W_PS.
70854 IF(WME.LT.PYR(0)*WPS) THEN
70862 C...Now for sure accepted branching. Save highest pT.
70863 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
70865 C...Update status for obsolete ones. Bookkkep the moved original parton
70866 C...and new daughter (arbitrary choice for g->gg or g->qqbar).
70867 C...Do not bookkeep radiated photon, since it cannot radiate further.
70871 IF(IPART(IP).EQ.I) IPART(IP)=INEW
70872 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
70879 C...Initialize colour flow of branching.
70880 C...Use both old and new style colour tags for flexibility.
70894 C...Trivial colour flow for l->lgamma and q->qgamma.
70895 IF(IABS(KCHA).EQ.3) THEN
70898 ELSEIF(KCHA.NE.0) THEN
70899 IF(K(I,4).NE.0) THEN
70901 K(INEW,4)=MSTU(5)*I
70902 MCT(INEW,1)=MCT(I,1)
70904 IF(K(I,5).NE.0) THEN
70906 K(INEW,5)=MSTU(5)*I
70907 MCT(INEW,2)=MCT(I,2)
70910 C...Set colour flow for q->qg and g->gg.
70911 ELSEIF(KFQ.EQ.0) THEN
70912 K(I,JCOLP)=K(I,JCOLP)+IGNEW
70913 K(IGNEW,JCOLP)=MSTU(5)*I
70914 K(INEW,JCOLP)=MSTU(5)*IGNEW
70915 K(IGNEW,JCOLN)=MSTU(5)*INEW
70916 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
70918 MCT(INEW,JCOLP-3)=NCT
70919 MCT(IGNEW,JCOLN-3)=NCT
70921 K(I,JCOLN)=K(I,JCOLN)+INEW
70922 K(INEW,JCOLN)=MSTU(5)*I
70923 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
70926 C...Set colour flow for g->qqbar.
70928 K(I,JCOLN)=K(I,JCOLN)+INEW
70929 K(INEW,JCOLN)=MSTU(5)*I
70930 K(I,JCOLP)=K(I,JCOLP)+IGNEW
70931 K(IGNEW,JCOLP)=MSTU(5)*I
70932 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
70933 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
70936 C...Daughter info for colourless recoiling parton.
70937 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
70943 C...Colour of recoiling parton sails through unchanged.
70945 IF(K(IR,4).NE.0) THEN
70946 K(IR,4)=K(IR,4)+IRNEW
70947 K(IRNEW,4)=MSTU(5)*IR
70948 MCT(IRNEW,1)=MCT(IR,1)
70950 IF(K(IR,5).NE.0) THEN
70951 K(IR,5)=K(IR,5)+IRNEW
70952 K(IRNEW,5)=MSTU(5)*IR
70953 MCT(IRNEW,2)=MCT(IR,2)
70957 C...Vertex information trivial.
70964 C...Update list of old radiators.
70965 DO 480 IEVOL=1,NEVOL
70966 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
70968 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
70971 ELSEIF(IPOS(IEVOL).EQ.I) THEN
70974 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
70977 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
70979 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
70983 C...Update links of old connected partons.
70984 IF(IREC(IEVOL).EQ.I) THEN
70987 ELSEIF(IREC(IEVOL).EQ.IR) THEN
70993 C...q->qg or g->gg: create new gluon radiators.
70994 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
71001 PTSCA(NEVOL)=SQRT(PT2)
71008 PTSCA(NEVOL)=PTSCA(NEVOL-1)
71011 C...Update matrix elements parton list and add new for g/gamma->qqbar.
71012 DO 490 IME=1,NMESYS
71013 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
71014 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
71015 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
71016 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
71021 MESYS(NMESYS,1)=INEW
71022 MESYS(NMESYS,2)=IGNEW
71024 MESYS(NMESYS,0)=102
71025 MESYS(NMESYS,1)=INEW
71026 MESYS(NMESYS,2)=IGNEW
71029 C...Global statistics.
71030 MINT(353)=MINT(353)+1
71031 VINT(353)=VINT(353)+PTCOR
71032 IF (MINT(353).EQ.1) VINT(358)=PTCOR
71034 C...Loopback for more emissions if enough space.
71036 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
71037 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
71040 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
71049 C*********************************************************************
71052 C...Auxiliary to PYSHOW and PYPTFS.
71053 C...Matrix elements for gluon (or photon) emission from
71054 C...a two-body state; to be used by the parton shower routine.
71055 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
71056 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
71057 C... = (alpha-strong/2 pi) * CF * PYMAEL,
71058 C...i.e. normalization is such that one recovers the familiar
71059 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
71060 C...Coupling structure:
71061 C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
71062 C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
71063 C... = 16-19 : q -> q V
71064 C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
71065 C... = 26-29 : q -> q S
71066 C... = 31-34 : V -> ~q ~qbar (~q = squark)
71067 C... = 36-39 : ~q -> ~q V
71068 C... = 41-44 : S -> ~q ~qbar
71069 C... = 46-49 : ~q -> ~q S
71070 C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
71071 C... = 56-59 : ~q -> q chi
71072 C... = 61-64 : q -> ~q chi
71073 C... = 66-69 : ~g -> q ~qbar
71074 C... = 71-74 : ~q -> q ~g
71075 C... = 76-79 : q -> ~q ~g
71076 C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
71077 C...Note that the order of the decay products is important.
71078 C...In each set of four, the variants are ordered as:
71079 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
71080 C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
71081 C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
71082 C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
71084 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
71086 C...Double precision and integer declarations.
71087 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71088 IMPLICIT INTEGER(I-N)
71090 C...Check input values. Return zero outside allowed phase space.
71092 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
71093 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
71094 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
71095 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
71096 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
71097 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
71099 C...Initial values and flags.
71107 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
71109 C...Eikonal expression; also acts as default.
71110 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
71112 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
71114 ELSEIF(ICOMBI.EQ.2) THEN
71115 ANUM=(2D0-X1-X2)**2
71116 ELSEIF(ICOMBI.EQ.3) THEN
71117 ANUM=ALPCOR*(2D0-X1-X2)**2
71119 ANUM=0.5D0*(2D0-X1-X2)**2
71121 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
71122 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
71123 & R1**2/(1D0+R2**2-R1**2-X2)**2-
71124 & R2**2/(1D0+R1**2-R2**2-X1)**2)
71127 C...V -> q qbar (V = gamma*/Z0/W+-/...).
71128 ELSEIF(ICLASS.EQ.2) THEN
71129 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71130 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
71131 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
71132 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
71133 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
71134 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
71135 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
71136 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
71137 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
71138 & (-1+R1**2-R2**2+X2)**2
71139 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
71140 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
71141 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
71142 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
71143 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
71144 & -X1-X2)**2+X1*(2-X1-X2)**2)/
71145 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71146 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
71147 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
71148 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
71149 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
71150 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
71154 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71155 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
71156 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
71157 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
71158 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
71159 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
71160 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
71161 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
71162 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
71163 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
71164 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
71165 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
71166 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
71167 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
71168 & -X1-X2)**2+X1*(2-X1-X2)**2)/
71169 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71170 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
71171 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
71172 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
71173 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
71174 & +X2)/(-1-R1**2+R2**2+X1)**2
71178 IF(ICOMBI.EQ.4) THEN
71179 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
71180 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
71181 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
71182 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
71183 & (-1-R1**2+R2**2+X1)**2
71185 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
71186 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
71187 & -R1**2*X2**2+X1*X2**2)/
71188 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71189 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
71190 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
71191 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
71192 & (-1+R1**2-R2**2+X2)**2
71198 ELSEIF(ICLASS.EQ.3) THEN
71199 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71200 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
71201 & +R1**2*R2**2-2D0*R2**4)
71202 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
71203 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
71204 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
71205 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
71206 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
71207 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
71208 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
71209 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
71210 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
71211 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
71212 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71213 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71214 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
71215 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
71216 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
71217 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
71218 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71219 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
71220 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
71223 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71224 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
71225 & +R1**2*R2**2-2D0*R2**4)
71226 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
71227 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
71228 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
71229 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
71230 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
71231 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
71232 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71233 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
71234 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
71235 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
71236 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71237 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71238 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
71239 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
71240 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
71241 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
71242 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71243 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
71244 & +X1*X2**2)/(-2+X1+X2)**2
71247 IF(ICOMBI.EQ.4) THEN
71248 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
71249 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
71250 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
71251 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
71252 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
71253 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71254 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
71255 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
71256 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71257 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71258 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
71259 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
71260 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
71261 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71262 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
71263 & +X1*X2**2)/(2-X1-X2)**2
71267 C...S -> q qbar (S = h0/H0/A0/H+-/...).
71268 ELSEIF(ICLASS.EQ.4) THEN
71269 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71270 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
71271 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71272 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71273 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71274 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
71275 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
71276 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71277 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71278 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71279 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71282 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71283 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
71284 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71285 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71286 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71287 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71288 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
71289 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71290 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
71291 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
71292 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
71293 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71296 IF(ICOMBI.EQ.4) THEN
71297 RLO4=PS*(1D0-R1**2-R2**2)
71298 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
71299 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71300 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
71301 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
71302 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71303 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
71304 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71309 ELSEIF(ICLASS.EQ.5) THEN
71310 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71311 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71312 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
71313 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71314 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
71315 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71316 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
71317 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
71318 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71319 & (-1+R1**2-R2**2+X2)**2
71322 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71323 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
71324 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
71325 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71326 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
71327 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71328 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
71329 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
71330 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71331 & (-1+R1**2-R2**2+X2)**2
71334 IF(ICOMBI.EQ.4) THEN
71335 RLO4=PS*(1D0+R1**2-R2**2)
71336 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
71337 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71338 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
71339 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
71340 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
71341 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
71345 C...V -> ~q ~qbar (~q = squark).
71346 ELSEIF(ICLASS.EQ.6) THEN
71347 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
71348 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
71349 & (-1-R1**2+R2**2+X1)**2
71350 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
71351 & (-1-R1**2+R2**2+X1)
71352 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
71353 & /(-1+R1**2-R2**2+X2)**2
71354 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
71355 & (-1+R1**2-R2**2+X2)
71356 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
71357 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
71358 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
71359 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71363 ELSEIF(ICLASS.EQ.7) THEN
71364 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
71365 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
71366 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
71367 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
71368 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
71369 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
71370 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
71371 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
71372 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
71373 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
71374 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
71380 ELSEIF(ICLASS.EQ.8) THEN
71382 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
71383 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
71384 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
71385 & -R1**2*X2**2+X1*X2**2)/
71386 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
71391 ELSEIF(ICLASS.EQ.9) THEN
71393 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71394 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71395 & -(X1+X2)/(-2+X1+X2)**2
71398 C...chi -> q ~qbar (chi = neutralino/chargino).
71399 ELSEIF(ICLASS.EQ.10) THEN
71400 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71401 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71402 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
71403 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
71404 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
71405 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71406 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
71407 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71408 & (-1+R1**2-R2**2+X2)**2
71411 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71412 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
71413 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
71414 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
71415 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
71416 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71417 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
71418 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71419 & (-1+R1**2-R2**2+X2)**2
71422 IF(ICOMBI.EQ.4) THEN
71423 RLO4=PS*(1+R1**2-R2**2)
71424 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
71425 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
71426 & +X2+R1**2*X2-X1*X2/2)/
71427 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71428 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
71429 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
71434 ELSEIF(ICLASS.EQ.11) THEN
71435 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71436 RLO1=PS*(1D0-(R1+R2)**2)
71437 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
71438 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71439 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71440 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71441 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
71442 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71443 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71446 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71447 RLO2=PS*(1D0-(R1-R2)**2)
71448 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
71450 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71451 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
71452 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71453 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
71454 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71455 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71458 IF(ICOMBI.EQ.4) THEN
71459 RLO4=PS*(1D0-R1**2-R2**2)
71460 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
71461 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
71462 & +3*R1**2*X2-R2**2*X2-X1*X2)/
71463 & (-1+R1**2-R2**2+X2)**2
71464 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
71465 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
71466 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71471 ELSEIF(ICLASS.EQ.12) THEN
71472 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71473 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
71474 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71475 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
71476 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
71477 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
71478 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71479 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71482 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71483 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
71484 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
71485 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
71486 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
71487 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
71488 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71489 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71492 IF(ICOMBI.EQ.4) THEN
71493 RLO4=PS*(1D0-R1**2+R2**2)
71494 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71495 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
71496 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
71497 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
71498 & +R1**2*X2-X1*X2/2-X2**2/2)/
71499 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71504 ELSEIF(ICLASS.EQ.13) THEN
71505 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71506 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71507 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
71508 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
71509 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
71510 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
71511 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
71512 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
71513 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
71514 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
71515 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
71516 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
71517 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
71518 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71519 & (3*(-1+R1**2-R2**2+X2)**2)
71523 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71524 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
71525 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
71526 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
71527 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71528 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
71529 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
71530 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
71531 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
71532 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
71533 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
71534 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71535 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
71536 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
71537 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71538 & (3*(-1+R1**2-R2**2+X2)**2)
71542 IF(ICOMBI.EQ.4) THEN
71543 RLO4=PS*(1D0+R1**2-R2**2)
71544 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
71545 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
71546 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
71547 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
71548 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
71549 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71550 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
71551 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71552 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
71553 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71554 & (3*(-1+R1**2-R2**2+X2)**2)
71560 ELSEIF(ICLASS.EQ.14) THEN
71561 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71562 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
71563 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
71564 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71565 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71566 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
71567 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
71568 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
71569 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
71570 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71571 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71572 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
71573 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
71574 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
71575 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
71577 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
71578 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71579 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71583 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71584 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
71585 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
71586 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71587 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71588 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
71589 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
71590 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
71591 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
71592 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
71593 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
71594 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
71596 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
71597 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
71598 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
71599 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
71600 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
71601 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71605 IF(ICOMBI.EQ.4) THEN
71606 RLO4=PS*(1-R1**2-R2**2)
71607 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
71608 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
71609 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71610 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
71611 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
71612 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
71613 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
71614 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
71615 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
71616 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
71617 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
71618 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
71619 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
71620 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
71621 RFO4=9D0*RFO4/128D0
71626 ELSEIF(ICLASS.EQ.15) THEN
71627 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71628 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
71629 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
71630 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
71631 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
71632 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
71633 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
71634 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
71635 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
71636 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
71637 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
71638 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
71639 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
71640 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
71641 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
71642 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71646 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71647 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
71648 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
71649 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
71650 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
71651 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
71652 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
71653 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
71654 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
71655 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
71656 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71657 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
71658 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
71659 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
71660 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71661 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71665 IF(ICOMBI.EQ.4) THEN
71666 RLO4=PS*(1D0-R1**2+R2**2)
71667 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
71668 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
71669 & -R2**2*X2/2-X1*X2/2)/
71670 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
71671 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
71672 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71673 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
71674 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
71675 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
71676 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
71677 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
71678 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71683 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
71684 ELSEIF(ICLASS.EQ.16) THEN
71686 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
71688 ELSEIF(ICOMBI.EQ.2) THEN
71689 ANUM=(2D0-X1-X2)**2
71690 ELSEIF(ICOMBI.EQ.3) THEN
71691 ANUM=ALPCOR*(2D0-X1-X2)**2
71693 ANUM=0.5D0*(2D0-X1-X2)**2
71695 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
71696 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
71697 & R1**2/(1D0+R2**2-R1**2-X2)**2-
71698 & R2**2/(1D0+R1**2-R2**2-X1)**2)
71703 C...Find relevant LO and FO expression.
71704 IF(ICOMBI.EQ.0) THEN
71705 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
71708 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
71711 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
71712 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
71713 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
71714 ELSEIF(ISSET4.EQ.1) THEN
71717 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
71718 RLO=0.5D0*(RLO1+RLO2)
71719 RFO=0.5D0*(RFO1+RFO2)
71720 ELSEIF(ISSET1.EQ.1) THEN
71724 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
71735 C*********************************************************************
71738 C...Modifies an event so as to approximately take into account
71739 C...Bose-Einstein effects according to a simple phenomenological
71740 C...parametrization.
71742 SUBROUTINE PYBOEI(NSAV)
71744 C...Double precision and integer declarations.
71745 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71746 IMPLICIT INTEGER(I-N)
71747 INTEGER PYK,PYCHGE,PYCOMP
71748 C...Parameter statement to help give large particle numbers.
71749 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71750 &KEXCIT=4000000,KDIMEN=5000000)
71752 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71753 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71754 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71755 COMMON/PYINT1/MINT(400),VINT(400)
71756 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
71757 C...Local arrays and data.
71758 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
71759 &BEIW(100),BEI3W(100)
71760 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
71761 C...Statement function: squared invariant mass.
71762 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
71763 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
71765 C...Boost event to overall CM frame. Calculate CM energy.
71766 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
71772 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
71773 & .AND.K(I,3).GT.0) THEN
71774 KFMA=IABS(K(K(I,3),2))
71775 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
71777 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
71779 DPS(J)=DPS(J)+P(I,J)
71782 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
71786 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
71789 C...Check if we have separated strings
71791 C...Reserve copy of particles by species at end of record.
71797 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
71798 NBE(IBE)=NBE(IBE-1)
71800 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
71801 DO 140 IIBE=1,IBE-1
71802 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
71805 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
71807 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
71808 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
71809 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
71812 NBE(IBE)=NBE(IBE)+1
71819 P(NBE(IBE),1)=0.0D0
71820 P(NBE(IBE),2)=0.0D0
71821 P(NBE(IBE),3)=0.0D0
71822 P(NBE(IBE),4)=0.0D0
71823 P(NBE(IBE),5)=0.0D0
71824 SMMIN=MIN(SMMIN,P(I,5))
71825 C...Check if particles comes from different W's or Z's
71826 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
71828 150 IF(K(IM,3).GT.0) THEN
71830 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
71832 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
71833 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
71834 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
71835 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
71838 C...Check if particles comes from different strings.
71839 IF(PARJ(94).GT.0.0D0) THEN
71841 160 IF(K(IM,3).GT.0) THEN
71843 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
71851 P(NBE(IBE),5)=-1.0D0
71854 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
71856 C...Calculate separation between W+ and W- or between two Z0's.
71857 C...No separation if there has been re-connections.
71859 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
71860 IF(K(IWP,2).EQ.23) THEN
71869 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
71870 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
71871 TAUP=-TAUPD*LOG(PYR(IDUM))
71872 TAUN=-TAUND*LOG(PYR(IDUM))
71873 DXP=TAUP*PYP(IWP,8)/DMP
71874 DXN=TAUN*PYP(IWN,8)/DMN
71876 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
71877 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
71880 C...Add separation between strings.
71881 IF(PARJ(94).GT.0.0D0) THEN
71882 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
71887 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
71888 DO 220 IBE=1,MIN(9,MSTJ(52))
71889 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
71892 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
71893 IF(I2M.EQ.I1M) GOTO 200
71895 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
71896 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
71897 & (P(I1,5)+P(I2,5))**2
71898 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
71907 C...Tabulate integral for subsequent momentum shift.
71908 DO 400 IBE=1,MIN(9,MSTJ(52))
71909 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
71910 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
71912 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
71913 & NBE(7)-NBE(6)).LE.1) GOTO 270
71914 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
71915 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
71916 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
71917 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
71918 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
71919 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
71920 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
71921 QDELW=0.1D0*MIN(PMHQ,SIGW)
71922 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
71923 IF(MSTJ(51).EQ.1) THEN
71924 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
71925 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
71926 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
71927 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
71928 BEEX=EXP(0.5D0*QDEL/PARJ(93))
71929 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
71930 BEEXW=EXP(0.5D0*QDELW/SIGW)
71931 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
71932 BERT=EXP(-QDEL/PARJ(93))
71933 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
71934 BERTW=EXP(-QDELW/SIGW)
71935 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
71937 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
71938 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
71939 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
71940 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
71943 QBIN=QDEL*(IBIN-0.5D0)
71944 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71945 IF(MSTJ(51).EQ.1) THEN
71947 BEI(IBIN)=BEI(IBIN)*BEEX
71949 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
71951 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
71953 DO 240 IBIN=1,NBIN3
71954 QBIN=QDEL3*(IBIN-0.5D0)
71955 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71956 IF(MSTJ(51).EQ.1) THEN
71958 BEI3(IBIN)=BEI3(IBIN)*BEEX3
71960 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
71962 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
71964 DO 250 IBIN=1,NBINW
71965 QBIN=QDELW*(IBIN-0.5D0)
71966 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71967 IF(MSTJ(51).EQ.1) THEN
71969 BEIW(IBIN)=BEIW(IBIN)*BEEXW
71971 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
71973 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
71975 DO 260 IBIN=1,NBIN3W
71976 QBIN=QDEL3W*(IBIN-0.5D0)
71977 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
71978 & SQRT(QBIN**2+PMHQ**2)
71979 IF(MSTJ(51).EQ.1) THEN
71980 BEEX3W=BEEX3W*BERT3W
71981 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
71983 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
71985 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
71988 C...Loop through particle pairs and find old relative momentum.
71989 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
71991 DO 380 I2M=I1M+1,NBE(IBE)
71992 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
71993 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
71995 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
71996 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
71997 IF(Q2OLD.LE.0.0D0) GOTO 380
72000 C...Calculate new relative momentum.
72005 IF(QOLD.LT.1D-3*QDEL) THEN
72007 ELSEIF(QOLD.LE.QDEL) THEN
72009 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
72012 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
72013 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
72014 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72016 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72018 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
72019 IF(QOLD.LT.1D-3*QDEL3) THEN
72021 ELSEIF(QOLD.LE.QDEL3) THEN
72023 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
72026 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
72027 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
72028 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72030 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72032 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
72035 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
72036 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
72037 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
72039 IF(QOLD.LT.1D-3*QDELW) THEN
72041 ELSEIF(QOLD.LE.QDELW) THEN
72043 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
72046 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
72047 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
72048 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72050 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72052 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
72053 IF(QOLD.LT.1D-3*QDEL3W) THEN
72055 ELSEIF(QOLD.LE.QDEL3W) THEN
72057 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
72060 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
72061 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
72062 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72064 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72066 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
72068 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
72070 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
72072 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
72073 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
72075 IF(MSTJ(54).GE.1) THEN
72076 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
72078 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
72079 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
72081 ELSEIF(MSTJ(54).LE.-1) THEN
72082 EDEL=P(I1,4)+P(I2,4)-
72083 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
72084 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
72085 & (P(I1,3)-P(I2,3))**2
72090 SM1=(P(I1,5)+SMMIN)**2
72091 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72092 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
72093 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
72094 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
72095 & K(I3M,5).NE.K(I1M,5)) GOTO 360
72097 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
72100 SM3=(P(I3,5)+SMMIN)**2
72101 IF(MSTJ(54).EQ.-2) THEN
72102 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
72103 & S23*MIN(SM1,SM3))*SM1)
72105 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
72106 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
72107 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
72108 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
72110 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
72111 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
72114 IF(WMAX*WI.GE.1.0) GOTO 360
72116 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
72117 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
72118 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
72119 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
72120 & K(I4M,5).NE.K(I1M,5)) GOTO 350
72122 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
72124 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
72125 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
72126 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
72128 IF(MSTJ(54).EQ.-2) THEN
72132 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
72133 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
72134 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
72135 W=MIN(W,MIN(S23,S24)*S13*S14)
72138 C...weight=1-cos(theta)/mtot2
72139 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
72140 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
72141 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
72142 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
72144 IF(W.LE.WMAX) GOTO 350
72146 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
72147 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
72148 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
72149 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
72150 IF(W.LE.WMAX) GOTO 350
72156 IF(MI4.EQ.0) GOTO 380
72159 EOLD=P(I3,4)+P(I4,4)
72161 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
72162 & (P(I3,3)+P(I4,3))**2
72163 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
72164 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
72165 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
72167 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
72168 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
72175 C...Shift momenta and recalculate energies.
72179 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72183 P(I,J)=P(I,J)+P(IM,J)
72185 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72188 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
72193 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
72194 440 ALPHA=(ESUMP-ESUM)/PROD
72195 PARJ(96)=PARJ(96)+ALPHA
72198 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72201 P(I,J)=P(I,J)+ALPHA*V(IM,J)
72203 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72206 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
72209 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
72213 C...Rescale all momenta for energy conservation.
72217 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
72219 PQS=PQS+P(I,5)**2/P(I,4)
72222 FAC=(PECM-PQS)/(PES-PQS)
72224 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
72228 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72231 C...Boost back to correct reference frame.
72232 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
72234 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
72240 C*********************************************************************
72243 C...Calculates the momentum shift in a system of two particles assuming
72244 C...the relative momentum squared should be shifted to Q2NEW. NI is the
72245 C...last position occupied in /PYJETS/.
72247 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
72249 C...Double precision and integer declarations.
72250 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72251 IMPLICIT INTEGER(I-N)
72252 INTEGER PYK,PYCHGE,PYCOMP
72253 C...Parameter statement to help give large particle numbers.
72254 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72255 &KEXCIT=4000000,KDIMEN=5000000)
72257 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72258 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72259 SAVE /PYJETS/,/PYDAT1/
72260 C...Local arrays and data.
72264 IF(MSTJ(55).EQ.0) THEN
72266 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
72267 & (P(I1,3)-P(I2,3))**2
72268 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
72269 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
72273 DA=SE*DE*DP12-DP2*DQ2SE
72274 DB=DP2*DQ2SE-DP12**2
72275 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
72277 PD=HA*(P(I1,J)-P(I2,J))
72289 DP(J)=P(I1,J)+P(I2,J)
72292 C...Boost to cms and rotate first particle to z-axis
72293 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
72294 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
72295 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
72296 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
72297 S=Q2NEW+(P(I1,5)+P(I2,5))**2
72298 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
72302 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
72306 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
72307 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
72308 CALL PYROBO(NI+1,NI+2,THE,PHI,
72309 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
72312 P(NI+1,J)=P(NI+1,J)-P(I1,J)
72313 P(NI+2,J)=P(NI+2,J)-P(I2,J)
72319 C*********************************************************************
72322 C...Gives the mass of a particle/parton.
72324 FUNCTION PYMASS(KF)
72326 C...Double precision and integer declarations.
72327 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72328 IMPLICIT INTEGER(I-N)
72329 INTEGER PYK,PYCHGE,PYCOMP
72331 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72332 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72333 SAVE /PYDAT1/,/PYDAT2/
72335 C...Reset variables. Compressed code. Special case for popcorn diquarks.
72344 C...Guarantee use of constituent masses for internal checks.
72345 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
72346 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
72348 PYMASS=PARF(100+KFA)
72349 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
72350 ELSEIF(KFA.LE.10) THEN
72352 ELSEIF(MSTJ(93).EQ.1) THEN
72353 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
72355 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
72358 C...Other masses can be read directly off table.
72363 C...Optional mass broadening according to truncated Breit-Wigner
72364 C...(either in m or in m^2).
72365 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
72366 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
72367 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
72368 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
72371 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
72372 & (PM0*PMAS(KC,2)))
72373 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
72374 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
72375 & (PMUPP-PMLOW)*PYR(0))))
72383 C*********************************************************************
72386 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
72387 C...for Higgs couplings. Everything else sent on to PYMASS.
72389 FUNCTION PYMRUN(KF,Q2)
72391 C...Double precision and integer declarations.
72392 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72393 IMPLICIT INTEGER(I-N)
72394 INTEGER PYK,PYCHGE,PYCOMP
72396 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72397 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72398 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
72399 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
72401 C...Most masses not handled here.
72403 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
72406 C...Current-algebra masses, but no Q2 dependence.
72407 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
72408 PYMRUN=PARF(90+KFA)
72410 C...Running current-algebra masses.
72413 PYMRUN=PARF(90+KFA)*
72414 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
72415 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
72421 C*********************************************************************
72424 C...Gives the particle/parton name as a character string.
72426 SUBROUTINE PYNAME(KF,CHAU)
72428 C...Double precision and integer declarations.
72429 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72430 IMPLICIT INTEGER(I-N)
72431 INTEGER PYK,PYCHGE,PYCOMP
72433 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72434 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72435 COMMON/PYDAT4/CHAF(500,2)
72437 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
72438 C...Local character variable.
72441 C...Read out code with distinction particle/antiparticle.
72444 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
72450 C*********************************************************************
72453 C...Gives three times the charge for a particle/parton.
72455 FUNCTION PYCHGE(KF)
72457 C...Double precision and integer declarations.
72458 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72459 IMPLICIT INTEGER(I-N)
72460 INTEGER PYK,PYCHGE,PYCOMP
72462 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72465 C...Read out charge and change sign for antiparticle.
72468 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
72473 C*********************************************************************
72476 C...Compress the standard KF codes for use in mass and decay arrays;
72477 C...also checks whether a given code actually is defined.
72479 FUNCTION PYCOMP(KF)
72481 C...Double precision and integer declarations.
72482 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72483 IMPLICIT INTEGER(I-N)
72484 INTEGER PYK,PYCHGE,PYCOMP
72486 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72487 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72488 SAVE /PYDAT1/,/PYDAT2/
72489 C...Local arrays and saved data.
72490 DIMENSION KFORD(100:500),KCORD(101:500)
72491 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
72493 C...Whenever necessary reorder codes for faster search.
72494 IF(MSTU(20).EQ.0) THEN
72499 IF(KFA.LE.100) GOTO 120
72501 DO 100 I1=NFORD-1,0,-1
72502 IF(KFA.GE.KFORD(I1)) GOTO 110
72503 KFORD(I1+1)=KFORD(I1)
72504 KCORD(I1+1)=KCORD(I1)
72506 110 KFORD(I1+1)=KFA
72514 C...Fast action if same code as in latest call.
72515 IF(KF.EQ.KFLAST) THEN
72520 C...Starting values. Remove internal diquark flags.
72523 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
72524 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
72526 C...Simple cases: direct translation.
72527 IF(KFA.GT.KFORD(NFORD)) THEN
72528 ELSEIF(KFA.LE.100) THEN
72531 C...Else binary search.
72535 130 IAVG=(IMIN+IMAX)/2
72536 IF(KFORD(IAVG).GT.KFA) THEN
72538 IF(IMAX.GT.IMIN+1) GOTO 130
72539 ELSEIF(KFORD(IAVG).LT.KFA) THEN
72541 IF(IMAX.GT.IMIN+1) GOTO 130
72547 C...Check if antiparticle allowed.
72548 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
72549 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
72552 C...Save codes for possible future fast action.
72559 C*********************************************************************
72562 C...Informs user of errors in program execution.
72564 SUBROUTINE PYERRM(MERR,CHMESS)
72566 C...Double precision and integer declarations.
72567 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72568 IMPLICIT INTEGER(I-N)
72569 INTEGER PYK,PYCHGE,PYCOMP
72571 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72572 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72573 SAVE /PYJETS/,/PYDAT1/
72574 C...Local character variable.
72575 CHARACTER CHMESS*(*)
72577 C...Write first few warnings, then be silent.
72578 IF(MERR.LE.10) THEN
72579 MSTU(27)=MSTU(27)+1
72581 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
72582 & MERR,MSTU(31),CHMESS
72584 C...Write first few errors, then be silent or stop program.
72585 ELSEIF(MERR.LE.20) THEN
72586 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
72587 MSTU(30)=MSTU(30)+1
72589 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
72590 & MERR-10,MSTU(31),CHMESS
72591 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
72592 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
72593 WRITE(MSTU(11),5200)
72594 IF(MERR.NE.17) CALL PYLIST(2)
72598 C...Stop program in case of irreparable error.
72600 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
72604 C...Formats for output.
72605 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
72606 &' PYEXEC calls:'/5X,A)
72607 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
72608 &' PYEXEC calls:'/5X,A)
72609 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
72611 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
72612 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
72617 C*********************************************************************
72620 C...Calculates the running alpha_electromagnetic.
72622 FUNCTION PYALEM(Q2)
72624 C...Double precision and integer declarations.
72625 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72626 IMPLICIT INTEGER(I-N)
72627 INTEGER PYK,PYCHGE,PYCOMP
72629 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72632 C...Calculate real part of photon vacuum polarization.
72633 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
72634 C...For hadrons use parametrization of H. Burkhardt et al.
72635 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
72636 AEMPI=PARU(101)/(3D0*PARU(1))
72637 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
72639 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
72641 ELSEIF(MSTU(101).EQ.2) THEN
72642 RPIGG=1D0-PARU(101)/PARU(103)
72643 ELSEIF(Q2.LT.0.09D0) THEN
72644 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
72645 ELSEIF(Q2.LT.9D0) THEN
72646 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
72647 & 0.00238D0*LOG(1D0+3.927D0*Q2)
72648 ELSEIF(Q2.LT.1D4) THEN
72649 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
72650 & 0.00299D0*LOG(1D0+Q2)
72652 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
72653 & 0.00293D0*LOG(1D0+Q2)
72656 C...Calculate running alpha_em.
72657 PYALEM=PARU(101)/(1D0-RPIGG)
72663 C*********************************************************************
72666 C...Gives the value of alpha_strong.
72668 FUNCTION PYALPS(Q2)
72670 C...Double precision and integer declarations.
72671 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72672 IMPLICIT INTEGER(I-N)
72673 INTEGER PYK,PYCHGE,PYCOMP
72675 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72676 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72677 SAVE /PYDAT1/,/PYDAT2/
72678 C...Coefficients for second-order threshold matching.
72679 C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
72680 DIMENSION STEPDN(6),STEPUP(6)
72681 c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
72682 c &(2D0*321D0/3703D0),0D0/
72683 c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
72684 c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
72685 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
72686 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
72688 C...Constant alpha_strong trivial. Pick artificial Lambda.
72689 IF(MSTU(111).LE.0) THEN
72691 MSTU(118)=MSTU(112)
72693 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
72694 & ((33D0-2D0*MSTU(112))*PARU(111)))
72695 PARU(118)=PARU(111)
72699 C...Find effective Q2, number of flavours and Lambda.
72701 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
72704 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
72705 Q2THR=PARU(113)*PMAS(NF,1)**2
72706 IF(Q2EFF.LT.Q2THR) THEN
72709 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
72710 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
72714 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
72715 Q2THR=PARU(113)*PMAS(NF+1,1)**2
72716 IF(Q2EFF.GT.Q2THR) THEN
72719 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
72720 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
72724 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
72725 PARU(117)=SQRT(ALAM2)
72727 C...Evaluate first or second order alpha_strong.
72728 B0=(33D0-2D0*NF)/6D0
72729 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
72730 IF(MSTU(111).EQ.1) THEN
72731 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
72733 B1=(153D0-19D0*NF)/6D0
72734 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
72743 C*********************************************************************
72746 C...Reconstructs an angle from given x and y coordinates.
72748 FUNCTION PYANGL(X,Y)
72750 C...Double precision and integer declarations.
72751 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72752 IMPLICIT INTEGER(I-N)
72753 INTEGER PYK,PYCHGE,PYCOMP
72755 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72760 IF(R.LT.1D-20) RETURN
72761 IF(ABS(X)/R.LT.0.8D0) THEN
72762 PYANGL=SIGN(ACOS(X/R),Y)
72765 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
72766 PYANGL=PARU(1)-PYANGL
72767 ELSEIF(X.LT.0D0) THEN
72768 PYANGL=-PARU(1)-PYANGL
72775 C*********************************************************************
72778 C...Performs rotations and boosts.
72780 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
72782 C...Double precision and integer declarations.
72783 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72784 IMPLICIT INTEGER(I-N)
72785 INTEGER PYK,PYCHGE,PYCOMP
72787 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72788 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72789 SAVE /PYJETS/,/PYDAT1/
72791 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
72793 C...Find and check range of rotation/boost.
72795 IF(IMIN.LE.0) IMIN=1
72796 IF(MSTU(1).GT.0) IMIN=MSTU(1)
72798 IF(IMAX.LE.0) IMAX=N
72799 IF(MSTU(2).GT.0) IMAX=MSTU(2)
72800 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
72801 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
72805 C...Optional resetting of V (when not set before.)
72806 IF(MSTU(33).NE.0) THEN
72807 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
72815 C...Rotate, typically from z axis to direction (theta,phi).
72816 IF(THE**2+PHI**2.GT.1D-20) THEN
72817 ROT(1,1)=COS(THE)*COS(PHI)
72819 ROT(1,3)=SIN(THE)*COS(PHI)
72820 ROT(2,1)=COS(THE)*SIN(PHI)
72822 ROT(2,3)=SIN(THE)*SIN(PHI)
72827 IF(K(I,1).LE.0) GOTO 140
72833 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
72834 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
72839 C...Boost, typically from rest to momentum/energy=beta.
72840 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
72844 DB=SQRT(DBX**2+DBY**2+DBZ**2)
72846 IF(DB.GT.EPS1) THEN
72847 C...Rescale boost vector if too close to unity.
72848 CALL PYERRM(3,'(PYROBO:) boost vector too large')
72854 DGA=1D0/SQRT(1D0-DB**2)
72856 IF(K(I,1).LE.0) GOTO 160
72861 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
72862 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
72863 P(I,1)=DP(1)+DGABP*DBX
72864 P(I,2)=DP(2)+DGABP*DBY
72865 P(I,3)=DP(3)+DGABP*DBZ
72866 P(I,4)=DGA*(DP(4)+DBP)
72867 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
72868 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
72869 V(I,1)=DV(1)+DGABV*DBX
72870 V(I,2)=DV(2)+DGABV*DBY
72871 V(I,3)=DV(3)+DGABV*DBZ
72872 V(I,4)=DGA*(DV(4)+DBV)
72879 C*********************************************************************
72882 C...Performs global manipulations on the event record, in particular
72883 C...to exclude unstable or undetectable partons/particles.
72885 SUBROUTINE PYEDIT(MEDIT)
72887 C...Double precision and integer declarations.
72888 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72889 IMPLICIT INTEGER(I-N)
72890 INTEGER PYK,PYCHGE,PYCOMP
72891 C...Parameter statement to help give large particle numbers.
72892 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72893 &KEXCIT=4000000,KDIMEN=5000000)
72895 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72896 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72897 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72898 COMMON/PYCTAG/NCT,MCT(4000,2)
72899 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
72901 DIMENSION NS(2),PTS(2),PLS(2)
72903 C...Remove unwanted partons/particles.
72904 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
72906 IF(MSTU(2).GT.0) IMAX=MSTU(2)
72907 I1=MAX(1,MSTU(1))-1
72908 DO 110 I=MAX(1,MSTU(1)),IMAX
72909 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
72910 IF(MEDIT.EQ.1) THEN
72911 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72912 ELSEIF(MEDIT.EQ.2) THEN
72913 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72915 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72916 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72917 & K(I,2).EQ.KSUSY1+39) GOTO 110
72918 ELSEIF(MEDIT.EQ.3) THEN
72919 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72921 IF(KC.EQ.0) GOTO 110
72922 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
72923 ELSEIF(MEDIT.EQ.5) THEN
72924 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
72926 IF(KC.EQ.0) GOTO 110
72927 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
72928 & KCHG(KC,2).EQ.0) GOTO 110
72931 C...Pack remaining partons/particles. Origin no longer known.
72940 IF(I1.LT.N) MSTU(3)=0
72941 IF(I1.LT.N) MSTU(70)=0
72944 C...Selective removal of class of entries. New position of retained.
72945 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
72948 K(I,3)=MOD(K(I,3),MSTU(5))
72949 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
72950 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
72951 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
72952 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
72953 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
72954 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
72955 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
72957 K(I,3)=K(I,3)+MSTU(5)*I1
72960 C...Find new event history information and replace old.
72962 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
72963 & K(I,3)/MSTU(5).EQ.0) GOTO 140
72965 130 IM=MOD(K(ID,3),MSTU(5))
72966 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
72967 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
72968 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
72972 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
72973 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
72974 & K(IM,2).EQ.94) THEN
72979 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
72980 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
72981 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
72982 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
72983 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
72984 & K(K(I,4),3)/MSTU(5)
72985 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
72986 & K(K(I,5),3)/MSTU(5)
72988 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
72989 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
72990 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
72991 KCD=MOD(K(I,4),MSTU(5))
72992 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
72993 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
72994 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
72995 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
72996 KCD=MOD(K(I,5),MSTU(5))
72997 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
72998 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
73002 C...Pack remaining entries.
73007 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
73014 C...Also update LHA1 colour tags
73017 K(I1,3)=MOD(K(I1,3),MSTU(5))
73019 IF(I.EQ.MSTU(90+IZ)) THEN
73020 MSTU(90)=MSTU(90)+1
73021 MSTU(90+MSTU(90))=I1
73022 PARU(90+MSTU(90))=PARU(90+IZ)
73026 IF(I1.LT.N) MSTU(3)=0
73027 IF(I1.LT.N) MSTU(70)=0
73030 C...Fill in some missing daughter pointers (lost in colour flow).
73031 ELSEIF(MEDIT.EQ.16) THEN
73033 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
73034 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
73035 C...Find daughters who point to mother.
73037 IF(K(I1,3).NE.I) THEN
73038 ELSEIF(K(I,4).EQ.0) THEN
73044 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73045 IF(K(I,4).NE.0) GOTO 220
73046 C...Find daughters who point to documentation version of mother.
73048 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
73049 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
73050 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
73052 IF(K(I1,3).NE.IM) THEN
73053 ELSEIF(K(I,4).EQ.0) THEN
73059 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73060 IF(K(I,4).NE.0) GOTO 220
73061 C...Find daughters who point to documentation daughters who,
73062 C...in their turn, point to documentation mother.
73066 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
73068 IF(ID1.EQ.IM) ID1=I1
73072 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
73073 ELSEIF(K(I,4).EQ.0) THEN
73079 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73082 C...Save top entries at bottom of PYJETS commonblock.
73083 ELSEIF(MEDIT.EQ.21) THEN
73084 IF(2*N.GE.MSTU(4)) THEN
73085 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
73090 K(MSTU(4)-I,J)=K(I,J)
73091 P(MSTU(4)-I,J)=P(I,J)
73092 V(MSTU(4)-I,J)=V(I,J)
73097 C...Restore bottom entries of commonblock PYJETS to top.
73098 ELSEIF(MEDIT.EQ.22) THEN
73099 DO 260 I=1,MSTU(32)
73101 K(I,J)=K(MSTU(4)-I,J)
73102 P(I,J)=P(MSTU(4)-I,J)
73103 V(I,J)=V(MSTU(4)-I,J)
73108 C...Mark primary entries at top of commonblock PYJETS as untreated.
73109 ELSEIF(MEDIT.EQ.23) THEN
73114 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
73116 IF(KH.NE.0) GOTO 280
73118 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
73119 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
73123 C...Place largest axis along z axis and second largest in xy plane.
73124 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
73125 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
73126 & P(MSTU(61),2)),0D0,0D0,0D0)
73127 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
73128 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
73129 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
73130 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
73131 IF(MEDIT.EQ.31) RETURN
73133 C...Rotate to put slim jet along +z axis.
73140 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
73141 IF(MSTU(41).GE.2) THEN
73143 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73144 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73145 & K(I,2).EQ.KSUSY1+39) GOTO 300
73146 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
73149 IS=2D0-SIGN(0.5D0,P(I,3))
73151 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
73153 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
73154 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
73156 C...Rotate to put second largest jet into -z,+x quadrant.
73158 IF(P(I,3).GE.0D0) GOTO 310
73159 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
73160 IF(MSTU(41).GE.2) THEN
73162 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73163 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73164 & K(I,2).EQ.KSUSY1+39) GOTO 310
73165 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
73168 IS=2D0-SIGN(0.5D0,P(I,1))
73169 PLS(IS)=PLS(IS)-P(I,3)
73171 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
73178 C*********************************************************************
73181 C...Gives program heading, or lists an event, or particle
73182 C...data, or current parameter values.
73184 SUBROUTINE PYLIST(MLIST)
73186 C...Double precision and integer declarations.
73187 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73188 IMPLICIT INTEGER(I-N)
73189 INTEGER PYK,PYCHGE,PYCOMP
73190 C...Parameter statement to help give large particle numbers.
73191 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
73192 &KEXCIT=4000000,KDIMEN=5000000)
73194 C...HEPEVT commonblock.
73195 PARAMETER (NMXHEP=4000)
73196 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
73197 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
73198 DOUBLE PRECISION PHEP,VHEP
73201 C...User process event common block.
73203 PARAMETER (MAXNUP=500)
73204 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
73205 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
73206 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
73207 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
73208 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
73212 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73213 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73214 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73215 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
73216 COMMON/PYCTAG/NCT,MCT(4000,2)
73217 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
73218 C...Local arrays, character variables and data.
73219 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
73221 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
73223 C...Initialization printout: version number and date of last change.
73224 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
73227 IF(MLIST.EQ.0) RETURN
73230 C...List event data, including additional lines after N.
73231 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
73232 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
73233 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
73234 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
73235 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
73237 IF(MLIST.GE.2) LMX=16
73240 IF(MSTU(2).GT.0) IMAX=MSTU(2)
73241 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
73242 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
73243 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
73244 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
73246 C...Get particle name, pad it and check it is not too long.
73247 CALL PYNAME(K(I,2),CHAP)
73250 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
73254 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
73256 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
73259 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
73261 CHAC=CHDL(MDL)(1:2*LDL)//' '
73263 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
73264 & CHDL(MDL)(LDL+1:2*LDL)//' '
73265 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
73269 C...Add information on string connection.
73270 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
73274 IF(KC.NE.0) KCC=KCHG(KC,2)
73275 IF(IABS(K(I,2)).EQ.39) THEN
73276 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
73277 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
73279 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
73280 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
73281 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
73282 ELSEIF(KCC.NE.0) THEN
73284 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
73287 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
73288 & CHAC(LMX-1:LMX-1)='I'
73290 C...Write data for particle/jet.
73291 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
73292 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
73294 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
73295 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
73297 ELSEIF(MLIST.EQ.1) THEN
73298 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
73300 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
73301 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
73302 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
73303 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
73304 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
73306 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
73307 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
73308 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
73309 & ,10000),MCT(I,1),MCT(I,2)
73311 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
73313 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
73314 & ,MCT(I,1),MCT(I,2)
73316 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
73318 C...Insert extra separator lines specified by user.
73319 IF(MSTU(70).GE.1) THEN
73321 DO 110 J=1,MIN(10,MSTU(70))
73322 IF(I.EQ.MSTU(70+J)) ISEP=1
73325 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
73326 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
73327 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
73332 C...Sum of charges and momenta.
73336 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
73337 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
73338 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
73339 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
73340 ELSEIF(MLIST.EQ.1) THEN
73341 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
73342 ELSEIF(MLIST.LE.3) THEN
73343 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
73345 WRITE(MSTU(11),7000) PS(6)
73348 C...Simple listing of HEPEVT entries (mainly for test purposes).
73349 ELSEIF(MLIST.EQ.5) THEN
73350 WRITE(MSTU(11),7100)
73352 IF(ISTHEP(I).EQ.0) GOTO 140
73353 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
73354 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
73358 C...Simple listing of user-process entries (mainly for test purposes).
73359 ELSEIF(MLIST.EQ.7) THEN
73360 WRITE(MSTU(11),7300)
73362 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
73363 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
73366 C...Give simple list of KF codes defined in program.
73367 ELSEIF(MLIST.EQ.11) THEN
73368 WRITE(MSTU(11),7500)
73370 CALL PYNAME(KF,CHAP)
73371 CALL PYNAME(-KF,CHAN)
73372 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
73373 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73377 DO 170 KFLB=1,KFLA-(3-KFLS)/2
73378 KF=1000*KFLA+100*KFLB+KFLS
73379 CALL PYNAME(KF,CHAP)
73380 CALL PYNAME(-KF,CHAN)
73381 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73387 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
73388 IF(KMUL.EQ.5) KFLS=5
73390 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
73391 IF(KMUL.EQ.4) KFLR=2
73393 DO 200 KFLC=1,KFLB-1
73394 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
73395 CALL PYNAME(KF,CHAP)
73396 CALL PYNAME(-KF,CHAN)
73397 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73400 CALL PYNAME(KFK,CHAP)
73401 WRITE(MSTU(11),7600) KFK,CHAP
73403 CALL PYNAME(KFK,CHAP)
73404 WRITE(MSTU(11),7600) KFK,CHAP
73407 KF=10000*KFLR+110*KFLB+KFLS
73408 CALL PYNAME(KF,CHAP)
73409 WRITE(MSTU(11),7600) KF,CHAP
73413 CALL PYNAME(KF,CHAP)
73414 WRITE(MSTU(11),7600) KF,CHAP
73416 CALL PYNAME(KF,CHAP)
73417 WRITE(MSTU(11),7600) KF,CHAP
73423 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
73425 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
73426 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
73427 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
73428 CALL PYNAME(KF,CHAP)
73429 CALL PYNAME(-KF,CHAN)
73430 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73437 IF(KF.LT.1000000) GOTO 270
73438 CALL PYNAME(KF,CHAP)
73439 CALL PYNAME(-KF,CHAN)
73440 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
73441 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73444 C...List parton/particle data table. Check whether to be listed.
73445 ELSEIF(MLIST.EQ.12) THEN
73446 WRITE(MSTU(11),7700)
73447 DO 300 KC=1,MSTU(6)
73449 IF(KF.EQ.0) GOTO 300
73450 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
73453 C...Find particle name and mass. Print information.
73454 CALL PYNAME(KF,CHAP)
73455 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
73456 CALL PYNAME(-KF,CHAN)
73457 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
73458 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
73460 C...Particle decay: channel number, branching ratios, matrix element,
73461 C...decay products.
73462 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73464 CALL PYNAME(KFDP(IDC,J),CHAD(J))
73466 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
73471 C...List parameter value table.
73472 ELSEIF(MLIST.EQ.13) THEN
73473 WRITE(MSTU(11),8000)
73475 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
73479 C...Format statements for output on unit MSTU(11) (by default 6).
73480 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
73481 &5X,'KF orig p_x p_y p_z E m'/)
73482 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
73483 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73484 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
73485 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
73486 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73487 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
73488 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
73489 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
73490 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
73491 & ,' C tag AC tag'/)
73492 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
73493 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
73494 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
73495 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
73496 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
73497 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
73498 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
73499 6200 FORMAT(66X,5(1X,F12.3))
73500 6300 FORMAT(1X,78('='))
73501 6400 FORMAT(1X,130('='))
73502 6500 FORMAT(1X,65('='))
73503 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
73504 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
73505 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
73506 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
73508 7000 FORMAT(19X,'sum charge:',F6.2)
73509 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
73510 &//' I IST ID Mothers Daughters p_x p_y p_z',
73512 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
73513 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
73514 &//' I IST ID Mothers Colours p_x p_y p_z',
73516 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
73517 7500 FORMAT(///20X,'List of KF codes in program'/)
73518 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
73519 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
73520 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
73521 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
73522 &1X,'ME',3X,'Br.rat.',4X,'decay products')
73523 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
73524 &1X,1P,E13.5,3X,I2)
73525 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
73526 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
73527 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
73528 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
73533 C*********************************************************************
73536 C...Writes a logo for the program.
73540 C...Double precision and integer declarations.
73541 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73542 IMPLICIT INTEGER(I-N)
73543 INTEGER PYK,PYCHGE,PYCOMP
73544 C...Parameter for length of information block.
73545 PARAMETER (IREFER=21)
73547 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73548 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
73549 SAVE /PYDAT1/,/PYPARS/
73550 C...Local arrays and character variables.
73552 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
73553 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
73555 C...Data on months, logo, titles, and references.
73556 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
73557 &'Oct','Nov','Dec'/
73558 DATA (LOGO(J),J=1,19)/
73560 &' *:::!!:::::::::::* ',
73561 &' *::::::!!::::::::::::::* ',
73562 &' *::::::::!!::::::::::::::::* ',
73563 &' *:::::::::!!:::::::::::::::::* ',
73564 &' *:::::::::!!:::::::::::::::::* ',
73565 &' *::::::::!!::::::::::::::::*! ',
73566 &' *::::::!!::::::::::::::* !! ',
73567 &' !! *:::!!:::::::::::* !! ',
73568 &' !! !* -><- * !! ',
73578 DATA (LOGO(J),J=20,38)/
73579 &'Welcome to the Lund Monte Carlo!',
73581 &'PPP Y Y TTTTT H H III A ',
73582 &'P P Y Y T H H I A A ',
73583 &'PPP Y T HHHHH I AAAAA',
73584 &'P Y T H H I A A',
73585 &'P Y T H H III A A',
73587 &'This is PYTHIA version x.xxx ',
73588 &'Last date of change: xx xxx 200x',
73590 &'Now is xx xxx 200x at xx:xx:xx ',
73592 &'Disclaimer: this program comes ',
73593 &'without any guarantees. Beware ',
73594 &'of errors and use common sense ',
73595 &'when interpreting results. ',
73597 &'Copyright T. Sjostrand (2008) '/
73598 DATA (REFER(J),J=1,14)/
73599 &'An archive of program versions and d',
73600 &'ocumentation is found on the web: ',
73601 &'http://www.thep.lu.se/~torbjorn/Pyth',
73605 &'When you cite this program, the offi',
73606 &'cial reference is to the 6.4 manual:',
73607 &'T. Sjostrand, S. Mrenna and P. Skand',
73608 &'s, JHEP05 (2006) 026 ',
73609 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
73610 &'-T) [hep-ph/0603175]. ',
73613 DATA (REFER(J),J=15,32)/
73614 &'Also remember that the program, to a',
73615 &' large extent, represents original ',
73616 &'physics research. Other publications',
73617 &' of special relevance to your ',
73618 &'studies may therefore deserve separa',
73622 &'Main author: Torbjorn Sjostrand; Dep',
73623 &'artment of Theoretical Physics, ',
73624 &' Lund University, Solvegatan 14A, S',
73625 &'-223 62 Lund, Sweden; ',
73626 &' phone: + 46 - 46 - 222 48 16; e-ma',
73627 &'il: torbjorn@thep.lu.se ',
73628 &'Author: Stephen Mrenna; Computing Di',
73629 &'vision, GDS Group, ',
73630 &' Fermi National Accelerator Laborat',
73631 &'ory, MS 234, Batavia, IL 60510, USA;'/
73632 DATA (REFER(J),J=33,2*IREFER)/
73633 &' phone: + 1 - 630 - 840 - 2556; e-m',
73634 &'ail: mrenna@fnal.gov ',
73635 &'Author: Peter Skands; Theoretical Ph',
73636 &'ysics Department, ',
73637 &' Fermi National Accelerator Laborat',
73638 &'ory, MS 106, Batavia, IL 60510, USA;',
73639 &' and CERN/PH, CH-1211 Geneva, Switz',
73641 &' phone: + 41 - 22 - 767 24 59; e-ma',
73642 &'il: skands@fnal.gov '/
73644 C...Check that PYDATA linked.
73645 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
73647 & 'Error: PYDATA has not been linked.'
73648 WRITE(*,'(1X,A)') 'Execution stopped!'
73651 C...Write current version number and current date+time.
73653 WRITE(VERS,'(I1)') MSTP(181)
73654 LOGO(28)(24:24)=VERS
73655 WRITE(SUBV,'(I3)') MSTP(182)
73656 LOGO(28)(26:28)=SUBV
73657 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
73658 WRITE(DATE,'(I2)') MSTP(185)
73659 LOGO(29)(22:23)=DATE
73660 LOGO(29)(25:27)=MONTH(MSTP(184))
73661 WRITE(YEAR,'(I4)') MSTP(183)
73662 LOGO(29)(29:32)=YEAR
73664 IF(IDATI(1).LE.0) THEN
73667 WRITE(DATE,'(I2)') IDATI(3)
73669 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
73670 WRITE(YEAR,'(I4)') IDATI(1)
73671 LOGO(31)(15:18)=YEAR
73672 WRITE(HOUR,'(I2)') IDATI(4)
73673 LOGO(31)(23:24)=HOUR
73674 WRITE(MINU,'(I2)') IDATI(5)
73675 LOGO(31)(26:27)=MINU
73676 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
73677 WRITE(SECO,'(I2)') IDATI(6)
73678 LOGO(31)(29:30)=SECO
73679 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
73683 C...Loop over lines in header. Define page feed and side borders.
73684 DO 100 ILIN=1,29+IREFER
73693 C...Separator lines and logos.
73694 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
73695 LINE(4:77)='***********************************************'//
73696 & '***************************'
73697 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
73698 LINE(6:37)=LOGO(ILIN-5)
73699 LINE(44:75)=LOGO(ILIN+14)
73700 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
73701 LINE(5:40)=REFER(2*ILIN-51)
73702 LINE(41:76)=REFER(2*ILIN-50)
73705 C...Write lines to appropriate unit.
73706 WRITE(MSTU(11),'(A79)') LINE
73712 C*********************************************************************
73715 C...Facilitates the updating of particle and decay data
73716 C...by allowing it to be done in an external file.
73718 SUBROUTINE PYUPDA(MUPDA,LFN)
73720 C...Double precision and integer declarations.
73721 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73722 IMPLICIT INTEGER(I-N)
73723 INTEGER PYK,PYCHGE,PYCOMP
73725 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73726 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73727 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
73728 COMMON/PYDAT4/CHAF(500,2)
73730 COMMON/PYINT4/MWID(500),WIDS(500,5)
73731 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
73732 C...Local arrays, character variables and data.
73733 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
73734 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
73735 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
73736 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
73737 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
73738 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
73739 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
73741 C...Write header if not yet done.
73742 IF(MSTU(12).NE.12345) CALL PYLIST(0)
73744 C...Write information on file for editing.
73745 IF(MUPDA.EQ.1) THEN
73747 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
73748 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
73749 & MWID(KC),MDCY(KC,1)
73750 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73751 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
73752 & (KFDP(IDC,J),J=1,5)
73756 C...Read complete set of information from edited file or
73757 C...read partial set of new or updated information from edited file.
73758 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
73760 C...Reset counters.
73764 IF(MUPDA.EQ.2) THEN
73769 DO 130 KC=1,MSTU(6)
73770 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
73771 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
73775 C...Begin of loop: read new line; unknown whether particle or
73777 140 READ(LFN,5200,END=190) CHINL
73779 C...Identify particle code and whether already defined (for MUPDA=3).
73780 IF(CHINL(2:10).NE.' ') THEN
73783 IF(MUPDA.EQ.2) THEN
73796 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
73799 C...Remove duplicate old decay data.
73800 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
73801 IDCREP=MDCY(KCREP,2)
73802 NDCREP=MDCY(KCREP,3)
73804 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
73806 DO 180 I=IDCREP,NDC-NDCREP
73807 MDME(I,1)=MDME(I+NDCREP,1)
73808 MDME(I,2)=MDME(I+NDCREP,2)
73809 BRAT(I)=BRAT(I+NDCREP)
73811 KFDP(I,J)=KFDP(I+NDCREP,J)
73816 ELSEIF(KCREP.NE.0) THEN
73824 C...Study line with particle data.
73825 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
73826 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
73827 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
73828 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
73829 & MWID(KC),MDCY(KC,1)
73833 C...Study line with decay data.
73836 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
73837 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
73838 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
73839 MDCY(KC,3)=MDCY(KC,3)+1
73840 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
73841 & (KFDP(NDC,J),J=1,5)
73844 C...End of loop; ensure that PYCOMP tables are updated.
73849 C...Perform possible tests that new information is consistent.
73850 DO 220 KC=1,MSTU(6)
73852 IF(KF.EQ.0) GOTO 220
73853 WRITE(CHKF,5300) KF
73854 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
73855 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
73856 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
73858 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73859 IF(MDME(IDC,2).GT.80) GOTO 210
73861 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
73865 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
73867 ELSEIF(PYCOMP(KP).EQ.0) THEN
73872 PMS=PMS-PMAS(KPC,1)
73873 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
73877 IF(KQ.NE.0) MERR=MAX(2,MERR)
73878 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
73880 IF(MERR.EQ.3) CALL PYERRM(17,
73881 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
73882 IF(MERR.EQ.2) CALL PYERRM(17,
73883 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
73884 IF(MERR.EQ.1) CALL PYERRM(7,
73885 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
73886 BRSUM=BRSUM+BRAT(IDC)
73888 WRITE(CHTMP,5500) BRSUM
73889 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
73890 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
73891 & CHTMP(9:16)//' for KF ='//CHKF)
73894 C...Write DATA statements for inclusion in program.
73895 ELSEIF(MUPDA.EQ.4) THEN
73897 C...Find out how many codes and decay channels are actually used.
73901 IF(KCHG(I,4).NE.0) THEN
73903 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
73907 C...Initialize writing of DATA statements for inclusion in program.
73910 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
73913 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
73917 C...Loop through variables for conversion to characters.
73919 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
73920 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
73921 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
73922 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
73923 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
73924 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
73925 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
73926 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
73927 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
73928 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
73929 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
73930 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
73931 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
73932 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
73933 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
73934 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
73935 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
73936 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
73937 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
73938 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
73939 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
73940 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
73942 C...Replace variables beyond what is properly defined.
73944 IF(IDIM.GT.KCC) CHTMP=' 0'
73945 ELSEIF(IVAR.LE.8) THEN
73946 IF(IDIM.GT.KCC) CHTMP=' 0.0'
73947 ELSEIF(IVAR.LE.11) THEN
73948 IF(IDIM.GT.KCC) CHTMP=' 0'
73949 ELSEIF(IVAR.LE.13) THEN
73950 IF(IDIM.GT.NDC) CHTMP=' 0'
73951 ELSEIF(IVAR.LE.14) THEN
73952 IF(IDIM.GT.NDC) CHTMP=' 0.0'
73953 ELSEIF(IVAR.LE.19) THEN
73954 IF(IDIM.GT.NDC) CHTMP=' 0'
73955 ELSEIF(IVAR.LE.21) THEN
73956 IF(IDIM.GT.KCC) CHTMP=' '
73958 IF(IDIM.GT.KCC) CHTMP=' 0'
73961 C...Length of variable, trailing decimal zeros, quotation marks.
73965 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
73966 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
73968 CHNEW=CHTMP(LLOW:LHIG)//' '
73970 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
73973 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
73974 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
73979 CHNEW(LNEW+1:LNEW+2)='D0'
73982 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
73983 DO 260 LL=LNEW,1,-1
73984 IF(CHNEW(LL:LL).EQ.'''') THEN
73986 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
73992 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
73996 C...Form composite character string, often including repetition counter.
73997 IF(CHNEW.NE.CHOLD) THEN
74004 IF(NRPT.GE.2) LRPT=LNEW+3
74005 IF(NRPT.GE.10) LRPT=LNEW+4
74006 IF(NRPT.GE.100) LRPT=LNEW+5
74007 IF(NRPT.GE.1000) LRPT=LNEW+6
74010 WRITE(CHTMP,5400) NRPT
74012 IF(NRPT.GE.10) LRPT=2
74013 IF(NRPT.GE.100) LRPT=3
74014 IF(NRPT.GE.1000) LRPT=4
74015 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
74019 C...Add characters to end of line, to new line (after storing old line),
74020 C...or to new block of lines (after writing old block).
74021 IF(LLIN+LCOM.LE.70) THEN
74022 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
74024 ELSEIF(NLIN.LE.19) THEN
74025 CHLIN(LLIN+1:72)=' '
74028 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
74031 CHLIN(LLIN:72)='/'//' '
74033 WRITE(CHTMP,5400) IDIM-NRPT
74034 CHBLK(1)(30:33)=CHTMP(13:16)
74036 WRITE(LFN,5700) CHBLK(ILIN)
74040 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
74041 & ',I= , )/'//CHCOM(1:LCOM)//','
74042 WRITE(CHTMP,5400) IDIM-NRPT+1
74043 CHLIN(25:28)=CHTMP(13:16)
74048 C...Write final block of lines.
74049 CHLIN(LLIN:72)='/'//' '
74051 WRITE(CHTMP,5400) NDIM
74052 CHBLK(1)(30:33)=CHTMP(13:16)
74054 WRITE(LFN,5700) CHBLK(ILIN)
74059 C...Formats for reading and writing particle data.
74060 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
74061 5100 FORMAT(10X,2I5,F12.6,5I10)
74072 C*********************************************************************
74075 C...Provides various integer-valued event related data.
74079 C...Double precision and integer declarations.
74080 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74081 IMPLICIT INTEGER(I-N)
74082 INTEGER PYK,PYCHGE,PYCOMP
74084 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74085 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74086 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74087 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74089 C...Default value. For I=0 number of entries, number of stable entries
74090 C...or 3 times total charge.
74092 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
74093 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
74095 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
74097 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
74098 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
74101 ELSEIF(I.EQ.0) THEN
74103 C...For I > 0 direct readout of K matrix or charge.
74104 ELSEIF(J.LE.5) THEN
74106 ELSEIF(J.EQ.6) THEN
74109 C...Status (existing/fragmented/decayed), parton/hadron separation.
74110 ELSEIF(J.LE.8) THEN
74111 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
74112 IF(J.EQ.8) PYK=PYK*K(I,2)
74113 ELSEIF(J.LE.12) THEN
74117 IF(KC.NE.0) KQ=KCHG(KC,2)
74118 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
74119 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
74121 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
74123 C...Heaviest flavour in hadron/diquark.
74124 ELSEIF(J.EQ.13) THEN
74126 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
74127 IF(KFA.LT.10) PYK=KFA
74128 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
74129 PYK=PYK*ISIGN(1,K(I,2))
74131 C...Particle history: generation, ancestor, rank.
74132 ELSEIF(J.LE.15) THEN
74139 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
74142 ELSEIF(J.EQ.16) THEN
74144 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
74145 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
74152 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
74153 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
74155 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
74156 IF(ILP.EQ.1) GOTO 120
74158 IF(K(I1,1).EQ.12) THEN
74160 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
74161 & .AND.K(I3,2).NE.93) PYK=PYK+1
74167 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
74171 C...Particle coming from collapsing jet system or not.
74172 ELSEIF(J.EQ.17) THEN
74179 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
74180 IF(PYK.EQ.1) PYK=-1
74184 IF(KCHG(KC,2).EQ.0) GOTO 150
74185 IF(K(I1,1).NE.12) PYK=0
74186 IF(K(I1,1).NE.12) RETURN
74189 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
74191 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
74193 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
74195 C...Number of decay products. Colour flow.
74196 ELSEIF(J.EQ.18) THEN
74197 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
74198 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
74199 ELSEIF(J.LE.22) THEN
74200 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
74201 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
74202 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
74203 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
74204 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
74211 C*********************************************************************
74214 C...Provides various real-valued event related data.
74218 C...Double precision and integer declarations.
74219 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74220 IMPLICIT INTEGER(I-N)
74221 INTEGER PYK,PYCHGE,PYCOMP
74223 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74224 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74225 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74226 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74230 C...Set default value. For I = 0 sum of momenta or charges,
74231 C...or invariant mass of system.
74233 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
74234 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
74236 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
74238 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
74242 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
74246 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
74247 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
74249 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
74251 ELSEIF(I.EQ.0) THEN
74253 C...Direct readout of P matrix.
74254 ELSEIF(J.LE.5) THEN
74257 C...Charge, total momentum, transverse momentum, transverse mass.
74258 ELSEIF(J.LE.12) THEN
74259 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
74260 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
74261 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
74262 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
74263 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
74265 C...Theta and phi angle in radians or degrees.
74266 ELSEIF(J.LE.16) THEN
74267 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
74268 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
74269 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
74271 C...True rapidity, rapidity with pion mass, pseudorapidity.
74272 ELSEIF(J.LE.19) THEN
74274 IF(J.EQ.17) PMR=P(I,5)
74275 IF(J.EQ.18) PMR=PYMASS(211)
74276 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
74277 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
74280 C...Energy and momentum fractions (only to be used in CM frame).
74281 ELSEIF(J.LE.25) THEN
74282 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
74283 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
74284 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
74285 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
74286 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
74287 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
74293 C*********************************************************************
74296 C...Performs sphericity tensor analysis to give sphericity,
74297 C...aplanarity and the related event axes.
74299 SUBROUTINE PYSPHE(SPH,APL)
74301 C...Double precision and integer declarations.
74302 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74303 IMPLICIT INTEGER(I-N)
74304 INTEGER PYK,PYCHGE,PYCOMP
74305 C...Parameter statement to help give large particle numbers.
74306 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74307 &KEXCIT=4000000,KDIMEN=5000000)
74309 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74310 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74311 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74312 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74314 DIMENSION SM(3,3),SV(3,3)
74316 C...Calculate matrix to be diagonalized.
74325 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
74326 IF(MSTU(41).GE.2) THEN
74328 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74329 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74330 & K(I,2).EQ.KSUSY1+39) GOTO 140
74331 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74335 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74337 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
74338 & MAX(1D-10,PA)**(PARU(41)-2D0)
74341 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
74347 C...Very low multiplicities (0 or 1) not considered.
74349 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
74356 SM(J1,J2)=SM(J1,J2)/PS
74360 C...Find eigenvalues to matrix (third degree equation).
74361 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
74362 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
74363 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
74364 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
74365 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
74366 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
74367 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
74368 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
74369 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
74370 IF(P(N+2,4).LT.1D-5) THEN
74371 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
74377 C...Find first and last eigenvector by solving equation system.
74380 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
74382 SV(J1,J2)=SM(J1,J2)
74383 SV(J2,J1)=SM(J1,J2)
74389 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
74392 SMAX=ABS(SV(J1,J2))
74396 DO 220 J3=JA+1,JA+2
74398 RL=SV(J1,JB)/SV(JA,JB)
74400 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
74401 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
74403 SMAX=ABS(SV(J1,J2))
74407 JB2=JB+2-3*((JB+1)/3)
74408 P(N+I,JB1)=-SV(JC,JB2)
74409 P(N+I,JB2)=SV(JC,JB1)
74410 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
74412 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
74413 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74415 P(N+I,J)=SGN*P(N+I,J)/PA
74419 C...Middle axis orthogonal to other two. Fill other codes.
74420 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74421 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
74422 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
74423 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
74436 C...Calculate sphericity and aplanarity. Select storing option.
74437 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
74441 IF(MSTU(43).LE.1) MSTU(3)=3
74442 IF(MSTU(43).GE.2) N=N+3
74447 C*********************************************************************
74450 C...Performs thrust analysis to give thrust, oblateness
74451 C...and the related event axes.
74453 SUBROUTINE PYTHRU(THR,OBL)
74455 C...Double precision and integer declarations.
74456 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74457 IMPLICIT INTEGER(I-N)
74458 INTEGER PYK,PYCHGE,PYCOMP
74459 C...Parameter statement to help give large particle numbers.
74460 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74461 &KEXCIT=4000000,KDIMEN=5000000)
74463 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74464 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74465 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74466 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74468 DIMENSION TDI(3),TPR(3)
74470 C...Take copy of particles that are to be considered in thrust analysis.
74474 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
74475 IF(MSTU(41).GE.2) THEN
74477 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74478 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74479 & K(I,2).EQ.KSUSY1+39) GOTO 100
74480 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74483 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
74484 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
74494 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74496 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
74497 & P(N+NP,4)**(PARU(42)-1D0)
74498 PS=PS+P(N+NP,4)*P(N+NP,5)
74501 C...Very low multiplicities (0 or 1) not considered.
74503 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
74509 C...Loop over thrust and major. T axis along z direction in latter case.
74513 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
74515 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
74516 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
74517 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
74520 C...Find and order particles with highest p (pT for major).
74521 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
74525 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
74526 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
74527 IF(P(I,4).LE.P(ILF,4)) GOTO 140
74529 P(ILF+1,J)=P(ILF,J)
74538 C...Find and order initial axes with highest thrust (major).
74539 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
74542 NC=2**(MIN(MSTU(44),NP)-1)
74547 DO 200 ILF=1,MIN(MSTU(44),NP)
74548 SGN=P(N+NP+ILF+3,5)
74549 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
74551 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
74554 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
74555 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
74556 IF(TDS.LE.P(ILG,4)) GOTO 230
74558 P(ILG+1,J)=P(ILG,J)
74561 ILG=N+NP+MSTU(44)+4
74568 C...Iterate direction of axis until stable maximum.
74575 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
74576 IF(THP.GT.1D-10) TDI(J)=TPR(J)
74580 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
74582 TPR(J)=TPR(J)+SGN*P(I,J)
74585 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
74586 IF(THP.GE.THPS+PARU(48)) GOTO 270
74588 C...Save good axis. Try new initial axis until a number of tries agree.
74589 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
74590 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
74592 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74594 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
74600 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
74603 C...Find minor axis and value by orthogonality.
74604 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74605 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
74606 P(N+NP+3,2)=SGN*P(N+NP+2,1)
74610 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
74615 C...Fill axis information. Rotate back to original coordinate system.
74623 P(N+ILD,J)=P(N+NP+ILD,J)
74627 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
74629 C...Calculate thrust and oblateness. Select storing option.
74631 OBL=P(N+2,4)-P(N+3,4)
74634 IF(MSTU(43).LE.1) MSTU(3)=3
74635 IF(MSTU(43).GE.2) N=N+3
74640 C*********************************************************************
74643 C...Subdivides the particle content of an event into jets/clusters.
74645 SUBROUTINE PYCLUS(NJET)
74647 C...Double precision and integer declarations.
74648 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74649 IMPLICIT INTEGER(I-N)
74650 INTEGER PYK,PYCHGE,PYCOMP
74651 C...Parameter statement to help give large particle numbers.
74652 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74653 &KEXCIT=4000000,KDIMEN=5000000)
74655 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74656 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74657 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74658 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74659 C...Local arrays and saved variables.
74661 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
74663 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
74664 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
74665 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
74666 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
74667 &P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
74668 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
74669 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
74671 C...If first time, reset. If reentering, skip preliminaries.
74672 IF(MSTU(48).LE.0) THEN
74678 PIMASS=PMAS(PYCOMP(211),1)
74681 IF(MSTU(43).GE.2) N=N-NJET
74682 DO 110 I=N+1,N+NJET
74683 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74685 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
74688 R2ACC=PARU(45)*PS(5)**2
74694 C...Find which particles are to be considered in cluster search.
74696 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
74697 IF(MSTU(41).GE.2) THEN
74699 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74700 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74701 & K(I,2).EQ.KSUSY1+39) GOTO 140
74702 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74705 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
74706 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
74711 C...Take copy of these particles, with space left for jets later on.
74717 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
74718 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
74719 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
74720 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74722 PS(J)=PS(J)+P(N+NP,J)
74732 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
74734 C...Very low multiplicities not considered.
74735 IF(NP.LT.MSTU(47)) THEN
74736 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
74741 C...Find precluster configuration. If too few jets, make harder cuts.
74743 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
74746 R2ACC=PARU(45)*PS(5)**2
74748 RINIT=1.25D0*PARU(43)
74749 IF(NP.LE.MSTU(47)+2) RINIT=0D0
74750 170 RINIT=0.8D0*RINIT
74753 DO 180 I=N+NP+1,N+2*NP
74757 C...Sum up small momentum region. Jet if enough absolute momentum.
74758 IF(MSTU(46).LE.2) THEN
74762 DO 210 I=N+NP+1,N+2*NP
74763 IF(P(I,5).GT.2D0*RINIT) GOTO 210
74767 P(N+1,J)=P(N+1,J)+P(I,J)
74770 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
74771 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
74772 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
74773 IF(NREM.EQ.0) GOTO 170
74776 C...Find fastest remaining particle.
74779 DO 230 I=N+NP+1,N+2*NP
74780 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
74785 P(N+NPRE,J)=P(IMAX,J)
74790 C...Sum up precluster around it according to pT separation.
74791 IF(MSTU(46).LE.2) THEN
74792 DO 260 I=N+NP+1,N+2*NP
74793 IF(K(I,4).NE.0) GOTO 260
74795 IF(R2.GT.RINIT**2) GOTO 260
74799 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
74802 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
74804 C...Sum up precluster around it according to mass or
74805 C...Durham pT separation.
74809 DO 280 I=N+NP+1,N+2*NP
74810 IF(K(I,4).NE.0) GOTO 280
74811 IF(MSTU(46).LE.4) THEN
74816 IF(R2.GE.R2MIN) GOTO 280
74822 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
74824 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
74831 C...Check if more preclusters to be found. Start over if too few.
74832 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
74833 IF(NREM.GT.0) GOTO 220
74836 C...Reassign all particles to nearest jet. Sum up new jet momenta.
74839 310 IF(MSTU(46).LE.1) THEN
74840 DO 330 I=N+1,N+NJET
74845 DO 360 I=N+NP+1,N+2*NP
74847 DO 340 IJET=N+1,N+NJET
74848 IF(P(IJET,5).LT.RINIT) GOTO 340
74850 IF(R2.GE.R2MIN) GOTO 340
74856 V(IMIN,J)=V(IMIN,J)+P(I,J)
74860 DO 380 I=N+1,N+NJET
74864 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74869 C...Find two closest jets.
74870 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
74871 DO 400 ITRY1=N+1,N+NJET-1
74872 DO 390 ITRY2=ITRY1+1,N+NJET
74873 IF(MSTU(46).LE.2) THEN
74874 R2=R2T(ITRY1,ITRY2)
74875 ELSEIF(MSTU(46).LE.4) THEN
74876 R2=R2M(ITRY1,ITRY2)
74878 R2=R2D(ITRY1,ITRY2)
74880 IF(R2.GE.R2MIN) GOTO 390
74887 C...If allowed, join two closest jets and start over.
74888 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
74889 IREC=MIN(IMIN1,IMIN2)
74890 IDEL=MAX(IMIN1,IMIN2)
74892 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
74894 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
74895 DO 430 I=IDEL+1,N+NJET
74900 IF(MSTU(46).GE.2) THEN
74901 DO 440 I=N+NP+1,N+2*NP
74903 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
74904 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
74910 C...Divide up broad jet if empty cluster in list of final ones.
74911 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
74912 DO 450 I=N+1,N+NJET
74915 DO 460 I=N+NP+1,N+2*NP
74916 K(N+K(I,4),5)=K(N+K(I,4),5)+1
74919 DO 470 I=N+1,N+NJET
74920 IF(K(I,5).EQ.0) IEMP=I
74926 DO 480 I=N+NP+1,N+2*NP
74927 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
74930 IF(R2.LE.R2MAX) GOTO 480
74937 P(IEMP,J)=P(ISPL,J)
74938 P(IJET,J)=P(IJET,J)-P(ISPL,J)
74940 P(IEMP,5)=P(ISPL,5)
74941 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
74942 IF(NLOOP.LE.2) GOTO 300
74947 C...If generalized thrust has not yet converged, continue iteration.
74948 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
74954 C...Reorder jets according to energy.
74955 DO 510 I=N+1,N+NJET
74960 DO 540 INEW=N+1,N+NJET
74962 DO 520 ITRY=N+1,N+NJET
74963 IF(V(ITRY,4).LE.PEMAX) GOTO 520
74972 P(INEW,J)=V(IMAX,J)
74978 C...Clean up particle-jet assignments and jet information.
74979 DO 550 I=N+NP+1,N+2*NP
74982 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
74983 K(IORI,4)=K(IORI,4)+1
74987 DO 570 I=N+1,N+NJET
74990 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
74994 IF(K(I,4).EQ.0) IEMP=I
74997 C...Select storing option. Output variables. Check for failure.
75003 PARU(63)=SQRT(R2MIN)
75004 IF(NJET.LE.1) PARU(63)=0D0
75006 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
75010 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
75011 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
75017 C*********************************************************************
75020 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
75021 C...as used for calorimeters at hadron colliders.
75023 SUBROUTINE PYCELL(NJET)
75025 C...Double precision and integer declarations.
75026 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75027 IMPLICIT INTEGER(I-N)
75028 INTEGER PYK,PYCHGE,PYCOMP
75029 C...Parameter statement to help give large particle numbers.
75030 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75031 &KEXCIT=4000000,KDIMEN=5000000)
75033 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75034 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75035 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75036 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75038 C...Loop over all particles. Find cell that was hit by given particle.
75039 PTLRAT=1D0/SINH(PARU(51))**2
75043 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
75044 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
75045 IF(MSTU(41).GE.2) THEN
75047 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75048 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75049 & K(I,2).EQ.KSUSY1+39) GOTO 110
75050 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75054 PT=SQRT(P(I,1)**2+P(I,2)**2)
75055 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
75056 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
75057 & (ETA/PARU(51)+1D0))))
75058 PHI=PYANGL(P(I,1),P(I,2))
75059 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
75060 & (PHI/PARU(1)+1D0))))
75061 IETPH=MSTU(52)*IETA+IPHI
75063 C...Add to cell already hit, or book new cell.
75065 IF(IETPH.EQ.K(IC,3)) THEN
75071 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
75072 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
75080 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
75081 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
75085 C...Smear true bin content by calorimeter resolution.
75086 IF(MSTU(53).GE.1) THEN
75089 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
75090 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
75091 & COS(PARU(2)*PYR(0))
75092 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
75094 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
75098 C...Remove cells below threshold.
75099 IF(PARU(58).GT.0D0) THEN
75103 IF(P(IC,5).GT.PARU(58)) THEN
75115 C...Find initiator cell: the one with highest pT of not yet used ones.
75119 IF(K(IC,5).NE.2) GOTO 160
75120 IF(P(IC,5).LE.ETMAX) GOTO 160
75126 IF(ETMAX.LT.PARU(52)) GOTO 220
75127 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
75128 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
75142 C...Sum up unused cells within required distance of initiator.
75144 IF(K(IC,5).EQ.0) GOTO 170
75145 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
75146 DPHIA=ABS(P(IC,2)-PHI)
75147 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
75149 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
75150 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
75152 K(NJ,4)=K(NJ,4)+K(IC,4)
75153 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
75154 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
75155 P(NJ,5)=P(NJ,5)+P(IC,5)
75158 C...Reject cluster below minimum ET, else accept.
75159 IF(P(NJ,5).LT.PARU(53)) THEN
75162 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
75164 ELSEIF(MSTU(54).LE.2) THEN
75165 P(NJ,3)=P(NJ,3)/P(NJ,5)
75166 P(NJ,4)=P(NJ,4)/P(NJ,5)
75167 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
75170 IF(K(IC,5).LT.0) K(IC,5)=0
75177 IF(K(IC,5).GE.0) GOTO 210
75178 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
75179 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
75180 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
75181 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
75187 C...Arrange clusters in falling ET sequence.
75188 220 DO 250 I=1,NJ-NC
75191 IF(K(IJ,5).EQ.0) GOTO 230
75192 IF(P(IJ,5).LT.ETMAX) GOTO 230
75200 K(N+I,4)=K(IJMAX,4)
75203 P(N+I,J)=P(IJMAX,J)
75209 C...Convert to massless or massive four-vectors.
75210 IF(MSTU(54).EQ.2) THEN
75211 DO 260 I=N+1,N+NJET
75213 P(I,1)=P(I,5)*COS(P(I,4))
75214 P(I,2)=P(I,5)*SIN(P(I,4))
75215 P(I,3)=P(I,5)*SINH(ETA)
75216 P(I,4)=P(I,5)*COSH(ETA)
75219 ELSEIF(MSTU(54).GE.3) THEN
75220 DO 270 I=N+1,N+NJET
75221 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
75225 C...Information about storage.
75229 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
75230 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
75235 C*********************************************************************
75238 C...Determines, approximately, the two jet masses that minimize
75239 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
75241 SUBROUTINE PYJMAS(PMH,PML)
75243 C...Double precision and integer declarations.
75244 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75245 IMPLICIT INTEGER(I-N)
75246 INTEGER PYK,PYCHGE,PYCOMP
75247 C...Parameter statement to help give large particle numbers.
75248 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75249 &KEXCIT=4000000,KDIMEN=5000000)
75251 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75252 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75253 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75254 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75256 DIMENSION SM(3,3),SAX(3),PS(3,5)
75269 PIMASS=PMAS(PYCOMP(211),1)
75271 C...Take copy of particles that are to be considered in mass analysis.
75273 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
75274 IF(MSTU(41).GE.2) THEN
75276 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75277 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75278 & K(I,2).EQ.KSUSY1+39) GOTO 170
75279 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75282 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
75283 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
75292 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
75293 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
75294 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
75296 C...Fill information in sphericity tensor and total momentum vector.
75299 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
75302 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
75304 PS(3,J)=PS(3,J)+P(N+NP,J)
75308 C...Very low multiplicities (0 or 1) not considered.
75310 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
75315 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
75318 C...Find largest eigenvalue to matrix (third degree equation).
75321 SM(J1,J2)=SM(J1,J2)/PSS
75324 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
75325 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
75326 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
75327 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
75328 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
75329 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
75330 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
75332 C...Find largest eigenvector by solving equation system.
75334 SM(J1,J1)=SM(J1,J1)-SMA
75336 SM(J2,J1)=SM(J1,J2)
75342 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
75345 SMAX=ABS(SM(J1,J2))
75349 DO 250 J3=JA+1,JA+2
75351 RL=SM(J1,JB)/SM(JA,JB)
75353 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
75354 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
75356 SMAX=ABS(SM(J1,J2))
75360 JB2=JB+2-3*((JB+1)/3)
75361 SAX(JB1)=-SM(JC,JB2)
75362 SAX(JB2)=SM(JC,JB1)
75363 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
75365 C...Divide particles into two initial clusters by hemisphere.
75367 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
75369 IF(PSAX.LT.0D0) IS=2
75372 PS(IS,J)=PS(IS,J)+P(I,J)
75375 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
75376 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
75378 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
75382 PS(3,J)=PS(1,J)-PS(2,J)
75385 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)
75386 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
75387 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
75388 IF(PMDI.LT.PMD) THEN
75394 C...Loop back if significant reduction in sum of m^2.
75395 IF(PMD.LT.-PARU(48)*PMS) THEN
75399 PS(IS,J)=PS(IS,J)-P(IM,J)
75400 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
75406 C...Final masses and output.
75409 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
75410 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
75411 PMH=MAX(PS(1,5),PS(2,5))
75412 PML=MIN(PS(1,5),PS(2,5))
75417 C*********************************************************************
75420 C...Calculates the first few Fox-Wolfram moments.
75422 SUBROUTINE PYFOWO(H10,H20,H30,H40)
75424 C...Double precision and integer declarations.
75425 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75426 IMPLICIT INTEGER(I-N)
75427 INTEGER PYK,PYCHGE,PYCOMP
75428 C...Parameter statement to help give large particle numbers.
75429 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75430 &KEXCIT=4000000,KDIMEN=5000000)
75432 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75433 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75434 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75435 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75437 C...Copy momenta for particles and calculate H0.
75442 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
75443 IF(MSTU(41).GE.2) THEN
75445 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75446 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75447 & K(I,2).EQ.KSUSY1+39) GOTO 110
75448 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75451 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
75452 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
75463 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
75469 C...Very low multiplicities (0 or 1) not considered.
75471 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
75479 C...Calculate H1 - H4.
75485 DO 120 I2=I1+1,N+NP
75486 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
75487 & (P(I1,4)*P(I2,4))
75488 H10=H10+P(I1,4)*P(I2,4)*CTHE
75489 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
75490 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
75491 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
75496 C...Calculate H1/H0 - H4/H0. Output.
75499 H10=(HD+2D0*H10)/H0
75500 H20=(HD+2D0*H20)/H0
75501 H30=(HD+2D0*H30)/H0
75502 H40=(HD+2D0*H40)/H0
75507 C*********************************************************************
75510 C...Evaluates various properties of an event, with statistics
75511 C...accumulated during the course of the run and
75512 C...printed at the end.
75514 SUBROUTINE PYTABU(MTABU)
75516 C...Double precision and integer declarations.
75517 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75518 IMPLICIT INTEGER(I-N)
75519 INTEGER PYK,PYCHGE,PYCOMP
75520 C...Parameter statement to help give large particle numbers.
75521 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75522 &KEXCIT=4000000,KDIMEN=5000000)
75524 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75525 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75526 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75527 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
75528 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
75529 C...Local arrays, character variables, saved variables and data.
75530 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
75531 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
75532 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
75533 &KFDM(8),KFDC(200,0:8),NPDC(200)
75534 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
75535 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
75536 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
75537 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
75538 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
75539 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
75540 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
75541 &NEVDC/0/,NKFDC/0/,NREDC/0/
75543 C...Reset statistics on initial parton state.
75544 IF(MTABU.EQ.10) THEN
75548 C...Identify and order flavour content of initial state.
75549 ELSEIF(MTABU.EQ.11) THEN
75551 KFM1=2*IABS(MSTU(161))
75552 IF(MSTU(161).GT.0) KFM1=KFM1-1
75553 KFM2=2*IABS(MSTU(162))
75554 IF(MSTU(162).GT.0) KFM2=KFM2-1
75555 KFMN=MIN(KFM1,KFM2)
75556 KFMX=MAX(KFM1,KFM2)
75558 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
75561 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
75562 & KFMX.LT.KFIS(I,2))) THEN
75568 110 IF(IKFIS.LT.0) THEN
75571 IF(NKFIS.GE.100) RETURN
75572 DO 130 I=NKFIS,IKFIS,-1
75573 KFIS(I+1,1)=KFIS(I,1)
75574 KFIS(I+1,2)=KFIS(I,2)
75576 NPIS(I+1,J)=NPIS(I,J)
75586 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
75588 C...Count number of partons in initial state.
75591 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
75592 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
75593 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
75598 IF(IM.LE.0.OR.IM.GT.N) THEN
75600 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
75602 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
75603 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
75613 IF(NP.GE.11) NPCO=8
75614 IF(NP.GE.16) NPCO=9
75615 IF(NP.GE.26) NPCO=10
75616 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
75619 C...Write statistics on initial parton state.
75620 ELSEIF(MTABU.EQ.12) THEN
75621 FAC=1D0/MAX(1,NEVIS)
75622 WRITE(MSTU(11),5000) NEVIS
75625 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
75627 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
75628 CALL PYNAME(KFM1,CHAU)
75630 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
75632 IF(KFIS(I,1).EQ.0) KFMX=0
75634 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
75635 CALL PYNAME(KFM2,CHAU)
75637 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
75638 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
75639 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
75642 C...Copy statistics on initial parton state into /PYJETS/.
75643 ELSEIF(MTABU.EQ.13) THEN
75644 FAC=1D0/MAX(1,NEVIS)
75647 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
75649 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
75651 IF(KFIS(I,1).EQ.0) KFMX=0
75653 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
75660 P(I,J)=FAC*NPIS(I,J)
75661 V(I,J)=FAC*NPIS(I,J+5)
75675 C...Reset statistics on number of particles/partons.
75676 ELSEIF(MTABU.EQ.20) THEN
75683 C...Identify whether particle/parton is primary or not.
75684 ELSEIF(MTABU.EQ.21) THEN
75688 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
75689 MSTU(62)=MSTU(62)+1
75692 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
75694 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
75696 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
75698 ELSEIF(KC.EQ.0) THEN
75699 ELSEIF(K(K(I,3),1).EQ.13) THEN
75701 IF(IM.LE.0.OR.IM.GT.N) THEN
75703 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
75706 ELSEIF(KCHG(KC,2).EQ.0) THEN
75707 KCM=PYCOMP(K(K(I,3),2))
75709 IF(KCHG(KCM,2).NE.0) MPRI=1
75712 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
75713 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
75715 IF(K(I,1).LE.10) THEN
75717 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
75720 C...Fill statistics on number of particles/partons in event.
75722 KFS=3-ISIGN(1,K(I,2))-MPRI
75724 IF(KFA.EQ.KFFS(IP)) THEN
75727 ELSEIF(KFA.LT.KFFS(IP)) THEN
75733 220 IF(IKFFS.LT.0) THEN
75736 IF(NKFFS.GE.400) RETURN
75737 DO 240 IP=NKFFS,IKFFS,-1
75738 KFFS(IP+1)=KFFS(IP)
75740 NPFS(IP+1,J)=NPFS(IP,J)
75749 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
75752 C...Write statistics on particle/parton composition of events.
75753 ELSEIF(MTABU.EQ.22) THEN
75754 FAC=1D0/MAX(1,NEVFS)
75755 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
75757 CALL PYNAME(KFFS(I),CHAU)
75760 IF(KC.NE.0) MDCYF=MDCY(KC,1)
75761 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
75762 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
75765 C...Copy particle/parton composition information into /PYJETS/.
75766 ELSEIF(MTABU.EQ.23) THEN
75767 FAC=1D0/MAX(1,NEVFS)
75773 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
75775 P(I,J)=FAC*NPFS(I,J)
75795 C...Reset factorial moments statistics.
75796 ELSEIF(MTABU.EQ.30) THEN
75802 FM1FM(IM,IB,IP)=0D0
75803 FM2FM(IM,IB,IP)=0D0
75808 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
75809 ELSEIF(MTABU.EQ.31) THEN
75814 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
75815 IF(MSTU(41).GE.2) THEN
75817 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75818 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75819 & K(I,2).EQ.KSUSY1+39) GOTO 410
75820 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
75821 & PYCHGE(K(I,2)).EQ.0) GOTO 410
75824 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
75825 IF(MSTU(42).GE.2) PMR=P(I,5)
75826 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
75827 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
75829 IF(ABS(YETA).GT.PARU(57)) GOTO 410
75830 PHI=PYANGL(P(I,1),P(I,2))
75831 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
75832 IYETA=MAX(0,MIN(511,IYETA))
75833 IPHI=512D0*(PHI+PARU(1))/PARU(2)
75834 IPHI=MAX(0,MIN(511,IPHI))
75837 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
75840 C...Order particles in (pseudo)rapidity and/or azimuth.
75841 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
75842 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
75846 IF(NUPP.EQ.NLOW+1) THEN
75851 DO 350 I1=NUPP-1,NLOW+1,-1
75852 IF(IYETA.GE.K(I1,1)) GOTO 360
75855 360 K(I1+1,1)=IYETA
75856 DO 370 I1=NUPP-1,NLOW+1,-1
75857 IF(IPHI.GE.K(I1,2)) GOTO 380
75861 DO 390 I1=NUPP-1,NLOW+1,-1
75862 IF(IYEP.GE.K(I1,3)) GOTO 400
75872 C...Calculate sum of factorial moments in event.
75880 IF(IM.LE.2) IBIN=2**(10-IB)
75881 IF(IM.EQ.3) IBIN=4**(10-IB)
75882 IAGR=K(NLOW+1,IM)/IBIN
75884 DO 440 I=NLOW+2,NUPP+1
75886 IF(ICUT.EQ.IAGR) THEN
75890 ELSEIF(NAGR.EQ.2) THEN
75891 FEVFM(IB,1)=FEVFM(IB,1)+2D0
75892 ELSEIF(NAGR.EQ.3) THEN
75893 FEVFM(IB,1)=FEVFM(IB,1)+6D0
75894 FEVFM(IB,2)=FEVFM(IB,2)+6D0
75895 ELSEIF(NAGR.EQ.4) THEN
75896 FEVFM(IB,1)=FEVFM(IB,1)+12D0
75897 FEVFM(IB,2)=FEVFM(IB,2)+24D0
75898 FEVFM(IB,3)=FEVFM(IB,3)+24D0
75900 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
75901 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
75902 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
75904 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
75905 & (NAGR-3D0)*(NAGR-4D0)
75913 C...Add results to total statistics.
75916 IF(FEVFM(1,IP).LT.0.5D0) THEN
75918 ELSEIF(IM.LE.2) THEN
75919 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
75921 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
75923 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
75924 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
75928 NMUFM=NMUFM+(NUPP-NLOW)
75931 C...Write accumulated statistics on factorial moments.
75932 ELSEIF(MTABU.EQ.32) THEN
75933 FAC=1D0/MAX(1,NEVFM)
75934 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
75935 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
75936 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
75938 WRITE(MSTU(11),5500)
75941 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
75943 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
75944 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
75945 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
75947 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
75948 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
75951 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
75956 C...Copy statistics on factorial moments into /PYJETS/.
75957 ELSEIF(MTABU.EQ.33) THEN
75958 FAC=1D0/MAX(1,NEVFM)
75965 IF(IM.NE.2) K(I,3)=2**(IB-1)
75967 IF(IM.NE.1) K(I,4)=2**(IB-1)
75969 P(I,1)=2D0*PARU(57)/K(I,3)
75970 V(I,1)=PARU(2)/K(I,4)
75972 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
75973 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
75989 C...Reset statistics on Energy-Energy Correlation.
75990 ELSEIF(MTABU.EQ.40) THEN
76001 C...Find particles to include, with proper assumed mass.
76002 ELSEIF(MTABU.EQ.41) THEN
76008 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
76009 IF(MSTU(41).GE.2) THEN
76011 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76012 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76013 & K(I,2).EQ.KSUSY1+39) GOTO 570
76014 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
76015 & PYCHGE(K(I,2)).EQ.0) GOTO 570
76018 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
76019 IF(MSTU(42).GE.2) PMR=P(I,5)
76020 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
76021 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
76028 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
76029 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
76032 IF(NUPP.EQ.NLOW) RETURN
76034 C...Analyze Energy-Energy Correlation in event.
76035 FAC=(2D0/ECM**2)*50D0/PARU(1)
76039 DO 600 I1=NLOW+2,NUPP
76040 DO 590 I2=NLOW+1,I1-1
76041 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
76042 & (P(I1,5)*P(I2,5))
76043 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
76044 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
76045 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
76049 FE1EC(J)=FE1EC(J)+FEVEE(J)
76050 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
76051 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
76052 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
76053 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
76054 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
76058 C...Write statistics on Energy-Energy Correlation.
76059 ELSEIF(MTABU.EQ.42) THEN
76060 FAC=1D0/MAX(1,NEVEE)
76061 WRITE(MSTU(11),5700) NEVEE
76064 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
76065 FEEC2=FAC*FE1EC(51-J)
76066 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
76068 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
76069 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
76070 & FEEC2,FEES2,FEECA,FEESA
76073 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
76074 ELSEIF(MTABU.EQ.43) THEN
76075 FAC=1D0/MAX(1,NEVEE)
76082 P(I,1)=FAC*FE1EC(I)
76083 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
76084 P(I,2)=FAC*FE1EC(51-I)
76085 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
76086 P(I,3)=FAC*FE1EA(I)
76087 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
76088 P(I,4)=PARU(1)*(I-1)/50D0
76089 P(I,5)=PARU(1)*I/50D0
76104 C...Reset statistics on decay channels.
76105 ELSEIF(MTABU.EQ.50) THEN
76110 C...Identify and order flavour content of final state.
76111 ELSEIF(MTABU.EQ.51) THEN
76115 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
76122 IF(K(I,2).LT.0) KFM=KFM-1
76123 DO 650 IDS=NDS-1,1,-1
76125 IF(KFM.LT.KFDM(IDS)) GOTO 660
76126 KFDM(IDS+1)=KFDM(IDS)
76132 C...Find whether old or new final state.
76134 IF(NDS.LT.KFDC(IDC,0)) THEN
76137 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
76139 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
76142 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
76151 700 IF(IKFDC.LT.0) THEN
76153 ELSEIF(NKFDC.GE.200) THEN
76157 DO 720 IDC=NKFDC,IKFDC,-1
76158 NPDC(IDC+1)=NPDC(IDC)
76160 KFDC(IDC+1,I)=KFDC(IDC,I)
76166 KFDC(IKFDC,I)=KFDM(I)
76170 NPDC(IKFDC)=NPDC(IKFDC)+1
76172 C...Write statistics on decay channels.
76173 ELSEIF(MTABU.EQ.52) THEN
76174 FAC=1D0/MAX(1,NEVDC)
76175 WRITE(MSTU(11),5900) NEVDC
76177 DO 740 I=1,KFDC(IDC,0)
76180 IF(2*KF.NE.KFM) KF=-KF
76181 CALL PYNAME(KF,CHAU)
76183 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
76185 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
76187 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
76189 C...Copy statistics on decay channels into /PYJETS/.
76190 ELSEIF(MTABU.EQ.53) THEN
76191 FAC=1D0/MAX(1,NEVDC)
76197 K(IDC,5)=KFDC(IDC,0)
76202 DO 770 I=1,KFDC(IDC,0)
76205 IF(2*KF.NE.KFM) KF=-KF
76206 IF(I.LE.5) P(IDC,I)=KF
76207 IF(I.GE.6) V(IDC,I-5)=KF
76209 V(IDC,5)=FAC*NPDC(IDC)
76224 C...Format statements for output on unit MSTU(11) (default 6).
76225 5000 FORMAT(///20X,'Event statistics - initial state'/
76226 &20X,'based on an analysis of ',I6,' events'//
76227 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
76228 &'according to fragmenting system multiplicity'/
76229 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
76230 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
76231 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
76232 5200 FORMAT(///20X,'Event statistics - final state'/
76233 &20X,'based on an analysis of ',I7,' events'//
76234 &5X,'Mean primary multiplicity =',F10.4/
76235 &5X,'Mean final multiplicity =',F10.4/
76236 &5X,'Mean charged multiplicity =',F10.4//
76237 &5X,'Number of particles produced per event (directly and via ',
76238 &'decays/branchings)'/
76239 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
76240 &8X,'Total'/35X,'prim seco prim seco'/)
76241 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
76242 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
76243 &20X,'based on an analysis of ',I6,' events'//
76244 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
76245 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
76247 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
76248 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
76249 &20X,'based on an analysis of ',I6,' events'//
76250 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
76251 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
76252 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
76253 5900 FORMAT(///20X,'Decay channel analysis - final state'/
76254 &20X,'based on an analysis of ',I6,' events'//
76255 &2X,'Probability',10X,'Complete final state'/)
76256 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
76257 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
76258 &'or table overflow)')
76263 C*********************************************************************
76266 C...Handles the generation of an e+e- annihilation jet event.
76268 SUBROUTINE PYEEVT(KFL,ECM)
76270 C...Double precision and integer declarations.
76271 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76272 IMPLICIT INTEGER(I-N)
76273 INTEGER PYK,PYCHGE,PYCOMP
76275 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76276 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76277 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76278 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76280 C...Check input parameters.
76281 IF(MSTU(12).NE.12345) CALL PYLIST(0)
76282 IF(KFL.LT.0.OR.KFL.GT.8) THEN
76283 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
76284 IF(MSTU(21).GE.1) RETURN
76286 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
76287 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
76288 IF(ECM.LT.ECMMIN) THEN
76289 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
76290 IF(MSTU(21).GE.1) RETURN
76293 C...Check consistency of MSTJ options set.
76294 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
76296 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
76299 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
76301 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
76305 C...Initialize alpha_strong and total cross-section.
76306 MSTU(111)=MSTJ(108)
76307 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
76309 PARU(112)=PARJ(121)
76310 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
76311 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
76312 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
76314 IF(MSTJ(116).GE.3) MSTJ(116)=1
76317 C...Add initial e+e- to event record (documentation only).
76320 IF(NTRY.GT.100) THEN
76321 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
76326 IF(MSTJ(115).GE.2) THEN
76328 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
76330 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
76334 C...Radiative photon (in initial state).
76337 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
76339 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
76340 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
76342 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
76343 K(NC,3)=MIN(MSTJ(115)/2,1)
76346 C...Virtual exchange boson (gamma or Z0).
76347 IF(MSTJ(115).GE.3) THEN
76350 IF(MSTJ(102).EQ.2) KF=23
76354 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
76360 C...Choice of flavour and jet configuration.
76361 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
76362 IF(KFLC.EQ.0) GOTO 100
76363 CALL PYXJET(ECMC,NJET,CUT)
76365 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
76367 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
76368 IF(NJET.EQ.2) MSTJ(120)=1
76370 C...Fill jet configuration and origin.
76371 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
76372 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
76374 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
76375 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
76376 &-KFLC,ECMC,X1,X2,X4,X12,X14)
76377 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
76378 &-KFLC,ECMC,X1,X2,X4,X12,X14)
76379 IF(MSTU(24).NE.0) GOTO 100
76381 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
76384 C...Angular orientation according to matrix element.
76385 IF(MSTJ(106).EQ.1) THEN
76386 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
76387 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
76388 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
76391 C...Rotation and boost from radiative photon.
76393 DBEK=-PAK/(ECM-PAK)
76394 NMIN=NC+1-MSTJ(115)/3
76395 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
76396 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
76397 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
76400 C...Generate parton shower. Rearrange along strings and check.
76401 IF(MSTJ(101).EQ.5) THEN
76402 CALL PYSHOW(N-1,N,ECMC)
76404 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
76405 IF(MSTJ(105).GE.0) MSTU(28)=0
76408 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
76411 C...Fragmentation/decay generation. Information for PYTABU.
76412 IF(MSTJ(105).EQ.1) CALL PYEXEC
76419 C*********************************************************************
76422 C...Calculates total cross-section, including initial state
76423 C...radiation effects.
76425 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
76427 C...Double precision and integer declarations.
76428 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76429 IMPLICIT INTEGER(I-N)
76430 INTEGER PYK,PYCHGE,PYCOMP
76432 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76433 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76434 SAVE /PYDAT1/,/PYDAT2/
76436 C...Status, (optimized) Q^2 scale, alpha_strong.
76438 MSTJ(119)=10*MSTJ(102)+KFL
76439 IF(MSTJ(111).EQ.0) THEN
76441 ELSEIF(MSTU(111).EQ.0) THEN
76442 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
76443 & ((33D0-2D0*MSTU(112))*PARU(111)))))
76444 Q2R=PARJ(168)*ECM**2
76446 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
76447 & (2D0*PARU(112)/ECM)**2))
76448 Q2R=PARJ(168)*ECM**2
76450 ALSPI=PYALPS(Q2R)/PARU(1)
76452 C...QCD corrections factor in R.
76453 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
76455 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
76457 ELSEIF(MSTJ(109).EQ.0) THEN
76458 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
76459 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
76460 & LOG(PARJ(168))*ALSPI**2)
76461 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
76462 RQCD=1D0+(3D0/4D0)*ALSPI
76464 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
76467 C...Calculate Z0 width if default value not acceptable.
76468 IF(MSTJ(102).GE.3) THEN
76469 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
76470 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
76473 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
76474 & (2D0*PYMASS(KFLC)/ ECM)**2))
76475 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
76476 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
76477 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
76479 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
76483 C...Calculate propagator and related constants for QFD case.
76484 POLL=1D0-PARJ(131)*PARJ(132)
76485 IF(MSTJ(102).GE.2) THEN
76486 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
76487 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
76488 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
76489 VE=4D0*PARU(102)-1D0
76490 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
76491 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
76496 C...Loop over different flavours: charge, velocity.
76501 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
76502 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
76505 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
76506 QF=KCHG(KFLC,1)/3D0
76508 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
76510 C...Calculate R and sum of charges for QED or QFD case.
76511 RQQ=RQQ+3D0*QF**2*POLL
76512 IF(MSTJ(102).LE.1) THEN
76513 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
76515 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
76516 RQV=RQV-6D0*QF*VF*SF1I
76517 RVA=RVA+3D0*(VF**2+1D0)*SF1W
76518 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
76519 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
76523 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
76525 C...Calculate cross-section, including QCD corrections.
76528 PARJ(143)=RTOT*RQCD
76529 PARJ(144)=PARJ(143)
76530 PARJ(145)=PARJ(141)*86.8D0/ECM**2
76531 PARJ(146)=PARJ(142)*86.8D0/ECM**2
76532 PARJ(147)=PARJ(143)*86.8D0/ECM**2
76533 PARJ(148)=PARJ(147)
76534 PARJ(157)=RSUM*RQCD
76538 IF(MSTJ(107).LE.0) RETURN
76540 C...Virtual cross-section.
76542 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
76543 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
76544 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
76545 &1.526D0*LOG(ECM**2/0.932D0)
76547 C...Soft and hard radiative cross-section in QED case.
76548 IF(MSTJ(102).LE.1) THEN
76549 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
76550 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
76551 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
76553 C...Soft and hard radiative cross-section in QFD case.
76555 SZM=1D0-(PARJ(123)/ECM)**2
76556 SZW=PARJ(123)*PARJ(124)/ECM**2
76557 PARJ(161)=-RQQ/RSUM
76558 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
76559 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
76560 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
76561 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
76562 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
76563 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
76564 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
76565 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
76566 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
76567 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
76568 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
76569 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
76570 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
76573 C...Total cross-section and fraction of hard photon events.
76574 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
76575 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
76576 PARJ(144)=PARJ(157)
76577 PARJ(148)=PARJ(144)*86.8D0/ECM**2
76583 C*********************************************************************
76586 C...Generates initial state photon radiation.
76588 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
76590 C...Double precision and integer declarations.
76591 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76592 IMPLICIT INTEGER(I-N)
76593 INTEGER PYK,PYCHGE,PYCOMP
76595 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76598 C...Function: cumulative hard photon spectrum in QFD case.
76599 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
76600 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
76602 C...Determine whether radiative photon or not.
76605 IF(PARJ(160).LT.PYR(0)) RETURN
76608 C...Photon energy range. Find photon momentum in QED case.
76610 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
76611 IF(MSTJ(102).LE.1) THEN
76612 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
76613 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
76615 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
76617 SZM=1D0-(PARJ(123)/ECM)**2
76618 SZW=PARJ(123)*PARJ(124)/ECM**2
76621 FXKD=1D-4*(FXKU-FXKL)
76622 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
76627 IF(FXKV.GT.FXKR) THEN
76634 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
76635 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
76639 C...Photon polar and azimuthal angle.
76640 PME=2D0*(PYMASS(11)/ECM)**2
76641 120 CTHM=PME*(2D0/PME)**PYR(0)
76642 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
76643 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
76645 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
76646 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
76647 THEK=PYANGL(CTHE,STHE)
76648 PHIK=PARU(2)*PYR(0)
76650 C...Rotation angle for hadronic system.
76652 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
76654 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
76655 &(2D0-XK*(1D0-SGN*CTHE)))
76660 C*********************************************************************
76663 C...Selects flavour for produced qqbar pair.
76665 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
76667 C...Double precision and integer declarations.
76668 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76669 IMPLICIT INTEGER(I-N)
76670 INTEGER PYK,PYCHGE,PYCOMP
76672 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76673 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76674 SAVE /PYDAT1/,/PYDAT2/
76676 C...Calculate maximum weight in QED or QFD case.
76677 IF(MSTJ(102).LE.1) THEN
76680 POLL=1D0-PARJ(131)*PARJ(132)
76681 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
76682 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
76683 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
76684 VE=4D0*PARU(102)-1D0
76685 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
76686 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
76687 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
76688 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
76689 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
76693 C...Choose flavour. Gives charge and velocity.
76696 IF(NTRY.GT.100) THEN
76697 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
76702 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
76705 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
76706 QF=KCHG(KFLC,1)/3D0
76708 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
76710 C...Calculate weight in QED or QFD case.
76711 IF(MSTJ(102).LE.1) THEN
76713 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
76715 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
76716 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
76717 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
76719 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
76722 C...Weighting or new event (radiative photon). Cross-section update.
76723 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
76724 PARJ(158)=PARJ(158)+1D0
76725 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
76726 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
76727 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
76728 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
76729 PARJ(148)=PARJ(144)*86.8D0/ECM**2
76734 C*********************************************************************
76737 C...Selects number of jets in matrix element approach.
76739 SUBROUTINE PYXJET(ECM,NJET,CUT)
76741 C...Double precision and integer declarations.
76742 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76743 IMPLICIT INTEGER(I-N)
76744 INTEGER PYK,PYCHGE,PYCOMP
76746 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76748 C...Local array and data.
76750 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
76752 C...Trivial result for two-jets only, including parton shower.
76753 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
76756 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
76757 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
76759 IF(MSTJ(109).EQ.2) CF=1D0
76760 IF(MSTJ(111).EQ.0) THEN
76763 ELSEIF(MSTU(111).EQ.0) THEN
76764 PARJ(169)=MIN(1D0,PARJ(129))
76765 Q2=PARJ(169)*ECM**2
76766 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
76767 & ((33D0-2D0*MSTU(112))*PARU(111)))))
76768 Q2R=PARJ(168)*ECM**2
76770 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
76771 Q2=PARJ(169)*ECM**2
76772 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
76773 & (2D0*PARU(112)/ECM)**2))
76774 Q2R=PARJ(168)*ECM**2
76777 C...alpha_strong for R and R itself.
76778 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
76779 IF(IABS(MSTJ(101)).EQ.1) THEN
76781 ELSEIF(MSTJ(109).EQ.0) THEN
76782 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
76783 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
76784 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
76786 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
76789 C...alpha_strong for jet rate. Initial value for y cut.
76790 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76791 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
76792 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
76793 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
76794 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
76796 C...Parametrization of first order three-jet cross-section.
76797 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
76800 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
76801 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
76802 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
76803 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
76804 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
76808 C...Parametrization of second order three-jet cross-section.
76809 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
76810 & CUT.GE.0.25D0) THEN
76812 ELSEIF(MSTJ(110).LE.1) THEN
76813 CT=LOG(1D0/CUT-2D0)
76814 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
76815 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
76817 C...Interpolation in second/first order ratio for Zhu parametrization.
76818 ELSEIF(MSTJ(110).EQ.2) THEN
76821 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
76827 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
76829 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
76832 C...Shift in second order three-jet cross-section with optimized Q^2.
76833 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
76834 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
76835 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
76837 C...Parametrization of second order four-jet cross-section.
76838 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
76841 CT=LOG(1D0/CUT-5D0)
76842 IF(CUT.LE.0.018D0) THEN
76843 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
76844 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
76846 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
76847 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
76849 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
76850 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
76851 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
76852 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
76853 & 0.002093D0*CT**3)
76854 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
76856 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
76857 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
76860 C...If negative three-jet rate, change y' optimization parameter.
76861 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
76862 & PARJ(169).LT.0.99D0) THEN
76863 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
76864 Q2=PARJ(169)*ECM**2
76865 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76869 C...If too high cross-section, use harder cuts, or fail.
76870 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
76871 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
76872 & PARJ(169).LT.0.99D0) THEN
76873 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
76874 Q2=PARJ(169)*ECM**2
76875 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76877 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
76879 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
76881 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
76882 & PARJ(154))**(-1D0/3D0)
76883 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
76887 C...Scalar gluon (first order only).
76889 ALSPI=PYALPS(ECM**2)/PARU(1)
76890 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
76892 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
76893 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
76898 C...Select number of jets.
76900 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
76902 ELSEIF(MSTJ(101).LE.0) THEN
76903 NJET=MIN(4,2-MSTJ(101))
76907 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
76908 IF(PARJ(154).GT.RNJ) NJET=4
76914 C*********************************************************************
76917 C...Selects the kinematical variables of three-jet events.
76919 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
76921 C...Double precision and integer declarations.
76922 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76923 IMPLICIT INTEGER(I-N)
76924 INTEGER PYK,PYCHGE,PYCOMP
76926 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76929 DIMENSION ZHUP(5,12)
76931 C...Coefficients of Zhu second order parametrization.
76932 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
76933 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
76934 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
76935 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
76936 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
76937 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
76938 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
76939 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
76940 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
76941 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
76942 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
76944 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
76945 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
76948 C...Event type. Mass effect factors and other common constants.
76952 QME=(2D0*PMQ/ECM)**2
76953 IF(MSTJ(109).NE.1) THEN
76955 CUTD=LOG(1D0/CUT-2D0)
76956 IF(MSTJ(109).EQ.0) THEN
76960 WTMX=MIN(20D0,37D0-6D0*CUTD)
76961 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
76969 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
76970 ALS2PI=PARU(118)/PARU(2)
76972 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
76973 & LOG(PARJ(169))*ALS2PI
76974 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
76976 C...Choose three-jet events in allowed region.
76978 110 Y13L=CUTL+CUTD*PYR(0)
76979 Y23L=CUTL+CUTD*PYR(0)
76983 IF(Y12.LE.CUT) GOTO 110
76984 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
76986 C...Second order corrections.
76987 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
76992 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
76993 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
76994 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
76995 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
76996 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
76997 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
76998 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
76999 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
77000 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
77001 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
77002 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
77003 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
77004 & TR*(2D0*CUTL/3D0-10D0/9D0)+
77005 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
77006 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
77007 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
77008 & Y13*Y23)/(Y12+Y13)**2)/WT1+
77009 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
77010 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
77011 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
77012 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
77013 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
77014 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
77015 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
77016 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
77017 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
77018 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
77020 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
77021 C...Second order corrections; Zhu parametrization of ERT.
77026 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
77030 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77031 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77032 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77033 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77036 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77037 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77038 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77039 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77041 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77042 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77043 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77044 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77045 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
77047 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
77048 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
77049 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
77052 C...Impose mass cuts (gives two jets). For fixed jet number new try.
77056 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
77057 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
77058 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
77059 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
77060 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
77062 C...Scalar gluon model (first order only, no mass effects).
77065 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
77066 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
77067 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
77068 X1=1D0-0.5D0*(X3+YD)
77069 X2=1D0-0.5D0*(X3-YD)
77070 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
77071 IF(MSTJ(102).GE.2) THEN
77072 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
77073 & X3**2*PYR(0)) NJET=2
77075 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
77081 C*********************************************************************
77084 C...Selects the kinematical variables of four-jet events.
77086 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
77088 C...Double precision and integer declarations.
77089 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77090 IMPLICIT INTEGER(I-N)
77091 INTEGER PYK,PYCHGE,PYCOMP
77093 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77096 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
77098 C...Common constants. Colour factors for QCD and Abelian gluon theory.
77100 QME=(2D0*PMQ/ECM)**2
77101 CT=LOG(1D0/CUT-5D0)
77102 IF(MSTJ(109).EQ.0) THEN
77112 C...Choice of process (qqbargg or qqbarqqbar).
77115 IF(PARJ(155).GT.PYR(0)) IT=2
77116 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
77117 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
77118 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
77119 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
77122 C...Sample the five kinematical variables (for qqgg preweighted in y34).
77123 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
77124 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
77125 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
77126 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
77127 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
77129 CP=COS(PARU(1)*PYR(0))
77132 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
77133 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
77134 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
77136 Y12=1D0-Y134-Y23-Y24
77137 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
77141 C...Calculate matrix elements for qqgg or qqqq process.
77146 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
77147 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
77148 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
77149 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
77150 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
77151 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
77152 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
77153 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
77154 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
77155 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
77156 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
77157 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
77158 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
77159 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
77160 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
77161 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
77162 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
77163 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
77164 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
77165 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
77166 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
77167 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
77168 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
77169 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
77170 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
77171 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
77172 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
77173 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
77174 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
77175 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
77176 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
77177 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
77178 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
77179 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
77180 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
77181 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
77182 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
77183 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
77184 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
77185 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
77186 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
77189 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
77190 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
77191 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
77192 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
77193 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
77194 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
77195 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
77196 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
77197 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
77198 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
77199 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
77200 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
77201 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
77202 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
77203 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
77204 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
77205 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
77206 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
77209 C...Permutations of momenta in matrix element. Weighting.
77210 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
77221 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
77232 IF(IC.LE.3) GOTO 120
77233 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
77236 C...qqgg events: string configuration and event type.
77238 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
77239 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
77240 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
77241 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
77242 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
77243 IF(ID.EQ.2) GOTO 130
77244 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
77245 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
77246 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
77247 IF(ID.EQ.2) GOTO 130
77250 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
77251 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
77254 C...Mass cuts. Kinematical variables out.
77255 IF(Y12.LE.CUT+QME) NJET=2
77256 IF(NJET.EQ.2) GOTO 150
77257 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
77258 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
77259 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
77261 X12=(1D0-Q12)*Y13+Q12*Y23
77263 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
77265 C...qqbarqqbar events: string configuration, choose new flavour.
77268 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
77269 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
77270 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
77271 IF(WTR.LT.WTD(4)) ID=4
77272 IF(ID.GE.2) GOTO 130
77275 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
77276 140 KFLN=1+INT(5D0*PYR(0))
77277 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
77278 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
77279 IF(KFLN.GT.MSTJ(104)) NJET=2
77281 QMEN=(2D0*PMQN/ECM)**2
77283 C...Mass cuts. Kinematical variables out.
77284 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
77285 IF(NJET.EQ.2) GOTO 150
77286 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
77287 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
77288 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
77289 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
77290 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
77291 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
77294 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
77296 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
77297 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
77298 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
77300 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
77305 C*********************************************************************
77308 C...Gives the angular orientation of events.
77310 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
77312 C...Double precision and integer declarations.
77313 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77314 IMPLICIT INTEGER(I-N)
77315 INTEGER PYK,PYCHGE,PYCOMP
77317 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77318 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77319 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77320 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77322 C...Charge. Factors depending on polarization for QED case.
77324 POLL=1D0-PARJ(131)*PARJ(132)
77325 POLD=PARJ(132)-PARJ(131)
77326 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
77332 C...Factors depending on flavour, energy and polarization for QFD case.
77334 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
77335 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
77336 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
77338 VE=4D0*PARU(102)-1D0
77340 VF=AF-4D0*QF*PARU(102)
77341 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
77342 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
77343 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
77344 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
77345 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
77346 & SFW*SFF**2*(VE**2-AE**2))
77347 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
77351 C...Mass factor. Differential cross-sections for two-jet events.
77354 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
77355 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
77357 SIGU=4D0*SQRT(1D0-QME)
77358 SIGL=2D0*QME*SQRT(1D0-QME)
77364 C...Kinematical variables. Reduce four-jet event to three-jet one.
77367 X1=2D0*P(NC+1,4)/ECM
77368 X2=2D0*P(NC+3,4)/ECM
77370 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
77371 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
77372 X1=2D0*P(NC+1,4)/ECMR
77373 X2=2D0*P(NC+4,4)/ECMR
77376 C...Differential cross-sections for three-jet (or reduced four-jet).
77377 XQ=(1D0-X1)/(1D0-X2)
77378 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
77379 ST12=SQRT(1D0-CT12**2)
77380 IF(MSTJ(109).NE.1) THEN
77381 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
77382 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
77383 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
77384 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
77386 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
77387 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
77388 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
77389 SIGA=X2**2*ST12/SQ2
77390 SIGP=2D0*(X1**2-X2**2*CT12)
77392 C...Differential cross-sect for scalar gluons (no mass effects).
77396 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
77397 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
77398 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
77399 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
77400 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
77401 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
77402 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
77403 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
77404 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
77405 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
77406 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
77410 C...Upper bounds for differential cross-section.
77415 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
77416 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
77417 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
77418 &2D0*HF2A*ABS(SIGP)
77420 C...Generate angular orientation according to differential cross-sect.
77421 100 CHI=PARU(2)*PYR(0)
77422 CTHE=2D0*PYR(0)-1D0
77430 C2PHI=COS(2D0*(PHI-PARJ(134)))
77431 S2PHI=SIN(2D0*(PHI-PARJ(134)))
77432 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
77433 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
77434 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
77435 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
77436 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
77437 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
77438 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
77439 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
77444 C*********************************************************************
77447 C...Generates Upsilon and toponium decays into three gluons
77448 C...or two gluons and a photon.
77450 SUBROUTINE PYONIA(KFL,ECM)
77452 C...Double precision and integer declarations.
77453 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77454 IMPLICIT INTEGER(I-N)
77455 INTEGER PYK,PYCHGE,PYCOMP
77457 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77458 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77459 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77460 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77462 C...Printout. Check input parameters.
77463 IF(MSTU(12).NE.12345) CALL PYLIST(0)
77464 IF(KFL.LT.0.OR.KFL.GT.8) THEN
77465 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
77466 IF(MSTU(21).GE.1) RETURN
77468 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
77469 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
77470 IF(MSTU(21).GE.1) RETURN
77473 C...Initial e+e- and onium state (optional).
77475 IF(MSTJ(115).GE.2) THEN
77477 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
77479 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
77483 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
77489 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
77495 C...Choose x1 and x2 according to matrix element.
77500 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
77501 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
77504 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
77505 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
77507 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
77508 MSTU(111)=MSTJ(108)
77509 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
77511 PARU(112)=PARJ(121)
77512 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
77514 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
77515 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
77518 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
77519 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
77521 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
77522 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
77525 ECMC=SQRT(1D0-X1)*ECM
77526 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
77531 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
77532 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
77533 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
77534 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
77536 IF(ECMC.LT.4D0*PARJ(127)) THEN
77540 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
77546 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
77549 C...Differential cross-sections. Upper limit for cross-section.
77550 IF(MSTJ(106).EQ.1) THEN
77552 HF1=1D0-PARJ(131)*PARJ(132)
77554 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
77555 ST13=SQRT(1D0-CT13**2)
77556 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
77557 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
77559 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
77560 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
77561 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
77563 C...Angular orientation of event.
77564 120 CHI=PARU(2)*PYR(0)
77565 CTHE=2D0*PYR(0)-1D0
77573 C2PHI=COS(2D0*(PHI-PARJ(134)))
77574 S2PHI=SIN(2D0*(PHI-PARJ(134)))
77575 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
77576 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
77577 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
77578 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
77579 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
77580 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
77581 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
77582 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
77585 C...Generate parton shower. Rearrange along strings and check.
77586 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
77587 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
77589 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
77590 IF(MSTJ(105).GE.0) MSTU(28)=0
77593 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
77596 C...Generate fragmentation. Information for PYTABU:
77597 IF(MSTJ(105).EQ.1) CALL PYEXEC
77598 MSTU(161)=110*KFLC+3
77604 C*********************************************************************
77607 C...Books a histogram.
77609 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
77611 C...Double precision declaration.
77612 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77613 IMPLICIT INTEGER(I-N)
77615 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77617 C...Local character variables.
77618 CHARACTER TITLE*(*), TITFX*60
77620 C...Check that input is sensible. Find initial address in memory.
77621 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77622 &'(PYBOOK:) not allowed histogram number')
77623 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
77624 &'(PYBOOK:) not allowed number of bins')
77625 IF(XL.GE.XU) CALL PYERRM(28,
77626 &'(PYBOOK:) x limits in wrong order')
77628 IHIST(4)=IHIST(4)+28+NX
77629 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
77630 &'(PYBOOK:) out of histogram space')
77633 C...Store histogram size and reset contents.
77637 BIN(IS+4)=(XU-XL)/NX
77640 C...Store title by conversion to integer to double precision.
77643 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
77644 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
77650 C*********************************************************************
77653 C...Fills entry in histogram.
77655 SUBROUTINE PYFILL(ID,X,W)
77657 C...Double precision declaration.
77658 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77659 IMPLICIT INTEGER(I-N)
77661 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77664 C...Find initial address in memory. Increase number of entries.
77665 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77666 &'(PYFILL:) not allowed histogram number')
77668 IF(IS.EQ.0) CALL PYERRM(28,
77669 &'(PYFILL:) filling unbooked histogram')
77670 BIN(IS+5)=BIN(IS+5)+1D0
77672 C...Find bin in x, including under/overflow, and fill.
77673 IF(X.LT.BIN(IS+2)) THEN
77674 BIN(IS+6)=BIN(IS+6)+W
77675 ELSEIF(X.GE.BIN(IS+3)) THEN
77676 BIN(IS+8)=BIN(IS+8)+W
77678 BIN(IS+7)=BIN(IS+7)+W
77679 IX=(X-BIN(IS+2))/BIN(IS+4)
77680 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
77681 BIN(IS+9+IX)=BIN(IS+9+IX)+W
77687 C*********************************************************************
77690 C...Multiplies histogram contents by factor.
77692 SUBROUTINE PYFACT(ID,F)
77694 C...Double precision declaration.
77695 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77696 IMPLICIT INTEGER(I-N)
77698 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77701 C...Find initial address in memory. Multiply all contents bins.
77702 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77703 &'(PYFACT:) not allowed histogram number')
77705 IF(IS.EQ.0) CALL PYERRM(28,
77706 &'(PYFACT:) scaling unbooked histogram')
77707 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
77714 C*********************************************************************
77717 C...Performs operations between histograms.
77719 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
77721 C...Double precision declaration.
77722 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77723 IMPLICIT INTEGER(I-N)
77725 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77727 C...Character variable.
77730 C...Find initial addresses in memory, and histogram size.
77731 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
77732 &'(PYFACT:) not allowed histogram number')
77734 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
77735 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
77736 NX=NINT(BIN(IS3+1))
77737 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
77739 C...Update info on number of histogram entries.
77740 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
77741 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
77742 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
77743 BIN(IS3+5)=BIN(IS1+5)
77746 C...Operations on pair of histograms: addition, subtraction,
77747 C...multiplication, division.
77748 IF(OPER.EQ.'+') THEN
77750 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
77752 ELSEIF(OPER.EQ.'-') THEN
77754 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
77756 ELSEIF(OPER.EQ.'*') THEN
77758 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
77760 ELSEIF(OPER.EQ.'/') THEN
77763 IF(ABS(FA2).LE.1D-20) THEN
77766 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
77770 C...Operations on single histogram: multiplication+addition,
77771 C...square root+addition, logarithm+addition.
77772 ELSEIF(OPER.EQ.'A') THEN
77774 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
77776 ELSEIF(OPER.EQ.'S') THEN
77778 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
77780 ELSEIF(OPER.EQ.'L') THEN
77783 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
77784 & ZMIN=0.8D0*BIN(IS1+IX)
77787 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
77790 C...Operation on two or three histograms: average and
77791 C...standard deviation.
77792 ELSEIF(OPER.EQ.'M') THEN
77794 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
77797 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
77800 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
77803 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
77807 BIN(IS1+IX)=F1*BIN(IS1+IX)
77814 C*********************************************************************
77817 C...Prints and resets all histograms.
77821 C...Double precision declaration.
77822 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77823 IMPLICIT INTEGER(I-N)
77825 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77828 C...Loop over histograms, print and reset used ones.
77829 DO 100 ID=1,IHIST(1)
77831 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
77840 C*********************************************************************
77843 C...Prints a histogram (but does not reset it).
77845 SUBROUTINE PYPLOT(ID)
77847 C...Double precision declaration.
77848 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77849 IMPLICIT INTEGER(I-N)
77851 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77852 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77853 SAVE /PYDAT1/,/PYBINS/
77854 C...Local arrays and character variables.
77855 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
77856 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
77858 C...Steps in histogram scale. Character sequence.
77859 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
77860 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
77862 C...Find initial address in memory; skip if empty histogram.
77863 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
77866 IF(NINT(BIN(IS+5)).LE.0) THEN
77867 WRITE(MSTU(11),5000) ID
77871 C...Number of histogram lines and x bins.
77875 C...Extract title by conversion from double precision via integer.
77877 IEQ=NINT(BIN(IS+8+NX+IT))
77878 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
77879 & //CHAR(MOD(IEQ,256))
77882 C...Find time; print title.
77884 IF(IDATI(1).GT.0) THEN
77885 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
77887 WRITE(MSTU(11),5200) ID, TITLE
77890 C...Find minimum and maximum bin content.
77893 DO 110 IX=IS+10,IS+8+NX
77894 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
77895 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
77898 C...Determine scale and step size for y axis.
77899 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
77900 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
77901 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
77902 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
77903 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
77904 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
77907 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
77911 C...Convert bin contents to integer form; fractional fill in top row.
77913 CTA=ABS(BIN(IS+8+IX))/DY
77914 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
77915 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
77917 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
77918 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
77920 C...Print histogram row by row.
77921 DO 150 IR=IRMA,IRMI,-1
77922 IF(IR.EQ.0) GOTO 150
77925 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
77926 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
77928 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
77931 C...Print sign and value of bin contents.
77932 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
77935 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
77936 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
77938 WRITE(MSTU(11),5400) OUT
77941 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
77943 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
77946 C...Print sign and value of lower bin edge.
77947 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
77951 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
77952 & OUT(IX:IX)=CHA(11)
77953 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
77955 WRITE(MSTU(11),5600) OUT
77958 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
77960 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
77964 C...Calculate and print statistics.
77969 CTA=ABS(BIN(IS+8+IX))
77970 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
77973 CXXSUM=CXXSUM+CTA*X**2
77975 XMEAN=CXSUM/MAX(CSUM,1D-20)
77976 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
77977 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
77978 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
77980 C...Formats for output.
77981 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
77982 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
77984 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
77985 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
77986 5400 FORMAT(/8X,'Contents',3X,A100)
77987 5500 FORMAT(9X,'*10**',I2,3X,A100)
77988 5600 FORMAT(/8X,'Low edge',3X,A100)
77989 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
77990 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
77991 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
77996 C*********************************************************************
77999 C...Resets bin contents of a histogram.
78001 SUBROUTINE PYNULL(ID)
78003 C...Double precision declaration.
78004 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78005 IMPLICIT INTEGER(I-N)
78007 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
78010 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
78013 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
78020 C*********************************************************************
78023 C...Dumps histogram contents on file for reading by other program.
78024 C...Can also read back own dump.
78026 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
78028 C...Double precision declaration.
78029 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78030 IMPLICIT INTEGER(I-N)
78032 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
78034 C...Local arrays and character variables.
78035 DIMENSION IHI(*),ISS(100),VAL(5)
78036 CHARACTER TITLE*60,FORMAT*13
78038 C...Dump all histograms that have been booked,
78039 C...including titles and ranges, one after the other.
78040 IF(MDUMP.EQ.1) THEN
78042 C...Loop over histograms and find which are wanted and booked.
78057 C...Write title, histogram size, filling statistics.
78060 IEQ=NINT(BIN(IS+8+NX+IT))
78061 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
78062 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
78064 WRITE(LFN,5100) ID,TITLE
78065 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
78066 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
78070 C...Write histogram contents, in groups of five.
78071 DO 120 IXG=1,(NX+4)/5
78075 VAL(IXV)=BIN(IS+8+IX)
78080 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
78083 C...Go to next histogram; finish.
78084 ELSEIF(NHI.GT.0) THEN
78085 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
78089 C...Read back in histograms dumped MDUMP=1.
78090 ELSEIF(MDUMP.EQ.2) THEN
78092 C...Read histogram number, title and range, and book.
78093 140 READ(LFN,5100,END=170) ID,TITLE
78094 READ(LFN,5200) NX,XL,XU
78095 CALL PYBOOK(ID,TITLE,NX,XL,XU)
78098 C...Read filling statistics.
78099 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
78100 BIN(IS+5)=DBLE(NENTRY)
78102 C...Read histogram contents, in groups of five.
78103 DO 160 IXG=1,(NX+4)/5
78104 READ(LFN,5400) (VAL(IXV),IXV=1,5)
78107 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
78111 C...Go to next histogram; finish.
78115 C...Write histogram contents in column format,
78116 C...convenient e.g. for GNUPLOT input.
78117 ELSEIF(MDUMP.EQ.3) THEN
78119 C...Find addresses to wanted histograms.
78133 IF(IS.NE.0.AND.NSS.LT.100) THEN
78136 ELSEIF(NSS.GE.100) THEN
78137 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
78138 ELSEIF(NHI.GT.0) THEN
78139 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
78143 C...Check that they have common number of x bins. Fix format.
78144 NX=NINT(BIN(ISS(1)+1))
78146 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
78147 CALL PYERRM(8,'(PYDUMP:) different number of bins')
78151 FORMAT='(1P,000E12.4)'
78152 WRITE(FORMAT(5:7),'(I3)') NSS+1
78154 C...Write histogram contents; first column x values.
78156 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
78157 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
78162 C...Formats for output.
78163 5100 FORMAT(I5,5X,A60)
78164 5200 FORMAT(I5,1P,2D12.4)
78165 5300 FORMAT(I12,1P,3D12.4)
78166 5400 FORMAT(1P,5D12.4)
78171 C*********************************************************************
78174 C...Allows users to handle STOP statemens
78176 SUBROUTINE PYSTOP(MCOD)
78178 C...Double precision and integer declarations.
78179 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78180 IMPLICIT INTEGER(I-N)
78181 INTEGER PYK,PYCHGE,PYCOMP
78183 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78187 C...Write message, then stop
78188 WRITE(MSTU(11),5000) MCOD
78192 C...Formats for output.
78193 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
78196 C*********************************************************************
78199 C...Dummy routine, which the user can replace in order to make cuts on
78200 C...the kinematics on the parton level before the matrix elements are
78201 C...evaluated and the event is generated. The cross-section estimates
78202 C...will automatically take these cuts into account, so the given
78203 C...values are for the allowed phase space region only. MCUT=0 means
78204 C...that the event has passed the cuts, MCUT=1 that it has failed.
78206 SUBROUTINE PYKCUT(MCUT)
78208 C...Double precision and integer declarations.
78209 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78210 IMPLICIT INTEGER(I-N)
78211 INTEGER PYK,PYCHGE,PYCOMP
78213 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78214 COMMON/PYINT1/MINT(400),VINT(400)
78215 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
78216 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
78218 C...Set default value (accepting event) for MCUT.
78221 C...Read out subprocess number.
78225 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78229 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
78231 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
78233 C...Calculate x_1, x_2, x_F.
78234 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
78235 X1=SQRT(TAU)*EXP(YST)
78236 X2=SQRT(TAU)*EXP(-YST)
78238 X1=SQRT(TAUP)*EXP(YST)
78239 X2=SQRT(TAUP)*EXP(-YST)
78243 C...Calculate shat, that, uhat, p_T^2.
78249 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
78250 RPTS=4D0*VINT(71)**2/SHAT
78251 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
78254 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
78255 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
78256 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
78257 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
78259 C...Decisions by user to be put here.
78261 C...Stop program if this routine is ever called.
78262 C...You should not copy these lines to your own routine.
78263 WRITE(MSTU(11),5000)
78266 C...Format for error printout.
78267 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
78268 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78269 &1X,'Execution stopped!')
78274 C*********************************************************************
78277 C...Dummy routine, which the user can replace in order to multiply the
78278 C...standard PYTHIA differential cross-section by a process- and
78279 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
78280 C...to generation of weighted events, with weight 1/WTXS, while for
78281 C...MSTP(142)=2 it corresponds to a modification of the underlying
78284 SUBROUTINE PYEVWT(WTXS)
78286 C...Double precision and integer declarations.
78287 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78288 IMPLICIT INTEGER(I-N)
78289 INTEGER PYK,PYCHGE,PYCOMP
78291 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78292 COMMON/PYINT1/MINT(400),VINT(400)
78293 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
78294 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
78296 C...Set default weight for WTXS.
78299 C...Read out subprocess number.
78303 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78307 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
78309 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
78311 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
78320 C...Modifications by user to be put here.
78322 C...Stop program if this routine is ever called.
78323 C...You should not copy these lines to your own routine.
78324 WRITE(MSTU(11),5000)
78327 C...Format for error printout.
78328 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
78329 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78330 &1X,'Execution stopped!')
78335 C*********************************************************************
78338 C...Dummy routine, to be replaced by a user implementing external
78339 C...processes. Is supposed to fill the HEPRUP commonblock with info
78340 C...on incoming beams and allowed processes.
78342 C...New example: handles a standard Les Houches Events File.
78346 C...Double precision and integer declarations.
78347 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78348 IMPLICIT INTEGER(I-N)
78350 C...PYTHIA commonblock: only used to provide read unit MSTP(161).
78351 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78354 C...User process initialization commonblock.
78356 PARAMETER (MAXPUP=100)
78357 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78358 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78359 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78360 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78364 C...Lines to read in assumed never longer than 200 characters.
78365 PARAMETER (MAXLEN=200)
78366 CHARACTER*(MAXLEN) STRING
78368 C...Format for reading lines.
78371 WRITE(STRFMT(3:5),'(I3)') MAXLEN
78373 C...Loop until finds line beginning with "<init>" or "<init ".
78374 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
78377 C...Allow indentation.
78378 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
78379 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
78380 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
78382 C...Read first line of initialization info.
78383 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
78384 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78386 C...Read NPRUP subsequent lines with information on each process.
78388 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
78389 & XMAXUP(IPR),LPRUP(IPR)
78393 C...Error exit: give up if initalization does not work.
78394 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
78395 WRITE(*,*) ' Event generation will be stopped.'
78401 C...Old example: handles a simple Pythia 6.4 initialization file.
78403 c SUBROUTINE UPINIT
78405 C...Double precision and integer declarations.
78406 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78407 c IMPLICIT INTEGER(I-N)
78410 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78411 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78412 c SAVE /PYDAT1/,/PYPARS/
78414 C...User process initialization commonblock.
78416 c PARAMETER (MAXPUP=100)
78417 c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78418 c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78419 c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78420 c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78424 C...Read info from file.
78425 c IF(MSTP(161).GT.0) THEN
78426 c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
78427 c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78428 c DO 100 IPR=1,NPRUP
78429 c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
78430 c & XMAXUP(IPR),LPRUP(IPR)
78433 C...Error or prematurely reached end of file.
78434 c 110 WRITE(MSTU(11),5000)
78437 C...Else not implemented.
78439 c WRITE(MSTU(11),5100)
78443 C...Format for error printout.
78444 c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
78445 c &1X,'Execution stopped!')
78446 c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
78447 c &1X,'Dummy routine in PYTHIA file called instead.'/
78448 c &1X,'Execution stopped!')
78453 C*********************************************************************
78456 C...Dummy routine, to be replaced by a user implementing external
78457 C...processes. Depending on cross section model chosen, it either has
78458 C...to generate a process of the type IDPRUP requested, or pick a type
78459 C...itself and generate this event. The event is to be stored in the
78460 C...HEPEUP commonblock, including (often) an event weight.
78462 C...New example: handles a standard Les Houches Events File.
78466 C...Double precision and integer declarations.
78467 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78468 IMPLICIT INTEGER(I-N)
78470 C...PYTHIA commonblock: only used to provide read unit MSTP(162).
78471 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78474 C...User process event common block.
78476 PARAMETER (MAXNUP=500)
78477 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78478 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78479 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78480 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78481 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78484 C...Lines to read in assumed never longer than 200 characters.
78485 PARAMETER (MAXLEN=200)
78486 CHARACTER*(MAXLEN) STRING
78488 C...Format for reading lines.
78491 WRITE(STRFMT(3:5),'(I3)') MAXLEN
78493 C...Loop until finds line beginning with "<event>" or "<event ".
78494 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
78497 C...Allow indentation.
78498 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
78499 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
78500 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
78502 C...Read first line of event info.
78503 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
78506 C...Read NUP subsequent lines with information on each particle.
78508 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
78509 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78510 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78514 C...Error exit, typically when no more events.
78515 130 WRITE(*,*) ' Failed to read LHEF event information.'
78516 WRITE(*,*) ' Will assume end of file has been reached.'
78523 C...Old example: handles a simple Pythia 6.4 event file.
78525 c SUBROUTINE UPEVNT
78527 C...Double precision and integer declarations.
78528 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78529 c IMPLICIT INTEGER(I-N)
78532 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78533 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78534 c SAVE /PYDAT1/,/PYPARS/
78536 C...User process event common block.
78538 c PARAMETER (MAXNUP=500)
78539 c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78540 c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78541 c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78542 c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78543 c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78546 C...Read info from file.
78547 c IF(MSTP(162).GT.0) THEN
78548 c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
78551 c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
78552 c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78553 c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78556 C...Special when reached end of file or other error.
78559 C...Else not implemented.
78561 c WRITE(MSTU(11),5000)
78565 C...Format for error printout.
78566 c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
78567 c &1X,'Dummy routine in PYTHIA file called instead.'/
78568 c &1X,'Execution stopped!')
78573 C*********************************************************************
78576 C...Dummy routine, to be replaced by user, to veto event generation
78577 C...on the parton level, after parton showers but before multiple
78578 C...interactions, beam remnants and hadronization is added.
78579 C...If resonances like W, Z, top, Higgs and SUSY particles are handed
78580 C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
78581 C...be undecayed at this stage; if decayed their decay products will
78582 C...have been allowed to shower.
78584 C...All partons at the end of the shower phase are stored in the
78585 C...HEPEVT commonblock. The interesting information is
78586 C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
78587 C...IDHEP(I) = the particle ID code according to PDG conventions,
78588 C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
78589 C...All ISTHEP entries are 1, while the rest is zeroed.
78591 C...The user decision is to be conveyed by the IVETO value.
78592 C...IVETO = 0 : retain current event and generate in full;
78593 C... = 1 : abort generation of current event and move to next.
78595 SUBROUTINE UPVETO(IVETO)
78597 C...HEPEVT commonblock.
78598 PARAMETER (NMXHEP=4000)
78599 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
78600 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
78601 DOUBLE PRECISION PHEP,VHEP
78604 C...Next few lines allow you to see what info PYVETO extracted from
78605 C...the full event record for the first two events.
78606 C...Delete if you don't want it.
78609 IF(NLIST.LE.2) THEN
78610 WRITE(*,*) ' Full event record at time of UPVETO call:'
78612 WRITE(*,*) ' Part of event record made available to UPVETO:'
78617 C...Make decision here.
78623 C*********************************************************************
78625 C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
78627 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
78628 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78629 IMPLICIT INTEGER(I-N)
78630 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
78633 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78636 C...Stop program if this routine is ever called.
78637 WRITE(MSTU(11),5000)
78640 C...Format for error printout.
78641 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78642 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
78643 &1X,'Execution stopped!')
78648 C*********************************************************************
78651 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78654 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78655 IMPLICIT INTEGER(I-N)
78656 CHARACTER*40 VISAJE
78659 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78662 C...Assign default value.
78665 C...Stop program if this routine is ever called.
78666 WRITE(MSTU(11),5000)
78669 C...Format for error printout.
78670 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78671 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
78672 &1X,'Execution stopped!')
78677 C*********************************************************************
78680 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78682 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
78683 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
78684 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
78686 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78687 IMPLICIT INTEGER(I-N)
78688 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
78689 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
78690 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
78692 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78695 C...Stop program if this routine is ever called.
78696 WRITE(MSTU(11),5000)
78699 C...Format for error printout.
78700 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78701 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
78702 &1X,'Execution stopped!')
78706 C*********************************************************************
78709 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78711 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
78712 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78713 IMPLICIT INTEGER(I-N)
78714 Cmssmpart = 4 # full MSSM [recommended]
78715 Cfieldren = 0 # MSbar field ren. [strongly recommended]
78716 Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
78717 Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
78718 Cp2approx = 0 # no approximation [recommended]
78719 Clooplevel= 2 # include 2-loop corrections
78720 Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
78721 Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
78724 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78727 C...Stop program if this routine is ever called.
78728 WRITE(MSTU(11),5000)
78731 C...Format for error printout.
78732 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78733 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
78734 &1X,'Execution stopped!')
78738 C*********************************************************************
78741 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78743 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
78744 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
78745 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
78746 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
78747 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78748 IMPLICIT INTEGER(I-N)
78750 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78751 DOUBLE COMPLEX DMU,
78752 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78756 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78759 C...Stop program if this routine is ever called.
78760 WRITE(MSTU(11),5000)
78763 C...Format for error printout.
78764 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78765 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78766 &1X,'Execution stopped!')
78770 C*********************************************************************
78773 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78775 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
78776 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78777 IMPLICIT INTEGER(I-N)
78779 C...FeynHiggs variables
78780 DOUBLE PRECISION RMHIGG(4)
78781 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78782 DOUBLE COMPLEX DMU,
78783 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78787 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78790 C...Stop program if this routine is ever called.
78791 WRITE(MSTU(11),5000)
78794 C...Format for error printout.
78795 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78796 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78797 &1X,'Execution stopped!')
78801 C*********************************************************************
78804 C...Dummy routine, to be replaced by user, to handle the decay of a
78805 C...polarized tau lepton.
78807 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
78808 C...IORIG is the position where the mother of the tau is stored;
78809 C... is 0 when the mother is not stored.
78810 C...KFORIG is the flavour of the mother of the tau;
78811 C... is 0 when the mother is not known.
78812 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
78813 C... e.g. in B hadron semileptonic decays the W propagator
78814 C... is not explicitly stored but the W code is still unambiguous.
78816 C...NDECAY is the number of decay products in the current tau decay.
78817 C...These decay products should be added to the /PYJETS/ common block,
78818 C...in positions N+1 through N+NDECAY. For each product I you must
78819 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
78820 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
78822 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
78824 C...Double precision and integer declarations.
78825 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78826 IMPLICIT INTEGER(I-N)
78827 INTEGER PYK,PYCHGE,PYCOMP
78829 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
78830 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78831 SAVE /PYJETS/,/PYDAT1/
78833 C...Stop program if this routine is ever called.
78834 C...You should not copy these lines to your own routine.
78835 NDECAY=ITAU+IORIG+KFORIG
78836 WRITE(MSTU(11),5000)
78839 C...Format for error printout.
78840 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
78841 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78842 &1X,'Execution stopped!')
78847 C*********************************************************************
78850 C...Finds current date and time.
78851 C...Since this task is not standardized in Fortran 77, the routine
78852 C...is dummy, to be replaced by the user. Examples are given for
78853 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
78854 C...you do not have access to suitable routines.
78856 SUBROUTINE PYTIME(IDATI)
78858 C...Double precision and integer declarations.
78859 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78860 IMPLICIT INTEGER(I-N)
78861 INTEGER PYK,PYCHGE,PYCOMP
78864 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
78866 C...Example 0: if you do not have suitable routines.
78871 C...Example 1: Fortran 90 routine.
78872 C CALL DATE_AND_TIME(VALUES=IVAL)
78880 C...Example 2: DEC Fortran 77. AIX.
78881 C CALL IDATE(IMON,IDAY,IYEAR)
78885 C CALL ITIME(IHOUR,IMIN,ISEC)
78890 C...Example 3: DEC Fortran, IRIX, IRIX64.
78891 C CALL IDATE(IMON,IDAY,IYEAR)
78899 C READ(ATIME(1:2),'(I2)') IHOUR
78900 C READ(ATIME(4:5),'(I2)') IMIN
78901 C READ(ATIME(7:8),'(I2)') ISEC
78906 C...Example 4: GNU LINUX libU77, SunOS.
78907 C CALL IDATE(IDTEMP)
78908 C IDATI(1)=IDTEMP(3)
78909 C IDATI(2)=IDTEMP(2)
78910 C IDATI(3)=IDTEMP(1)
78911 C CALL ITIME(IDTEMP)
78912 C IDATI(4)=IDTEMP(1)
78913 C IDATI(5)=IDTEMP(2)
78914 C IDATI(6)=IDTEMP(3)
78916 C...Common code to ensure right century.
78917 IDATI(1)=2000+MOD(IDATI(1),100)
git://git.uio.no / u / mrichter / AliRoot.git / blob