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/LW50512/QCDL4,QCDL5
2877 SAVE /W50511/,/LW50512/
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)
2959 C...Choose Lambda value to use in alpha-strong.
2961 IF(MSTP(3).GE.2) THEN
2964 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2965 ALAM=ALAMIN(MSTP(51))
2967 ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
2970 ELSEIF(MSTP(52).EQ.2) THEN
2979 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2981 C...Initialize the UED masses and widths
2982 IF (IUED(1).EQ.1) CALL PYXDIN
2984 C...Initialize the SUSY generation: couplings, masses,
2985 C...decay modes, branching ratios, and so on.
2987 C...Initialize widths and partial widths for resonances.
2989 C...Set Z0 mass and width for e+e- routines.
2990 PARJ(123)=PMAS(23,1)
2991 PARJ(124)=PMAS(23,2)
2993 C...Identify beam and target particles and frame of process.
2997 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2998 IF(MINT(65).EQ.1) GOTO 170
3000 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
3001 C...For e-gamma allow 2 alternatives.
3003 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3004 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3005 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
3006 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
3007 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3008 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
3009 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3010 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3011 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
3012 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
3013 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3014 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3015 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
3016 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
3017 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3018 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3019 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
3020 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
3023 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
3024 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
3025 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
3026 IF(MSTP(14).EQ.11) MINT(123)=0
3027 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
3028 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
3029 IF(MSTP(14).EQ.15) MINT(123)=2
3030 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
3031 IF(MSTP(14).EQ.19) MINT(123)=3
3032 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
3033 IF(MSTP(14).EQ.21) MINT(123)=0
3034 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
3035 IF(MSTP(14).EQ.24) MINT(123)=1
3036 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
3037 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
3038 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
3041 C...Set up kinematics of process.
3044 C...Set up kinematics for photons inside leptons.
3045 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
3047 C...Precalculate flavour selection weights.
3050 C...Loop over gamma-p or gamma-gamma alternatives.
3053 DO 160 IGA=1,MINT(121)
3057 C...Select partonic subprocesses to be included in the simulation.
3064 C...Count number of subprocesses on.
3067 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
3068 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
3070 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
3071 & MSUB(ISUB).EQ.1) THEN
3072 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
3074 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
3075 WRITE(MSTU(11),5300) ISUB
3077 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
3078 WRITE(MSTU(11),5400) ISUB
3080 ELSEIF(MSUB(ISUB).EQ.1) THEN
3085 C...Stop or raise warning flag if no subprocesses on.
3086 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
3087 IF(MSTP(127).NE.1) THEN
3088 WRITE(MSTU(11),5500)
3091 WRITE(MSTU(11),5700)
3095 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
3096 MSAV48=MSAV48+MINT(48)
3098 C...Reset variables for cross-section calculation.
3106 C...Find parametrized total cross-sections.
3110 C...Maxima of differential cross-sections.
3111 IF(MSTP(121).LE.1) CALL PYMAXI
3113 C...Initialize possibility of pileup events.
3114 IF(MINT(121).GT.1) MSTP(131)=0
3115 IF(MSTP(131).NE.0) CALL PYPILE(1)
3117 C...Initialize multiple interactions with variable impact parameter.
3118 IF(MINT(50).EQ.1) THEN
3119 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
3120 IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
3121 & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
3122 IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
3130 C...Save results for gamma-p and gamma-gamma alternatives.
3131 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
3134 C...Initialization finished.
3135 IF(MSAV48.EQ.0) THEN
3136 IF(MSTP(127).NE.1) THEN
3137 WRITE(MSTU(11),5500)
3140 WRITE(MSTU(11),5700)
3144 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
3146 C...Formats for initialization information.
3147 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
3148 &'routines',1X,17('*'))
3149 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
3150 &'-',A6,' interactions.'/1X,'Execution stopped!')
3151 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
3152 &1X,'Execution stopped!')
3153 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
3154 &1X,'Execution stopped!')
3155 5500 FORMAT(1X,'Error: no subprocess switched on.'/
3156 &1X,'Execution stopped.')
3157 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
3159 5700 FORMAT(1X,'Error: no subprocess switched on.'/
3160 &1X,'Execution will stop if you try to generate events.')
3165 C*********************************************************************
3168 C...Administers the generation of a high-pT event via calls to
3169 C...a number of subroutines.
3173 C...Double precision and integer declarations.
3174 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3175 IMPLICIT INTEGER(I-N)
3176 INTEGER PYK,PYCHGE,PYCOMP
3177 PARAMETER (MAXNUR=1000)
3179 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
3180 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3181 COMMON/PYCTAG/NCT,MCT(4000,2)
3182 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3183 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3184 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3185 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3186 COMMON/PYINT1/MINT(400),VINT(400)
3187 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3188 COMMON/PYINT4/MWID(500),WIDS(500,5)
3189 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3190 SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
3191 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
3195 C...Optionally let PYEVNW do the whole job.
3196 IF(MSTP(81).GE.20) THEN
3201 C...Stop if no subprocesses on.
3202 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3203 WRITE(MSTU(11),5100)
3207 C...Initial values for some counters.
3220 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3224 C...Let called routines know call is from PYEVNT (not PYEVNW).
3226 IF (MSTP(81).GE.10) MINT(35)=2
3228 C...If variable energies: redo incoming kinematics and cross-section.
3230 IF(MSTP(171).EQ.1) THEN
3232 IF(MSTI(61).EQ.1) THEN
3236 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3240 C...Loop over number of pileup events; check space left.
3241 IF(MSTP(131).LE.0) THEN
3247 DO 270 IPILE=1,NPILE
3248 IF(MINT(84)+100.GE.MSTU(4)) THEN
3250 & '(PYEVNT:) no more space in PYJETS for pileup events')
3251 IF(MSTU(21).GE.1) GOTO 280
3255 C...Generate variables of hard scattering.
3259 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3265 IF(MSTI(61).EQ.1) THEN
3269 IF(MINT(51).EQ.2) RETURN
3271 IF(MSTP(111).EQ.-1) GOTO 260
3273 C...Loopback point if PYPREP fails, especially for junction topologies.
3279 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3280 C...Hard scattering (including low-pT):
3281 C...reconstruct kinematics and colour flow of hard scattering.
3286 IF(MINT(51).EQ.1) GOTO 100
3289 IF(ISUB.EQ.95) GOTO 140
3291 C...Reset statistics on activity in event.
3297 C...Showering of initial state partons (optional).
3301 IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
3302 & CALL PYSSPA(IPU1,IPU2)
3304 IF(MINT(51).EQ.1) GOTO 100
3306 C...pT-ordered FSR off ISR (optional, must have at least 2 partons)
3307 IF (NPART.GE.2.AND.(MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12)) THEN
3308 PTMAX=0.5*SQRT(PARP(71))*VINT(55)
3309 CALL PYPTFS(3,PTMAX,0D0,PTGEN)
3312 C...Showering of final state partons (optional).
3315 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
3319 IF(ISET(ISUB).EQ.5) IPU4=-3
3321 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3322 CALL PYSHOW(IPU3,IPU4,QMAX)
3323 ELSEIF(ISET(ISUB).EQ.11) THEN
3328 C...Allow possibility for user to abort event generation.
3330 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
3331 IF(IVETO.EQ.1) GOTO 100
3333 C...Decay of final state resonances.
3335 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
3336 IF(MINT(51).EQ.1) GOTO 100
3340 C...Multiple interactions - PYTHIA 6.3 intermediate style.
3341 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
3342 IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
3344 IF(MINT(51).EQ.1) GOTO 100
3347 C...Beam remnant flavour and colour assignments - new scheme.
3349 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3351 IF(MINT(51).EQ.1) GOTO 100
3353 C...Primordial kT and beam remnant momentum sharing - new scheme.
3355 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3357 IF(MINT(51).EQ.1) GOTO 100
3358 IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
3360 C...Multiple interactions - PYTHIA 6.2 style.
3361 ELSEIF(MINT(111).NE.12) THEN
3362 IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
3367 C...Hadron remnants and primordial kT.
3368 CALL PYREMN(IPU1,IPU2)
3369 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3371 IF(MINT(51).EQ.1) GOTO 100
3374 ELSEIF(ISUB.NE.99) THEN
3375 C...Diffractive and elastic scattering.
3379 C...DIS scattering (photon flux external).
3381 IF(MINT(51).EQ.1) GOTO 100
3384 C...Check that no odd resonance left undecayed.
3386 IF(MSTP(111).GE.1) THEN
3388 DO 150 I=MINT(84)+1,NFIX
3389 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3390 & K(I,2).NE.22) THEN
3392 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3394 IF(MINT(51).EQ.1) GOTO 100
3400 C...Boost hadronic subsystem to overall rest frame.
3401 C..(Only relevant when photon inside lepton beam.)
3402 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3404 C...Recalculate energies from momenta and masses (if desired).
3405 IF(MSTP(113).GE.1) THEN
3406 DO 160 I=MINT(83)+1,N
3407 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3408 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3413 C...Colour reconnection before string formation
3414 IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
3416 C...Rearrange partons along strings, check invariant mass cuts.
3418 IF(MSTP(111).LE.0) MSTJ(14)=-1
3419 CALL PYPREP(MINT(84)+1)
3421 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3425 IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
3426 IF (MINT(51).EQ.1) GOTO 100
3427 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3428 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3429 DO 190 I=MINT(84)+1,N
3430 IF(K(I,2).EQ.94) THEN
3431 DO 180 I1=I+1,MIN(N,I+10)
3432 IF(K(I1,3).EQ.I) THEN
3433 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3434 IF(K(I1,3).EQ.0) THEN
3435 DO 170 II=MINT(84)+1,I-1
3436 IF(K(II,2).EQ.K(I1,2)) THEN
3437 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3438 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3441 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3449 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3450 IF(MSTP(125).EQ.0) MINT(4)=0
3451 DO 210 I=MINT(83)+1,N
3452 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3454 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3455 IF(K(I1,3).EQ.I) K(I,5)=I1
3461 C...Introduce separators between sections in PYLIST event listing.
3462 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3465 ELSEIF(IPILE.EQ.1) THEN
3472 C...Go back to lab frame (needed for vertices, also in fragmentation).
3475 C...Set nonvanishing production vertex (optional).
3476 IF(MSTP(151).EQ.1) THEN
3478 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3479 & SIN(PARU(2)*PYR(0))
3481 DO 240 I=MINT(83)+1,N
3483 V(I,J)=V(I,J)+VTX(J)
3488 C...Perform hadronization (if desired).
3489 IF(MSTP(111).GE.1) THEN
3491 IF(MSTU(24).NE.0) GOTO 100
3493 IF(MSTP(113).GE.1) THEN
3495 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3496 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3499 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3501 C...Store event information and calculate Monte Carlo estimates of
3502 C...subprocess cross-sections.
3503 260 IF(IPILE.EQ.1) CALL PYDOCU
3505 C...Set counters for current pileup event and loop to next one.
3507 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3508 IF(MSTU70.LT.10) THEN
3513 MINT(84)=N+MSTP(126)
3514 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3517 C...Generic information on pileup events. Reconstruct missing history.
3518 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3522 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3526 C...Transform to the desired coordinate frame.
3527 280 CALL PYFRAM(MSTP(124))
3532 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3533 &1X,'Execution stopped.')
3538 C*********************************************************************
3541 C...Administers the generation of a high-pT event via calls to
3542 C...a number of subroutines for the new multiple interactions and
3543 C...showering framework.
3547 C...Double precision and integer declarations.
3548 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3549 IMPLICIT INTEGER(I-N)
3550 INTEGER PYK,PYCHGE,PYCOMP
3551 PARAMETER (MAXNUR=1000)
3553 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
3555 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3556 COMMON/PYCTAG/NCT,MCT(4000,2)
3557 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3558 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3559 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3560 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3561 COMMON/PYINT1/MINT(400),VINT(400)
3562 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3563 COMMON/PYINT4/MWID(500),WIDS(500,5)
3564 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3565 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
3566 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
3567 & XMI(2,240),PT2MI(240),IMISEP(0:240)
3568 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
3569 & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
3573 C...Stop if no subprocesses on.
3574 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3575 WRITE(MSTU(11),5100)
3579 C...Initial values for some counters.
3592 C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3595 C...Zero counters for pT-ordered showers (failsafe)
3599 C...Let called routines know call is from PYEVNW (not PYEVNT).
3602 C...If variable energies: redo incoming kinematics and cross-section.
3604 IF(MSTP(171).EQ.1) THEN
3606 IF(MSTI(61).EQ.1) THEN
3610 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3614 C...Loop over number of pileup events; check space left.
3615 IF(MSTP(131).LE.0) THEN
3621 DO 300 IPILE=1,NPILE
3622 IF(MINT(84)+100.GE.MSTU(4)) THEN
3624 & '(PYEVNW:) no more space in PYJETS for pileup events')
3625 IF(MSTU(21).GE.1) GOTO 310
3629 C...Generate variables of hard scattering.
3635 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3636 IF(LOOPHS.GE.10) THEN
3637 CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or '
3638 & //'multiple interactions. Returning.')
3648 IF(MSTI(61).EQ.1) THEN
3652 IF(MINT(51).EQ.2) RETURN
3654 IF(MSTP(111).EQ.-1) GOTO 290
3656 C...Loopback point if PYPREP fails, especially for junction topologies.
3662 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3663 C...Hard scattering (including low-pT):
3664 C...reconstruct kinematics and colour flow of hard scattering.
3669 IF(MINT(51).EQ.1) GOTO 100
3673 C...Intertwined initial state showers and multiple interactions.
3674 C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3675 C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3677 IF (MINT(47).LT.2) MSTP(61)=0
3679 IF (MINT(50).EQ.0) MSTP(81)=0
3680 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3681 & MINT(111).NE.12) THEN
3682 C...Absolute max pT2 scale for evolution: phase space limit.
3683 PT2MXS=0.25D0*VINT(2)
3684 C...Check if more constrained by ISR and MI max scales:
3685 PT2MXS=MIN(PT2MXS,MAX(VINT(56),VINT(62)))
3686 C...Loopback point in case of failure in evolution.
3690 IF(LOOP.GT.100) THEN
3691 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3692 & //'multiple interactions. Trying new point.')
3697 C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3698 C...once per event. (E.g. compute constants and save variables to be
3699 C...restored later in case of failure.)
3700 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3702 C...Initialize interleaved MI/ISR/JI evolution.
3703 C...PT2MAX: absolute upper limit for evolution - Initialization may
3704 C... return a PT2MAX which is lower than this.
3705 C...PT2MIN: absolute lower limit for evolution - Initialization may
3706 C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3709 CALL PYEVOL(0,PT2MAX,PT2MIN)
3710 C...If failed to initialize evolution, generate a new hard process
3711 IF (MINT(51).EQ.1) GOTO 100
3713 C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3714 C...In principle factorized, so can be stopped and restarted.
3715 C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3716 C PT2MED=MAX(10D0**2,PT2MIN)
3717 C CALL PYEVOL(1,PT2MAX,PT2MED)
3718 C IF (MINT(51).EQ.1) GOTO 160
3720 CALL PYEVOL(1,PT2MAX,PT2MIN)
3721 C...If fatal error (e.g., massive hard-process initiator, but no available
3722 C...phase space for creation), generate a new hard process
3723 IF (MINT(51).EQ.2) GOTO 100
3724 C...If smaller error, just try running evolution again
3725 IF (MINT(51).EQ.1) GOTO 130
3727 C...Finalize interleaved MI/ISR/JI evolution.
3728 CALL PYEVOL(2,PT2MAX,PT2MIN)
3729 IF (MINT(51).EQ.1) GOTO 130
3734 IF(MINT(51).EQ.1) GOTO 100
3735 C...(MINT(52) is actually obsolete in this routine. Set anyway
3736 C...to ensure PYDOCU stable.)
3740 C...Beam remnants - new scheme.
3741 140 IF(MINT(50).EQ.1) THEN
3742 IF (ISUB.EQ.95) MINT(31)=1
3744 C...Beam remnant flavour and colour assignments - new scheme.
3746 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3748 IF(MINT(51).EQ.1) GOTO 100
3750 C...Primordial kT and beam remnant momentum sharing - new scheme.
3752 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3754 IF(MINT(51).EQ.1) GOTO 100
3755 IF (ISUB.EQ.95) MINT(31)=0
3756 ELSEIF(MINT(111).NE.12) THEN
3757 C...Hadron remnants and primordial kT - old model.
3758 C...Happens e.g. for direct photon on one side.
3761 CALL PYREMN(IPU1,IPU2)
3762 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3764 IF(MINT(51).EQ.1) GOTO 100
3765 C...PYREMN does not set colour tags for BRs, so needs to be done now.
3766 DO 160 I=MINT(53)+1,N
3768 IDA=MOD(K(I,KCS),MSTU(5))
3770 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3776 C...Instruct PYPREP to use colour tags
3780 DO 350 I=MINT(84)+1,N
3782 C...Look for coloured string endpoint, or (later) leftover gluon.
3783 IF (K(I,1).NE.3) GOTO 350
3785 IF(KC.EQ.0) GOTO 350
3787 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
3789 C... Pick up loose string end with no previous tag.
3791 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
3792 IF(MCT(I,KCS-3).NE.0) GOTO 350
3794 CALL PYCTTR(I,KCS,I)
3795 IF(MINT(51).NE.0) RETURN
3799 C...Now delete any colour processing information if set (since partons
3800 C...otherwise not FS showered!)
3801 DO 170 I=MINT(84)+1,N
3803 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3804 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3809 C...Showering of final state partons (optional).
3812 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3815 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3816 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3817 C...External processes: handle successive showers.
3818 ELSEIF(ISET(ISUB).EQ.11) THEN
3823 C...Allow possibility for user to abort event generation.
3825 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
3827 C...........No reason to count this as an error
3833 C...Decay of final state resonances.
3835 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3837 IF(MINT(51).NE.0) GOTO 100
3840 IF(MINT(51).EQ.1) GOTO 100
3842 ELSEIF(ISUB.NE.99) THEN
3843 C...Diffractive and elastic scattering.
3847 C...DIS scattering (photon flux external).
3849 IF(MINT(51).EQ.1) GOTO 100
3852 C...Check that no odd resonance left undecayed.
3854 IF(MSTP(111).GE.1) THEN
3856 DO 180 I=MINT(84)+1,NFIX
3857 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3858 & K(I,2).NE.22) THEN
3860 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3862 IF(MINT(51).EQ.1) GOTO 100
3868 C...Boost hadronic subsystem to overall rest frame.
3869 C..(Only relevant when photon inside lepton beam.)
3870 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3872 C...Recalculate energies from momenta and masses (if desired).
3873 IF(MSTP(113).GE.1) THEN
3874 DO 190 I=MINT(83)+1,N
3875 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3876 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3881 C...Colour reconnection before string formation
3882 CALL PYFSCR(MINT(84)+1)
3884 C...Rearrange partons along strings, check invariant mass cuts.
3886 IF(MSTP(111).LE.0) MSTJ(14)=-1
3887 CALL PYPREP(MINT(84)+1)
3889 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3893 IF(MINT(51).EQ.1) GOTO 110
3894 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3895 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3896 DO 220 I=MINT(84)+1,N
3897 IF(K(I,2).EQ.94) THEN
3898 DO 210 I1=I+1,MIN(N,I+10)
3899 IF(K(I1,3).EQ.I) THEN
3900 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3901 IF(K(I1,3).EQ.0) THEN
3902 DO 200 II=MINT(84)+1,I-1
3903 IF(K(II,2).EQ.K(I1,2)) THEN
3904 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3905 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3908 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3912 CC...Also collapse particles decaying to themselves (if same KS)
3913 ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0
3914 & .AND.K(I,4).LT.N) THEN
3916 IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN
3923 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3924 IF(MSTP(125).EQ.0) MINT(4)=0
3925 DO 240 I=MINT(83)+1,N
3926 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3928 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3929 IF(K(I1,3).EQ.I) K(I,5)=I1
3935 C...Introduce separators between sections in PYLIST event listing.
3936 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3939 ELSEIF(IPILE.EQ.1) THEN
3946 C...Go back to lab frame (needed for vertices, also in fragmentation).
3949 C...Set nonvanishing production vertex (optional).
3950 IF(MSTP(151).EQ.1) THEN
3952 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3953 & SIN(PARU(2)*PYR(0))
3955 DO 270 I=MINT(83)+1,N
3957 V(I,J)=V(I,J)+VTX(J)
3962 C...Perform hadronization (if desired).
3963 IF(MSTP(111).GE.1) THEN
3965 IF(MSTU(24).NE.0) GOTO 100
3967 IF(MSTP(113).GE.1) THEN
3969 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3970 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3973 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3975 C...Store event information and calculate Monte Carlo estimates of
3976 C...subprocess cross-sections.
3977 290 IF(IPILE.EQ.1) CALL PYDOCU
3979 C...Set counters for current pileup event and loop to next one.
3981 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3982 IF(MSTU70.LT.10) THEN
3987 MINT(84)=N+MSTP(126)
3988 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3991 C...Generic information on pileup events. Reconstruct missing history.
3992 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3996 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
4000 C...Transform to the desired coordinate frame.
4001 310 CALL PYFRAM(MSTP(124))
4006 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4007 &1X,'Execution stopped.')
4013 C***********************************************************************
4016 C...Prints out information about cross-sections, decay widths, branching
4017 C...ratios, kinematical limits, status codes and parameter values.
4019 SUBROUTINE PYSTAT(MSTAT)
4021 C...Double precision and integer declarations.
4022 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4023 IMPLICIT INTEGER(I-N)
4024 INTEGER PYK,PYCHGE,PYCOMP
4025 C...Parameter statement to help give large particle numbers.
4026 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
4027 &KEXCIT=4000000,KDIMEN=5000000)
4028 PARAMETER (EPS=1D-3)
4030 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4031 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4032 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4033 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4034 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4035 COMMON/PYINT1/MINT(400),VINT(400)
4036 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4037 COMMON/PYINT4/MWID(500),WIDS(500,5)
4038 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4039 COMMON/PYINT6/PROC(0:500)
4040 CHARACTER PROC*28, CHTMP*16
4041 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
4042 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
4043 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4044 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
4045 C...Local arrays, character variables and data.
4046 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
4047 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
4048 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
4049 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
4050 CHARACTER*24 CHD0, CHDC(10)
4051 CHARACTER*6 DNAME(3)
4053 &'VMD/hadron * VMD ','VMD/hadron * direct ',
4054 &'VMD/hadron * anomalous ','direct * direct ',
4055 &'direct * anomalous ','anomalous * anomalous '/
4056 DATA DISGA/'e * VMD','e * anomalous'/
4058 &'direct * direct ','direct * VMD ',
4059 &'direct * anomalous ','VMD * direct ',
4060 &'VMD * VMD ','VMD * anomalous ',
4061 &'anomalous * direct ','anomalous * VMD ',
4062 &'anomalous * anomalous ','DIS * VMD ',
4063 &'DIS * anomalous ','VMD * DIS ',
4064 &'anomalous * DIS '/
4066 &'direct * direct ','direct * resolved ',
4067 &'resolved * direct ','resolved * resolved '/
4069 &'direct * hadron ','resolved * hadron '/
4071 &'VMD * hadron ','direct * hadron ',
4072 &'anomalous * hadron ','DIS * hadron '/
4073 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
4074 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
4075 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
4076 &' y*_small ',' eta*_large ',' eta*_small ',
4077 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
4078 &' x_2 ',' x_F ',' cos(theta_hard) ',
4079 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
4080 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
4082 DATA DNAME /'q ','lepton','nu '/
4086 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
4087 WRITE(MSTU(11),5000)
4088 WRITE(MSTU(11),5100)
4089 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
4091 IF(MSUB(I).NE.1) GOTO 100
4092 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
4094 IF(MINT(121).GT.1) THEN
4095 WRITE(MSTU(11),5300)
4096 DO 110 IGA=1,MINT(121)
4098 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4099 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
4101 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4102 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
4104 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
4105 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
4107 ELSEIF(MINT(121).EQ.4) THEN
4108 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
4110 ELSEIF(MINT(121).EQ.2) THEN
4111 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
4114 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
4120 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
4121 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
4123 C...Decay widths and branching ratios.
4124 ELSEIF(MSTAT.EQ.2) THEN
4125 WRITE(MSTU(11),5500)
4126 WRITE(MSTU(11),5600)
4129 CALL PYNAME(KF,CHKF)
4132 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
4133 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
4134 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
4135 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
4136 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
4138 IF(MWID(KC).LE.0) GOTO 140
4139 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
4140 & KF/KSUSY1.EQ.2)) GOTO 140
4142 C...Off-shell branchings.
4145 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
4146 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
4147 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
4148 DO 120 J=1,MDCY(KC,3)
4151 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4152 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4154 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4155 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4156 CALL PYNAME(KFDP(IDC,1),CHD1)
4157 CALL PYNAME(KFDP(IDC,2),CHD2)
4158 IF(KFDP(IDC,3).EQ.0) THEN
4159 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4160 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4161 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4163 CALL PYNAME(KFDP(IDC,3),CHD3)
4164 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4165 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4166 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4169 C...On-shell decays.
4171 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
4173 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
4174 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
4175 & STATE(MDCY(KC,1)),BRFIN
4176 DO 130 J=1,MDCY(KC,3)
4179 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4180 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4182 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4183 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4185 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
4187 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
4188 CALL PYNAME(KFDP(IDC,1),CHD1)
4189 CALL PYNAME(KFDP(IDC,2),CHD2)
4190 IF(KFDP(IDC,3).EQ.0) THEN
4191 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4192 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4193 & CHD2(1:10),WDTP(J),BRPRI,
4194 & STATE(MDME(IDC,1)),BRFIN
4196 CALL PYNAME(KFDP(IDC,3),CHD3)
4197 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4198 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4199 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
4200 & STATE(MDME(IDC,1)),BRFIN
4205 WRITE(MSTU(11),6000)
4207 C...Allowed incoming partons/particles at hard interaction.
4208 ELSEIF(MSTAT.EQ.3) THEN
4209 WRITE(MSTU(11),6100)
4210 CALL PYNAME(MINT(11),CHAU)
4212 CALL PYNAME(MINT(12),CHAU)
4214 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
4218 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
4219 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
4221 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
4224 WRITE(MSTU(11),6400)
4226 C...User-defined limits on kinematical variables.
4227 ELSEIF(MSTAT.EQ.4) THEN
4228 WRITE(MSTU(11),6500)
4229 WRITE(MSTU(11),6600)
4231 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
4232 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
4233 PTHMIN=MAX(CKIN(3),CKIN(5))
4235 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
4236 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
4237 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
4239 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
4242 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
4243 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
4244 WRITE(MSTU(11),7000)
4246 C...Status codes and parameter values.
4247 ELSEIF(MSTAT.EQ.5) THEN
4248 WRITE(MSTU(11),7100)
4249 WRITE(MSTU(11),7200)
4251 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4255 C...List of all processes implemented in the program.
4256 ELSEIF(MSTAT.EQ.6) THEN
4257 WRITE(MSTU(11),7400)
4258 WRITE(MSTU(11),7500)
4260 IF(ISET(I).LT.0) GOTO 180
4261 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4263 WRITE(MSTU(11),7700)
4265 ELSEIF(MSTAT.EQ.7) THEN
4266 WRITE (MSTU(11),8000)
4272 KFSUSY=ILR*KSUSY1+KFSM
4275 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4281 CALL PYNAME(KFSUSY,CHTMP)
4283 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4284 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4285 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4287 DO 200 J=1,MDCY(KC,3)
4289 ID1=IABS(KFDP(IDC,1))
4290 ID2=IABS(KFDP(IDC,2))
4291 IF (KFDP(IDC,3).EQ.0) THEN
4292 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4293 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4294 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4295 NMODES(1)=NMODES(1)+1
4296 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4297 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4298 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4299 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4300 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4301 NMODES(2)=NMODES(2)+1
4302 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4303 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4304 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4305 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4306 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4307 NMODES(3)=NMODES(3)+1
4308 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4309 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4315 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4321 CALL PYNAME(KFSUSY,CHTMP)
4323 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4324 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4326 DO 220 J=1,MDCY(KC,3)
4328 ID1=IABS(KFDP(IDC,1))
4329 ID2=IABS(KFDP(IDC,2))
4330 IF (KFDP(IDC,3).EQ.0) THEN
4331 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4332 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4333 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4334 NMODES(1)=NMODES(1)+1
4335 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4336 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4337 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4338 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4339 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4340 NMODES(2)=NMODES(2)+1
4341 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4342 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4348 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4354 CALL PYNAME(KFSUSY,CHTMP)
4356 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4357 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4359 DO 240 J=1,MDCY(KC,3)
4361 ID1=IABS(KFDP(IDC,1))
4362 ID2=IABS(KFDP(IDC,2))
4363 IF (KFDP(IDC,3).EQ.0) THEN
4364 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4365 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4366 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4367 NMODES(1)=NMODES(1)+1
4368 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4369 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4371 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4372 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4373 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4374 NMODES(2)=NMODES(2)+1
4375 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4376 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4381 C...SNEUTRINO DECAYS
4382 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4389 CALL PYNAME(KFSUSY,CHTMP)
4391 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4392 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4394 DO 260 J=1,MDCY(KC,3)
4396 ID1=IABS(KFDP(IDC,1))
4397 ID2=IABS(KFDP(IDC,2))
4398 IF (KFDP(IDC,3).EQ.0) THEN
4399 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4400 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4401 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4402 NMODES(1)=NMODES(1)+1
4403 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4404 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4406 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4407 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4408 NMODES(2)=NMODES(2)+1
4409 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4410 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4411 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4416 IF (NRVDC.NE.0) THEN
4418 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4419 NMODES(0)=NMODES(0)+NMODES(I)
4427 C...NEUTRALINO DECAYS
4428 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4434 CALL PYNAME(KFSUSY,CHTMP)
4436 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4437 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4438 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4439 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4441 DO 310 J=1,MDCY(KC,3)
4443 ID1=IABS(KFDP(IDC,1))
4444 ID2=IABS(KFDP(IDC,2))
4445 ID3=IABS(KFDP(IDC,3))
4446 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4447 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4448 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4449 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4450 NMODES(1)=NMODES(1)+1
4451 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4452 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4453 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4454 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4455 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4456 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4457 NMODES(2)=NMODES(2)+1
4458 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4459 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4460 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4461 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4462 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4463 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4464 NMODES(3)=NMODES(3)+1
4465 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4466 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4467 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4468 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4469 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4470 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4471 NMODES(4)=NMODES(4)+1
4472 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4473 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4478 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4484 CALL PYNAME(KFSUSY,CHTMP)
4486 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4487 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4488 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4489 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4490 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4492 DO 330 J=1,MDCY(KC,3)
4494 ID1=IABS(KFDP(IDC,1))
4495 ID2=IABS(KFDP(IDC,2))
4496 ID3=IABS(KFDP(IDC,3))
4497 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4498 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4499 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4500 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4501 NMODES(1)=NMODES(1)+1
4502 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4503 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4504 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4505 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4506 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4507 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4508 NMODES(1)=NMODES(1)+1
4509 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4510 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4511 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4512 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4513 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4514 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4515 NMODES(2)=NMODES(2)+1
4516 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4517 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4518 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4519 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4520 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4521 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4522 NMODES(3)=NMODES(3)+1
4523 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4524 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4525 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4526 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4527 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4528 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4529 NMODES(3)=NMODES(3)+1
4530 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4531 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4532 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4533 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4534 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4535 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4536 NMODES(4)=NMODES(4)+1
4537 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4538 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4539 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4540 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4541 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4542 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4543 NMODES(4)=NMODES(4)+1
4544 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4545 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4546 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4547 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4548 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4549 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4550 NMODES(5)=NMODES(5)+1
4551 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4552 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4553 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4554 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4555 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4556 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4557 NMODES(5)=NMODES(5)+1
4558 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4559 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4564 IF (KFSM.EQ.21) THEN
4570 CALL PYNAME(KFSUSY,CHTMP)
4572 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4573 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4574 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4576 DO 350 J=1,MDCY(KC,3)
4578 ID1=IABS(KFDP(IDC,1))
4579 ID2=IABS(KFDP(IDC,2))
4580 ID3=IABS(KFDP(IDC,3))
4581 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4582 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4583 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4584 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4585 NMODES(1)=NMODES(1)+1
4586 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4587 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4588 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4589 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4590 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4591 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4592 NMODES(2)=NMODES(2)+1
4593 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4594 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4595 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4596 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4597 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4598 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4599 NMODES(3)=NMODES(3)+1
4600 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4601 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4606 IF (NRVDC.NE.0) THEN
4608 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4609 NMODES(0)=NMODES(0)+NMODES(I)
4613 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4615 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4616 WRITE (MSTU(11),8500)
4620 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4621 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4625 WRITE (MSTU(11),8600)
4629 C...Formats for printouts.
4630 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4631 &'Events and Cross-sections',1X,9('*'))
4632 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4633 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4634 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4635 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4636 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4637 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4639 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4641 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4642 &1X,'I',34X,'I',28X,'I',12X,'I')
4643 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4644 &1X,'********* Total number of errors, excluding junctions =',
4645 &1X,I8,' *************'/
4646 &1X,'********* Total number of errors, including junctions =',
4647 &1X,I8,' *************'/
4648 &1X,'********* Total number of warnings = ',
4649 &1X,I8,' *************'/
4650 &1X,'********* Fraction of events that fail fragmentation ',
4651 &'cuts =',1X,F8.5,' *********'/)
4652 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4653 &'Ratios',1X,27('*'))
4654 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4655 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4656 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4657 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4659 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4660 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4661 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4662 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4663 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4664 &1P,D10.3,0P,1X,'I')
4665 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4666 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4667 &1P,D10.3,0P,1X,'I')
4668 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4669 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4670 &'Particles at Hard Interaction',1X,7('*'))
4671 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4672 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4673 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4674 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4675 &78('=')/1X,'I',38X,'I',37X,'I')
4676 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4677 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4678 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4679 &'Kinematical Variables',1X,12('*'))
4680 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4681 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4683 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4684 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4685 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4686 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4687 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4688 &'Parameter Values',1X,12('*'))
4689 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4691 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4692 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4694 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4695 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4696 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4697 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4698 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4700 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4701 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4702 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4703 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4704 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4705 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4706 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4707 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4708 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4710 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4711 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4712 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4714 & 1X,'R-Violating couplings',1X/ 1X /
4716 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4717 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4718 & ,'I',15X,'I',15X,'I',15X,'I')
4719 8600 FORMAT(1X,55('='))
4720 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4721 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4726 C*********************************************************************
4729 C...Administers the hard-process generation required for output to the
4730 C...Les Houches event record.
4734 C...Double precision and integer declarations.
4735 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4736 IMPLICIT INTEGER(I-N)
4737 INTEGER PYK,PYCHGE,PYCOMP
4740 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4741 COMMON/PYCTAG/NCT,MCT(4000,2)
4742 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4743 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4744 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4745 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4746 COMMON/PYINT1/MINT(400),VINT(400)
4747 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4748 COMMON/PYINT4/MWID(500),WIDS(500,5)
4749 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4750 &/PYINT1/,/PYINT2/,/PYINT4/
4752 C...HEPEUP for output.
4754 PARAMETER (MAXNUP=500)
4755 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4756 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4757 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4758 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4759 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4762 C...Stop if no subprocesses on.
4763 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4764 WRITE(MSTU(11),5100)
4768 C...Special flags for hard-process generation only.
4774 C...Initial values for some counters.
4785 C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4788 C...If variable energies: redo incoming kinematics and cross-section.
4790 IF(MSTP(171).EQ.1) THEN
4792 IF(MSTI(61).EQ.1) THEN
4796 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4800 C...Do not allow pileup events.
4803 C...Generate variables of hard scattering.
4807 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4812 IF(MSTI(61).EQ.1) THEN
4816 IF(MINT(51).EQ.2) RETURN
4819 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4820 C...Hard scattering (including low-pT):
4821 C...reconstruct kinematics and colour flow of hard scattering.
4826 IF(MINT(51).EQ.1) GOTO 100
4830 C...Decay of final state resonances.
4832 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4834 IF(MINT(51).EQ.1) GOTO 100
4837 C...Longitudinal boost of hard scattering.
4838 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4839 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4841 ELSEIF(ISUB.NE.99) THEN
4842 C...Diffractive and elastic scattering.
4846 C...DIS scattering (photon flux external).
4848 IF(MINT(51).EQ.1) GOTO 100
4851 C...Check that no odd resonance left undecayed.
4854 DO 120 I=MINT(84)+1,NFIX
4855 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4856 & K(I,2).NE.22) THEN
4858 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4860 IF(MINT(51).EQ.1) GOTO 100
4865 C...Boost hadronic subsystem to overall rest frame.
4866 C..(Only relevant when photon inside lepton beam.)
4867 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4869 C...Store event information and calculate Monte Carlo estimates of
4870 C...subprocess cross-sections.
4873 C...Transform to the desired coordinate frame.
4874 140 CALL PYFRAM(MSTP(124))
4878 C...Restore special flags for hard-process generation only.
4882 C...Trace colour tags; convert to LHA style labels.
4884 DO 150 I=MINT(84)+1,N
4888 DO 160 I=MINT(84)+1,N
4889 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4890 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4891 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4893 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4894 IDA=MOD(K(I,4),MSTU(5))
4895 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4896 & MCT(IMO,2).NE.0) THEN
4898 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4899 & MCT(IMO,1).NE.0) THEN
4901 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4902 & MCT(IDA,2).NE.0) THEN
4909 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4911 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4912 IDA=MOD(K(I,5),MSTU(5))
4913 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4914 & MCT(IMO,1).NE.0) THEN
4916 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4917 & MCT(IMO,2).NE.0) THEN
4919 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4920 & MCT(IDA,1).NE.0) THEN
4930 C...Put event in HEPEUP commonblock.
4938 IDUP(I)=K(I+MINT(84),2)
4943 ELSEIF(K(I+4,3).EQ.0) THEN
4949 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4952 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4953 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4954 ICOLUP(1,I)=MCT(I+MINT(84),1)
4955 ICOLUP(2,I)=MCT(I+MINT(84),2)
4957 PUP(J,I)=P(I+MINT(84),J)
4963 C...Optionally write out event to disk. Minimal size for time/spin fields.
4964 IF(MSTP(162).GT.0) THEN
4965 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4967 IF(VTIMUP(I).EQ.0D0) THEN
4968 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4969 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4972 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4973 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4978 C...Optional extra line with parton-density information.
4979 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4980 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4983 C...Error messages and other print formats.
4984 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4985 &1X,'Execution stopped.')
4986 5200 FORMAT(1P,2I6,4E14.6)
4987 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
4988 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
4989 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
4994 C*********************************************************************
4997 C...Fills the HEPRUP commonblock with info on incoming beams and allowed
4998 C...processes, and optionally stores that information on file.
5002 C...Double precision and integer declarations.
5003 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5004 IMPLICIT INTEGER(I-N)
5007 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5008 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5009 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5010 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5011 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
5013 C...User process initialization commonblock.
5015 PARAMETER (MAXPUP=100)
5016 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5017 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5018 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5019 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5023 C...Store info on incoming beams.
5033 C...Event weighting strategy.
5036 C...Info on individual processes.
5039 IF(MSUB(ISUB).EQ.1) THEN
5041 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
5042 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
5048 C...Write info to file.
5049 IF(MSTP(161).GT.0) THEN
5050 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
5051 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5053 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
5058 C...Formats for printout.
5059 5100 FORMAT(1P,2I8,2E14.6,6I6)
5060 5200 FORMAT(1P,3E14.6,I6)
5066 C*********************************************************************
5068 C...Combine the two old-style Pythia initialization and event files
5069 C...into a single Les Houches Event File.
5073 C...Double precision and integer declarations.
5074 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5075 IMPLICIT INTEGER(I-N)
5077 C...PYTHIA commonblock: only used to provide read/write units and version.
5078 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5081 C...User process initialization commonblock.
5083 PARAMETER (MAXPUP=100)
5084 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5085 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5086 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5087 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5091 C...User process event common block.
5093 PARAMETER (MAXNUP=500)
5094 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
5095 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
5096 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
5097 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
5098 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
5101 C...Lines to read in assumed never longer than 200 characters.
5102 PARAMETER (MAXLEN=200)
5103 CHARACTER*(MAXLEN) STRING
5105 C...Format for reading lines.
5108 WRITE(STRFMT(3:5),'(I3)') MAXLEN
5110 C...Rewind initialization and event files.
5114 C...Write header info.
5115 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
5116 WRITE(MSTP(163),'(A)') '<!--'
5117 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
5118 &MSTP(181),'.',MSTP(182)
5119 WRITE(MSTP(163),'(A)') '-->'
5121 C...Read first line of initialization info and get number of processes.
5122 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5123 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
5124 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5126 C...Copy initialization lines, omitting trailing blanks.
5127 C...Embed in <init> ... </init> block.
5128 WRITE(MSTP(163),'(A)') '<init>'
5130 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5133 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
5134 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5136 WRITE(MSTP(163),'(A)') '</init>'
5138 C...Begin event loop. Read first line of event info or already done.
5139 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
5142 C...Look at first line to know number of particles in event.
5143 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
5145 C...Begin an <event> block. Copy event lines, omitting trailing blanks.
5146 WRITE(MSTP(163),'(A)') '<event>'
5148 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
5151 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
5152 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5155 C...Copy trailing comment lines - with a # in the first column - as is.
5156 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
5157 IF(STRING(1:1).EQ.'#') THEN
5160 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
5161 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5165 C..End the <event> block. Loop back to look for next event.
5166 WRITE(MSTP(163),'(A)') '</event>'
5169 C...Successfully reached end of event loop: write closing tag
5170 C...and remove temporary intermediate files (unless asked not to).
5171 300 WRITE(MSTP(163),'(A)') '</event>'
5172 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
5173 IF(MSTP(164).EQ.1) RETURN
5174 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
5175 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
5179 400 WRITE(*,*) ' PYLHEF file joining failed!'
5184 C*********************************************************************
5187 C...Calculates full and effective widths of gauge bosons, stores
5188 C...masses and widths, rescales coefficients to be used for
5189 C...resonance production generation.
5193 C...Double precision and integer declarations.
5194 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5195 IMPLICIT INTEGER(I-N)
5196 INTEGER PYK,PYCHGE,PYCOMP
5197 C...Parameter statement to help give large particle numbers.
5198 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5199 &KEXCIT=4000000,KDIMEN=5000000)
5201 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5202 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5203 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5204 COMMON/PYDAT4/CHAF(500,2)
5206 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5207 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5208 COMMON/PYINT1/MINT(400),VINT(400)
5209 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5210 COMMON/PYINT4/MWID(500),WIDS(500,5)
5211 COMMON/PYINT6/PROC(0:500)
5213 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5214 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
5215 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
5216 C...Local arrays and data.
5217 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
5218 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
5220 C...Born level couplings in MSSM Higgs doublet sector.
5223 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
5225 IF(MSTP(4).EQ.2) THEN
5227 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
5231 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
5232 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
5234 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
5235 WRITE(MSTU(11),5000)
5238 PMAS(35,1)=SQRT(SQMHP)
5239 PMAS(36,1)=SQRT(SQMA)
5240 PMAS(37,1)=SQRT(SQMHC)
5241 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5246 PARU(161)=-SIN(ALSU)/COS(BESU)
5247 PARU(162)=COS(ALSU)/SIN(BESU)
5249 PARU(164)=SIN(BESU-ALSU)
5251 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5252 PARU(171)=COS(ALSU)/COS(BESU)
5253 PARU(172)=SIN(ALSU)/SIN(BESU)
5255 PARU(174)=COS(BESU-ALSU)
5257 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5259 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5260 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5266 PARU(186)=COS(BESU-ALSU)
5267 PARU(187)=SIN(BESU-ALSU)
5271 PARU(195)=COS(BESU-ALSU)
5274 C...Reset effective widths of gauge bosons.
5281 C...Order resonances by increasing mass (except Z0 and W+/-).
5285 IF(KF.EQ.0) GOTO 140
5286 IF(MWID(KC).EQ.0) GOTO 140
5287 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5288 IF(MSTP(1).LE.3) GOTO 140
5290 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5291 IF(IMSS(1).LE.0) GOTO 140
5295 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5296 DO 120 I1=NRES-1,1,-1
5297 IF(PMRES.GE.PMORD(I1)) GOTO 130
5298 KCORD(I1+1)=KCORD(I1)
5299 PMORD(I1+1)=PMORD(I1)
5305 C...Loop over possible resonances.
5310 C...Check that no fourth generation channels on by mistake.
5311 IF(MSTP(1).LE.3) THEN
5312 DO 150 J=1,MDCY(KC,3)
5314 KFA1=IABS(KFDP(IDC,1))
5315 KFA2=IABS(KFDP(IDC,2))
5316 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5317 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5322 C...Check that no supersymmetric channels on by mistake.
5323 IF(IMSS(1).LE.0) THEN
5324 DO 160 J=1,MDCY(KC,3)
5326 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5327 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5328 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5333 C...Find mass and evaluate width.
5335 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5336 IF(MWID(KC).EQ.3) MINT(63)=1
5337 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5340 C...Evaluate suppression factors due to non-simulated channels.
5341 IF(KCHG(KC,3).EQ.0) THEN
5343 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5344 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5345 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5346 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5347 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5352 IF(MWID(KC).EQ.3) MINT(63)=1
5353 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5356 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5357 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5358 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5359 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5360 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5361 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5362 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5363 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5364 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5365 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5366 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5367 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5368 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5371 C...Set resonance widths and branching ratios;
5372 C...also on/off switch for decays.
5373 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5375 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5376 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5377 DO 170 J=1,MDCY(KC,3)
5380 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5385 C...Flavours of leptoquark: redefine charge and name.
5386 KFLQQ=KFDP(MDCY(42,2),1)
5387 KFLQL=KFDP(MDCY(42,2),2)
5388 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5389 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5391 IF(IABS(KFLQL).EQ.13) LL=2
5392 IF(IABS(KFLQL).EQ.15) LL=3
5393 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5394 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5395 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5397 C...Special cases in treatment of gamma*/Z0: redefine process name.
5398 IF(MSTP(43).EQ.1) THEN
5399 PROC(1)='f + fbar -> gamma*'
5400 PROC(15)='f + fbar -> g + gamma*'
5401 PROC(19)='f + fbar -> gamma + gamma*'
5402 PROC(30)='f + g -> f + gamma*'
5403 PROC(35)='f + gamma -> f + gamma*'
5404 ELSEIF(MSTP(43).EQ.2) THEN
5405 PROC(1)='f + fbar -> Z0'
5406 PROC(15)='f + fbar -> g + Z0'
5407 PROC(19)='f + fbar -> gamma + Z0'
5408 PROC(30)='f + g -> f + Z0'
5409 PROC(35)='f + gamma -> f + Z0'
5410 ELSEIF(MSTP(43).EQ.3) THEN
5411 PROC(1)='f + fbar -> gamma*/Z0'
5412 PROC(15)='f + fbar -> g + gamma*/Z0'
5413 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5414 PROC(30)='f + g -> f + gamma*/Z0'
5415 PROC(35)='f + gamma -> f + gamma*/Z0'
5418 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5419 IF(MSTP(44).EQ.1) THEN
5420 PROC(141)='f + fbar -> gamma*'
5421 ELSEIF(MSTP(44).EQ.2) THEN
5422 PROC(141)='f + fbar -> Z0'
5423 ELSEIF(MSTP(44).EQ.3) THEN
5424 PROC(141)='f + fbar -> Z''0'
5425 ELSEIF(MSTP(44).EQ.4) THEN
5426 PROC(141)='f + fbar -> gamma*/Z0'
5427 ELSEIF(MSTP(44).EQ.5) THEN
5428 PROC(141)='f + fbar -> gamma*/Z''0'
5429 ELSEIF(MSTP(44).EQ.6) THEN
5430 PROC(141)='f + fbar -> Z0/Z''0'
5431 ELSEIF(MSTP(44).EQ.7) THEN
5432 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5435 C...Special cases in treatment of WW -> WW: redefine process name.
5436 IF(MSTP(45).EQ.1) THEN
5437 PROC(77)='W+ + W+ -> W+ + W+'
5438 ELSEIF(MSTP(45).EQ.2) THEN
5439 PROC(77)='W+ + W- -> W+ + W-'
5440 ELSEIF(MSTP(45).EQ.3) THEN
5441 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5444 C...Format for error information.
5445 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5446 &'combination'/1X,'Execution stopped!')
5451 C*********************************************************************
5454 C...Identifies the two incoming particles and the choice of frame.
5456 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5458 C...Double precision and integer declarations.
5459 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5460 IMPLICIT INTEGER(I-N)
5461 INTEGER PYK,PYCHGE,PYCOMP
5463 C...User process initialization commonblock.
5465 PARAMETER (MAXPUP=100)
5466 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5467 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5468 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5469 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5474 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5475 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5476 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5477 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5478 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5479 COMMON/PYINT1/MINT(400),VINT(400)
5480 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5482 C...Local arrays, character variables and data.
5483 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5484 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5485 DIMENSION LEN(3),KCDE(39),PM(2)
5486 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5487 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5488 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5489 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5490 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5491 &'nu_taubar ','pi+ ','pi- ','n0 ',
5492 &'nbar0 ','p+ ','pbar- ','gamma ',
5493 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5494 &'xi- ','xi0 ','omega- ','pi0 ',
5495 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5496 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5497 &'k+ ','k- ','ks0 ','kl0 '/
5498 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5499 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5500 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5502 C...Store initial energy. Default frame.
5506 C...Special user process initialization; convert to normal input.
5507 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5509 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5510 CALL PYNAME(IDBMUP(1),CHNAME)
5512 CALL PYNAME(IDBMUP(2),CHNAME)
5516 C...Convert character variables to lowercase and find their length.
5523 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5525 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5531 C...Fix up bar, underscore and charge in particle name (if needed).
5533 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5535 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5538 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5540 CHIDNT(I)='nu_'//CHTEMP(3:7)
5541 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5542 CHIDNT(I)(1:3)='n0 '
5543 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5544 CHIDNT(I)(1:5)='nbar0'
5545 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5546 CHIDNT(I)(1:3)='p+ '
5547 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5548 & CHIDNT(I)(1:2).EQ.'p-') THEN
5549 CHIDNT(I)(1:5)='pbar-'
5550 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5552 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5553 CHIDNT(I)(1:7)='reggeon'
5554 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5555 CHIDNT(I)(1:7)='pomeron'
5559 C...Identify free initialization.
5560 IF(CHCOM(1)(1:2).EQ.'no') THEN
5565 C...Identify incoming beam and target particles.
5568 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5570 PM(I)=PYMASS(MINT(10+I))
5573 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5574 CHTEMP=CHIDNT(I+1)(7:12)//' '
5576 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5578 PM(I)=PYMASS(MINT(140+I))
5582 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5583 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5584 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
5586 C...Identify choice of frame and input energies.
5589 C...Events defined in the CM frame.
5590 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5593 IF(MSTP(122).GE.1) THEN
5594 IF(CHCOM(2)(1:1).NE.'e') THEN
5595 LOFFS=(31-(LEN(2)+LEN(3)))/2
5596 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5597 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5600 LOFFS=(30-(LEN(2)+LEN(3)))/2
5601 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5602 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5605 WRITE(MSTU(11),5200) CHINIT
5606 WRITE(MSTU(11),5300) WIN
5609 C...Events defined in fixed target frame.
5610 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5612 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5613 IF(MSTP(122).GE.1) THEN
5614 LOFFS=(29-(LEN(2)+LEN(3)))/2
5615 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5616 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5617 & ' fixed target'//' '
5618 WRITE(MSTU(11),5200) CHINIT
5619 WRITE(MSTU(11),5400) WIN
5620 WRITE(MSTU(11),5500) SQRT(S)
5623 C...Frame defined by user three-vectors.
5624 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5628 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5629 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5630 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5631 & (P(1,3)+P(2,3))**2
5632 IF(MSTP(122).GE.1) THEN
5633 LOFFS=(22-(LEN(2)+LEN(3)))/2
5634 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5635 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5636 & ' user configuration'//' '
5637 WRITE(MSTU(11),5200) CHINIT
5638 WRITE(MSTU(11),5600)
5639 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5640 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5641 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5644 C...Frame defined by user four-vectors.
5645 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5647 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5648 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5649 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5650 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5651 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5652 & (P(1,3)+P(2,3))**2
5653 IF(MSTP(122).GE.1) THEN
5654 LOFFS=(22-(LEN(2)+LEN(3)))/2
5655 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5656 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5657 & ' user configuration'//' '
5658 WRITE(MSTU(11),5200) CHINIT
5659 WRITE(MSTU(11),5600)
5660 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5661 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5662 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5665 C...Frame defined by user five-vectors.
5666 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5668 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5669 & (P(1,3)+P(2,3))**2
5670 IF(MSTP(122).GE.1) THEN
5671 LOFFS=(22-(LEN(2)+LEN(3)))/2
5672 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5673 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5674 & ' user configuration'//' '
5675 WRITE(MSTU(11),5200) CHINIT
5676 WRITE(MSTU(11),5600)
5677 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5678 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5679 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5682 C...Frame defined by HEPRUP common block.
5683 ELSEIF(MINT(111).GE.11) THEN
5684 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5685 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5686 IF(MSTP(122).GE.1) THEN
5687 LOFFS=(22-(LEN(2)+LEN(3)))/2
5688 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5689 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5690 & ' user configuration'//' '
5691 WRITE(MSTU(11),5200) CHINIT
5692 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5693 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5696 C...Unknown frame. Error for too low CM energy.
5698 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5701 IF(S.LT.PARP(2)**2) THEN
5702 WRITE(MSTU(11),5900) SQRT(S)
5706 C...Formats for initialization and error information.
5707 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5708 &1X,'Execution stopped!')
5709 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5710 &1X,'Execution stopped!')
5711 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5712 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5713 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5714 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5715 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5716 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5717 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5718 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5719 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5720 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5721 &1X,'Execution stopped!')
5722 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5723 &'generation.'/1X,'Execution stopped!')
5724 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5725 &'GeV beam energies',13X,'I')
5730 C*********************************************************************
5733 C...Sets up kinematics, including rotations and boosts to/from CM frame.
5735 SUBROUTINE PYINKI(MODKI)
5737 C...Double precision and integer declarations.
5738 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5739 IMPLICIT INTEGER(I-N)
5740 INTEGER PYK,PYCHGE,PYCOMP
5742 C...User process initialization commonblock.
5744 PARAMETER (MAXPUP=100)
5745 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5746 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5747 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5748 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5753 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5754 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5755 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5756 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5757 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5758 COMMON/PYINT1/MINT(400),VINT(400)
5759 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5761 C...Set initial flavour state.
5766 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5769 C...Reset boost. Do kinematics for various cases.
5774 C...Set up kinematics for events defined in CM frame.
5775 IF(MINT(111).EQ.1) THEN
5777 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5781 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5782 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5787 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5790 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5791 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5793 C...Set up kinematics for fixed target events.
5794 ELSEIF(MINT(111).EQ.2) THEN
5796 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5799 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5800 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5806 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5809 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5810 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5811 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5813 C...Set up kinematics for events in user-defined frame.
5814 ELSEIF(MINT(111).EQ.3) THEN
5817 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5818 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5819 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5820 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5822 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5824 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5825 VINT(7)=PYANGL(P(1,1),P(1,2))
5826 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5827 VINT(6)=PYANGL(P(1,3),P(1,1))
5828 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5829 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5831 C...Set up kinematics for events with user-defined four-vectors.
5832 ELSEIF(MINT(111).EQ.4) THEN
5833 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5834 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5835 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5836 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5838 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5840 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5841 VINT(7)=PYANGL(P(1,1),P(1,2))
5842 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5843 VINT(6)=PYANGL(P(1,3),P(1,1))
5844 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5845 S=(P(1,4)+P(2,4))**2
5847 C...Set up kinematics for events with user-defined five-vectors.
5848 ELSEIF(MINT(111).EQ.5) THEN
5850 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5852 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5853 VINT(7)=PYANGL(P(1,1),P(1,2))
5854 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5855 VINT(6)=PYANGL(P(1,3),P(1,1))
5856 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5857 S=(P(1,4)+P(2,4))**2
5859 C...Set up kinematics for events with external user processes.
5860 ELSEIF(MINT(111).GE.11) THEN
5863 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5864 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5869 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5870 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5873 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5874 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5875 S=(P(1,4)+P(2,4))**2
5878 C...Return or error for too low CM energy.
5879 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5880 IF(MSTP(172).LE.1) THEN
5882 & '(PYINKI:) too low invariant mass in this event')
5889 C...Save information on incoming particles.
5892 IF(MINT(111).GE.4) THEN
5893 IF(MINT(141).EQ.0) THEN
5895 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5899 IF(MINT(142).EQ.0) THEN
5901 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5907 IF(MODKI.EQ.0) VINT(289)=S
5915 C...Store pT cut-off and related constants to be used in generation.
5916 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5917 IF(MSTP(82).LE.1) THEN
5918 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5920 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5922 VINT(149)=4D0*PTMN**2/S
5928 C*********************************************************************
5931 C...Selects partonic subprocesses to be included in the simulation.
5935 C...Double precision and integer declarations.
5936 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5937 IMPLICIT INTEGER(I-N)
5938 INTEGER PYK,PYCHGE,PYCOMP
5940 C...User process initialization commonblock.
5942 PARAMETER (MAXPUP=100)
5943 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5944 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5945 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5946 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5950 C...Commonblocks and character variables.
5951 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5952 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5953 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5954 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5955 COMMON/PYINT1/MINT(400),VINT(400)
5956 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5957 COMMON/PYINT6/PROC(0:500)
5959 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
5963 C...Reset processes to be included.
5970 C...Set running pTmin scale.
5971 IF(MSTP(82).LE.1) THEN
5972 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5974 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5977 C...Begin by assuming incoming photon to enter subprocess.
5978 IF(MINT(11).EQ.22) MINT(15)=22
5979 IF(MINT(12).EQ.22) MINT(16)=22
5981 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
5982 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
5984 MINT(123)=MINT(122)+1
5986 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
5988 C...Here also set a few parameters otherwise normally not touched.
5989 ELSEIF(MINT(121).GT.1) THEN
5991 C...Parton distributions dampened at small Q2; go to low energies,
5992 C...alpha_s <1; no minimum pT cut-off a priori.
5993 IF(MSTP(18).EQ.2) THEN
6001 C...Define pT cut-off parameters and whether run involves low-pT.
6005 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6007 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
6008 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
6010 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
6011 IF(MSEL.EQ.2) IPTL=1
6013 C...Set up for p/gamma * gamma; real or virtual photons.
6014 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
6015 & MSTP(14).EQ.30)) THEN
6017 C...Set up for p/VMD * VMD.
6018 IF(MINT(122).EQ.1) THEN
6026 IF(IPTL.EQ.1) MSUB(95)=1
6033 IF(IPTL.EQ.1) CKIN(3)=0D0
6035 C...Set up for p/VMD * direct gamma.
6036 ELSEIF(MINT(122).EQ.2) THEN
6038 IF(MINT(121).EQ.6) MINT(123)=5
6043 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6045 C...Set up for p/VMD * anomalous gamma.
6046 ELSEIF(MINT(122).EQ.3) THEN
6048 IF(MINT(121).EQ.6) MINT(123)=7
6055 IF(IPTL.EQ.1) MSUB(95)=1
6062 IF(IPTL.EQ.1) CKIN(3)=0D0
6064 C...Set up for DIS * p.
6065 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
6066 & IABS(MINT(12)).GT.100)) THEN
6068 IF(IPTL.EQ.1) MSUB(99)=1
6070 C...Set up for direct * direct gamma (switch off leptons).
6071 ELSEIF(MINT(122).EQ.4) THEN
6077 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6078 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6080 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6082 C...Set up for direct * anomalous gamma.
6083 ELSEIF(MINT(122).EQ.5) THEN
6089 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6091 C...Set up for anomalous * anomalous gamma.
6092 ELSEIF(MINT(122).EQ.6) THEN
6100 IF(IPTL.EQ.1) MSUB(95)=1
6107 IF(IPTL.EQ.1) CKIN(3)=0D0
6110 C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
6111 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6113 C...Set up for direct * direct gamma (switch off leptons).
6114 IF(MINT(122).EQ.1) THEN
6120 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6121 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6123 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6125 C...Set up for direct * VMD and VMD * direct gamma.
6126 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
6132 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6134 C...Set up for direct * anomalous and anomalous * direct gamma.
6135 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
6141 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6143 C...Set up for VMD*VMD.
6144 ELSEIF(MINT(122).EQ.5) THEN
6152 IF(IPTL.EQ.1) MSUB(95)=1
6159 IF(IPTL.EQ.1) CKIN(3)=0D0
6161 C...Set up for VMD * anomalous and anomalous * VMD gamma.
6162 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
6170 IF(IPTL.EQ.1) MSUB(95)=1
6177 IF(IPTL.EQ.1) CKIN(3)=0D0
6179 C...Set up for anomalous * anomalous gamma.
6180 ELSEIF(MINT(122).EQ.9) THEN
6188 IF(IPTL.EQ.1) MSUB(95)=1
6195 IF(IPTL.EQ.1) CKIN(3)=0D0
6197 C...Set up for DIS * VMD and VMD * DIS gamma.
6198 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
6200 IF(IPTL.EQ.1) MSUB(99)=1
6202 C...Set up for DIS * anomalous and anomalous * DIS gamma.
6203 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
6205 IF(IPTL.EQ.1) MSUB(99)=1
6208 C...Set up for gamma* * p; virtual photons = dir, res.
6209 ELSEIF(MINT(121).EQ.2) THEN
6211 C...Set up for direct * p.
6212 IF(MINT(122).EQ.1) THEN
6218 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6220 C...Set up for resolved * p.
6221 ELSEIF(MINT(122).EQ.2) THEN
6229 IF(IPTL.EQ.1) MSUB(95)=1
6236 IF(IPTL.EQ.1) CKIN(3)=0D0
6239 C...Set up for gamma* * gamma*; virtual photons = dir, res.
6240 ELSEIF(MINT(121).EQ.4) THEN
6242 C...Set up for direct * direct gamma (switch off leptons).
6243 IF(MINT(122).EQ.1) THEN
6249 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6250 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6252 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6254 C...Set up for direct * resolved and resolved * direct gamma.
6255 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6261 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6263 C...Set up for resolved * resolved gamma.
6264 ELSEIF(MINT(122).EQ.4) THEN
6272 IF(IPTL.EQ.1) MSUB(95)=1
6279 IF(IPTL.EQ.1) CKIN(3)=0D0
6282 C...End of special set up for gamma-p and gamma-gamma.
6287 C...Flavour information for individual beams.
6290 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6291 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6292 MINT(44+I)=MINT(40+I)
6293 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6294 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6297 C...If two real gammas, whereof one direct, pick the first.
6298 C...For two virtual photons, keep requested order.
6299 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6300 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6303 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6304 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6307 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6308 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6311 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6312 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6315 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6316 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6319 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6322 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6326 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6327 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6328 IF(MINT(11).EQ.22) THEN
6336 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6337 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6340 C...Flavour information on combination of incoming particles.
6341 MINT(43)=2*MINT(41)+MINT(42)-2
6343 IF(MINT(123).LE.0) THEN
6344 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6345 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6346 ELSEIF(MINT(123).LE.3) THEN
6347 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6348 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6349 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6353 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6354 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6355 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6356 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6358 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6361 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6362 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6364 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6366 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6367 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6368 & MINT(122).EQ.10) MINT(108)=2
6369 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6370 & MINT(122).EQ.11) MINT(108)=3
6371 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6372 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6373 IF(MINT(122).GE.3) MINT(107)=1
6374 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6375 ELSEIF(MINT(121).EQ.2) THEN
6376 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6377 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6379 IF(MINT(11).EQ.22) THEN
6381 IF(MINT(123).GE.4) MINT(107)=0
6382 IF(MINT(123).EQ.7) MINT(107)=2
6383 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6384 IF(MSTP(14).EQ.28) MINT(107)=2
6385 IF(MSTP(14).EQ.29) MINT(107)=3
6386 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6389 IF(MINT(12).EQ.22) THEN
6391 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6392 IF(MINT(123).EQ.7) MINT(108)=3
6393 IF(MSTP(14).EQ.26) MINT(108)=2
6394 IF(MSTP(14).EQ.27) MINT(108)=3
6395 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6396 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6399 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6400 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6406 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6407 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6409 C...Select default processes according to incoming beams
6410 C...(already done for gamma-p and gamma-gamma with
6411 C...MSTP(14) = 10, 20, 25 or 30).
6412 IF(MINT(121).GT.1) THEN
6413 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6415 IF(MINT(43).EQ.1) THEN
6416 C...Lepton + lepton -> gamma/Z0 or W.
6417 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6418 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6420 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6421 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6422 C...Unresolved photon + lepton: Compton scattering.
6426 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6427 & .OR.MINT(12).EQ.22)) THEN
6428 C...DIS as pure gamma* + f -> f process.
6431 ELSEIF(MINT(43).LE.3) THEN
6432 C...Lepton + hadron: deep inelastic scattering.
6435 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6436 & MINT(12).EQ.22) THEN
6437 C...Two unresolved photons: fermion pair production,
6438 C...exclude lepton pairs.
6442 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6443 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6446 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6447 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6448 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6450 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6451 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6452 & MINT(12).EQ.22)) THEN
6453 C...Unresolved photon + hadron: photon-parton scattering.
6458 ELSEIF(MSEL.EQ.1) THEN
6459 C...High-pT QCD processes:
6468 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6469 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6472 C...All QCD processes:
6486 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6487 C...Heavy quark production.
6491 DO 180 J=1,MIN(8,MDCY(21,3))
6492 MDME(MDCY(21,2)+J-1,1)=0
6494 MDME(MDCY(21,2)+MSEL-1,1)=1
6496 DO 190 J=1,MIN(12,MDCY(22,3))
6497 MDME(MDCY(22,2)+J-1,1)=0
6499 MDME(MDCY(22,2)+MSEL-1,1)=1
6501 ELSEIF(MSEL.EQ.10) THEN
6502 C...Prompt photon production:
6507 ELSEIF(MSEL.EQ.11) THEN
6508 C...Z0/gamma* production:
6511 ELSEIF(MSEL.EQ.12) THEN
6512 C...W+/- production:
6515 ELSEIF(MSEL.EQ.13) THEN
6520 ELSEIF(MSEL.EQ.14) THEN
6525 ELSEIF(MSEL.EQ.15) THEN
6526 C...Z0 & W+/- pair production:
6533 ELSEIF(MSEL.EQ.16) THEN
6541 ELSEIF(MSEL.EQ.17) THEN
6542 C...h0 & Z0 or W+/- pair production:
6546 ELSEIF(MSEL.EQ.18) THEN
6547 C...h0 production; interesting processes in e+e-.
6553 ELSEIF(MSEL.EQ.19) THEN
6554 C...h0, H0 and A0 production; interesting processes in e+e-.
6568 ELSEIF(MSEL.EQ.21) THEN
6572 ELSEIF(MSEL.EQ.22) THEN
6573 C...W'+/- production:
6576 ELSEIF(MSEL.EQ.23) THEN
6577 C...H+/- production:
6580 ELSEIF(MSEL.EQ.24) THEN
6584 ELSEIF(MSEL.EQ.25) THEN
6585 C...LQ (leptoquark) production.
6591 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6592 C...Production of one heavy quark (W exchange):
6594 DO 200 J=1,MIN(8,MDCY(21,3))
6595 MDME(MDCY(21,2)+J-1,1)=0
6597 MDME(MDCY(21,2)+MSEL-31,1)=1
6599 CMRENNA++Define SUSY alternatives.
6600 ELSEIF(MSEL.EQ.39) THEN
6601 C...Turn on all SUSY processes.
6602 IF(MINT(43).EQ.4) THEN
6603 C...Hadron-hadron processes.
6605 IF(ISET(I).GE.0) MSUB(I)=1
6607 ELSEIF(MINT(43).EQ.1) THEN
6608 C...Lepton-lepton processes: QED production of squarks.
6625 ELSEIF(MSEL.EQ.40) THEN
6626 C...Gluinos and squarks.
6627 IF(MINT(43).EQ.4) THEN
6639 ELSEIF(MINT(43).EQ.1) THEN
6644 ELSEIF(MSEL.EQ.41) THEN
6645 C...Stop production.
6649 IF(MINT(43).EQ.4) THEN
6654 ELSEIF(MSEL.EQ.42) THEN
6655 C...Slepton production.
6659 IF(MINT(43).NE.4) THEN
6665 ELSEIF(MSEL.EQ.43) THEN
6666 C...Neutralino/Chargino + Gluino/Squark.
6667 IF(MINT(43).EQ.4) THEN
6677 ELSEIF(MSEL.EQ.44) THEN
6678 C...Neutralino/Chargino pair production.
6679 IF(MINT(43).EQ.4) THEN
6683 ELSEIF(MINT(43).EQ.1) THEN
6689 ELSEIF(MSEL.EQ.45) THEN
6690 C...Sbottom production.
6693 IF(MINT(43).EQ.4) THEN
6699 ELSEIF(MSEL.EQ.50) THEN
6700 C...Pair production of technipions and gauge bosons.
6704 IF(MINT(43).EQ.4) THEN
6710 ELSEIF(MSEL.EQ.51) THEN
6711 C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6716 ELSEIF(MSEL.EQ.61) THEN
6717 C...Charmonium production in colour octet model, with recoiling parton.
6722 ELSEIF(MSEL.EQ.62) THEN
6723 C...Bottomonium production in colour octet model, with recoiling parton.
6728 ELSEIF(MSEL.EQ.63) THEN
6729 C...Charmonium and bottomonium production in colour octet model.
6736 C...Find heaviest new quark flavour allowed in processes 81-84.
6738 DO 350 I=1,MIN(8,MDCY(21,3))
6740 IF(MDME(IDC,1).LE.0) GOTO 350
6743 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6754 C...Find heaviest new fermion flavour allowed in process 85.
6756 DO 360 I=1,MIN(12,MDCY(22,3))
6758 IF(MDME(IDC,1).LE.0) GOTO 360
6761 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6762 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6767 C...Import relevant information on external user processes.
6768 IF(MINT(111).GE.11) THEN
6771 C...Find next empty PYTHIA process number slot and enable it.
6773 IF(IPYPR.GT.500) CALL PYERRM(26,
6774 & '(PYINPR.) no more empty slots for user processes')
6775 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6776 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6778 C...Overwrite KFPR with references back to process number and ID.
6780 KFPR(IPYPR,2)=LPRUP(IUP)
6782 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6785 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6787 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6788 C...Switch on process.
6796 C*********************************************************************
6799 C...Parametrizes total, elastic and diffractive cross-sections
6800 C...for different energies and beams. Donnachie-Landshoff for
6801 C...total and Schuler-Sjostrand for elastic and diffractive.
6802 C...Process code IPROC:
6809 C...= 7 : J/psi + p;
6810 C...= 11 : rho + rho;
6811 C...= 12 : rho + phi;
6812 C...= 13 : rho + J/psi;
6813 C...= 14 : phi + phi;
6814 C...= 15 : phi + J/psi;
6815 C...= 16 : J/psi + J/psi;
6816 C...= 21 : gamma + p (DL);
6817 C...= 22 : gamma + p (VDM).
6818 C...= 23 : gamma + pi (DL);
6819 C...= 24 : gamma + pi (VDM);
6820 C...= 25 : gamma + gamma (DL);
6821 C...= 26 : gamma + gamma (VDM).
6825 C...Double precision and integer declarations.
6826 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6827 IMPLICIT INTEGER(I-N)
6828 INTEGER PYK,PYCHGE,PYCOMP
6830 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6831 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6832 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6833 COMMON/PYINT1/MINT(400),VINT(400)
6834 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6835 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6836 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6838 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6839 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6840 &CEFFD(10,9),SIGTMP(6,0:5)
6842 C...Common constants.
6843 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6844 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6847 C...Number of multiple processes to be evaluated (= 0 : undefined).
6848 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6849 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6850 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6851 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6852 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6854 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6855 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6856 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6858 C...Beam and target hadron class:
6859 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6860 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6861 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6862 C...Characteristic class masses, slope parameters, beta = sqrt(X).
6863 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6864 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6865 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6867 C...Fitting constants used in parametrizations of diffractive results.
6868 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6869 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6870 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6871 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6872 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6873 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6874 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6875 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6876 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6877 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6878 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6879 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6880 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6881 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6882 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6883 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6884 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6885 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6886 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6887 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6888 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6889 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6890 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6891 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6892 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6893 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6894 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6895 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6896 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6898 C...Parameters. Combinations of the energy.
6907 C...Ratio of gamma/pi (for rescaling in parton distributions).
6908 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
6909 &(XPAR(5)*SEPS+YPAR(5)*SETA)
6911 IF(MINT(50).NE.1) RETURN
6913 C...Order flavours of incoming particles: KF1 < KF2.
6914 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
6923 ISGN12=ISIGN(1,MINT(11)*MINT(12))
6925 C...Find process number (for lookup tables).
6926 IF(KF1.GT.1000) THEN
6928 IF(ISGN12.LT.0) IPROC=2
6929 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
6931 IF(ISGN12.LT.0) IPROC=4
6932 IF(KF1.EQ.111) IPROC=5
6933 ELSEIF(KF1.GT.100) THEN
6935 ELSEIF(KF2.GT.1000) THEN
6937 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
6938 ELSEIF(KF2.GT.100) THEN
6940 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
6943 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
6946 C... Number of multiple processes to be stored; beam/target side.
6952 ELSEIF(NPR.EQ.6) THEN
6957 IF(MINT(101).EQ.4) N1=4
6959 IF(MINT(102).EQ.4) N2=4
6961 C...Do not do any more for user-set or undefined cross-sections.
6962 IF(MSTP(31).LE.0) RETURN
6963 IF(NPR.EQ.0) CALL PYERRM(26,
6964 &'(PYXTOT:) cross section for this process not yet implemented')
6966 C...Parameters. Combinations of the energy.
6975 C...Loop over multiple processes (for VDM).
6979 ELSEIF(NPR.EQ.3) THEN
6981 IF(KF2.LT.1000) IPR=I+10
6982 ELSEIF(NPR.EQ.6) THEN
6986 C...Evaluate hadron species, mass, slope contribution and fit number.
6996 C...Skip if energy too low relative to masses.
7000 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
7002 C...Total cross-section. Elastic slope parameter and cross-section.
7003 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
7004 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
7005 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
7007 C...Diffractive scattering A + B -> X + B.
7010 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
7011 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7012 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7013 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
7014 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
7015 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
7016 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
7018 C...Diffractive scattering A + B -> A + X.
7021 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
7022 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7023 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7024 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
7025 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
7026 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
7027 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
7029 C...Order single diffractive correctly.
7032 SIGTMP(I,2)=SIGTMP(I,3)
7036 C...Double diffractive scattering A + B -> X1 + X2.
7037 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
7038 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
7039 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
7040 IF(YEFF.LE.0) SUM1=0D0
7041 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
7042 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
7043 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
7044 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
7046 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
7047 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
7048 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
7050 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
7051 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
7052 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
7053 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
7054 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
7056 C...Non-diffractive by unitarity.
7057 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
7061 C...Put temporary results in output array: only one process.
7062 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
7064 SIGT(0,0,J)=SIGTMP(1,J)
7067 C...Beam multiple processes.
7068 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
7069 IF(MINT(107).EQ.2) THEN
7070 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7072 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7073 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7075 IF(MSTP(20).GT.0) THEN
7076 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
7079 IF(MINT(107).EQ.2) THEN
7080 CONV=(AEM/PARP(160+I))*VINT(317)
7081 ELSEIF(VINT(154).GT.PARP(15)) THEN
7082 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7083 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7089 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
7093 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7096 C...Target multiple processes.
7097 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
7098 IF(MINT(108).EQ.2) THEN
7099 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7101 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7102 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7104 IF(MSTP(20).GT.0) THEN
7105 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
7108 IF(MINT(108).EQ.2) THEN
7109 CONV=(AEM/PARP(160+I))*VINT(317)
7110 ELSEIF(VINT(154).GT.PARP(15)) THEN
7111 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7112 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7118 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
7122 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
7125 C...Both beam and target multiple processes.
7127 IF(MINT(107).EQ.2) THEN
7128 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7130 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7131 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7133 IF(MINT(108).EQ.2) THEN
7134 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7136 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
7137 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7139 IF(MSTP(20).GT.0) THEN
7140 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
7141 & VINT(308)))**MSTP(20)
7145 IF(MINT(107).EQ.2) THEN
7146 CONV=(AEM/PARP(160+I1))*VINT(317)
7147 ELSEIF(VINT(154).GT.PARP(15)) THEN
7148 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
7149 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7153 IF(MINT(108).EQ.2) THEN
7154 CONV=CONV*(AEM/PARP(160+I2))
7155 ELSEIF(VINT(154).GT.PARP(15)) THEN
7156 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
7157 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
7163 ELSEIF(I2.LE.2) THEN
7165 ELSEIF(I1.EQ.I2) THEN
7172 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
7173 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
7179 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
7180 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
7182 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7186 C...Scale up uniformly for Donnachie-Landshoff parametrization.
7187 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
7188 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
7192 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
7201 C*********************************************************************
7204 C...Finds optimal set of coefficients for kinematical variable selection
7205 C...and the maximum of the part of the differential cross-section used
7206 C...in the event weighting.
7210 C...Double precision and integer declarations.
7211 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7212 IMPLICIT INTEGER(I-N)
7213 INTEGER PYK,PYCHGE,PYCOMP
7214 C...Parameter statement to help give large particle numbers.
7215 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7216 &KEXCIT=4000000,KDIMEN=5000000)
7218 C...User process initialization commonblock.
7220 PARAMETER (MAXPUP=100)
7221 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7222 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7223 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7224 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7229 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7230 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7231 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7232 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7233 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7234 COMMON/PYINT1/MINT(400),VINT(400)
7235 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7236 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7237 COMMON/PYINT4/MWID(500),WIDS(500,5)
7238 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7239 COMMON/PYINT6/PROC(0:500)
7241 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7242 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
7243 COMMON/PYTCCO/COEFX(194:380,2)
7244 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
7245 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7246 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
7248 C...Local arrays, character variables and data.
7251 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7252 &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
7253 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2),WTRSAV(9),TEMPC(9),
7255 DATA CVAR/'tau ','tau''','y* ','cth '/
7258 C...Initial values and loop over subprocesses.
7268 C...Find maximum weight factors for photon flux.
7269 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7270 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7273 C...Select subprocess to study: skip cases not applicable.
7274 IF(ISET(ISUB).EQ.11) THEN
7275 IF(MSUB(ISUB).NE.1) GOTO 460
7276 C...User process intialization: cross section model dependent.
7277 IF(IABS(IDWTUP).EQ.1) THEN
7278 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7279 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7280 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7282 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7283 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7284 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7285 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7286 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7287 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7289 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7290 & WTGAGA*XSEC(ISUB,1)
7293 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7294 CALL PYSIGH(NCHN,SIGS)
7296 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7297 & WTGAGA*XSEC(ISUB,1)
7298 IF(MSUB(ISUB).NE.1) GOTO 460
7301 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7302 CALL PYSIGH(NCHN,SIGS)
7304 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7305 & WTGAGA*XSEC(ISUB,1)
7306 IF(XSEC(ISUB,1).EQ.0D0) THEN
7312 ELSEIF(ISUB.EQ.96) THEN
7313 IF(MINT(50).EQ.0) GOTO 460
7314 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7316 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7317 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7318 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7319 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7320 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7321 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7323 IF(MSUB(ISUB).NE.1) GOTO 460
7326 IF(ISUB.EQ.96) ISTSB=2
7327 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7329 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7330 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7332 C...Find resonances (explicit or implicit in cross-section).
7335 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7337 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7338 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7340 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7341 & .OR.ISUB.EQ.177) THEN
7343 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7345 IF(MSTP(46).EQ.5) THEN
7348 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7352 IF(CKMX.LE.0D0) CKMX=VINT(1)
7355 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7356 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7359 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7360 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7368 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
7369 $ (ISUB.GE.361.AND.ISUB.LE.380))
7372 IF(ISUB.EQ.141) THEN
7374 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7375 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
7378 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7379 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7385 ELSEIF(ITECH.EQ.0) THEN
7386 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
7395 C...Order the resonances
7396 IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
7401 IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
7406 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7413 SHN0=PMAS(KCR1,1)**2
7415 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
7416 SHN0=PMAS(KCR2,1)**2
7418 IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
7419 SHN0=PMAS(KCR3,1)**2
7422 FAR=SQRT(AEM/ALPRHT)
7424 CALL PYTECM(SHN,S1,WIDO,1)
7429 CALL PYTECM(SHN,S1,WIDO,1)
7430 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7433 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7434 ELSEIF(IRES.EQ.0) THEN
7444 IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
7451 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7458 SHN0=PMAS(KCR1,1)**2
7460 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
7461 SHN0=PMAS(KCR2,1)**2
7464 FAR=SQRT(AEM/ALPRHT)
7466 CALL PYTECM(SHN,S1,WIDO,2)
7471 CALL PYTECM(SHN,S1,WIDO,2)
7472 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7475 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7476 ELSEIF(JRES.EQ.0) THEN
7486 IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
7489 IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
7490 & ISUB.EQ.379.OR.ISUB.EQ.380) THEN
7493 VINT(73)=XMAS(1)**2/VINT(2)
7494 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
7502 VINT(75)=XMAS(2)**2/VINT(2)
7503 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
7511 VINT(77)=XMAS(3)**2/VINT(2)
7512 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
7519 C...Charged current: rho+- and a+-
7520 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
7523 VINT(73)=YMAS(1)**2/VINT(2)
7524 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
7532 VINT(75)=YMAS(2)**2/VINT(2)
7533 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
7542 IF(ISUB.NE.141) THEN
7543 IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
7544 & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
7545 IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
7546 & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
7547 IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
7548 & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
7549 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
7551 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
7553 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
7558 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
7566 ELSEIF(KFR1.NE.0) THEN
7568 ELSEIF(KFR2.NE.0) THEN
7573 ELSEIF(KFR3.NE.0) THEN
7582 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7584 ELSEIF(KFR2.NE.0) THEN
7599 C...Find product masses and minimum pT of process.
7605 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7609 IF(KFPR(ISUB,I).EQ.0) THEN
7610 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7612 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7613 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7616 C...This prevents SUSY/t particles from becoming too light.
7618 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7621 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7622 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7623 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7624 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7625 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7626 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7627 PMMN(I)=MIN(PMMN(I),PMSUM)
7630 ELSEIF(KFLW.EQ.6) THEN
7631 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7638 CKIN(41)=MAX(PMMN(1),CKIN(41))
7639 CKIN(43)=MAX(PMMN(2),CKIN(43))
7640 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7643 IF(MINT(51).EQ.1) THEN
7644 WRITE(MSTU(11),5100) ISUB
7651 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7652 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7653 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7654 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7655 ELSEIF(ISUB.EQ.96) THEN
7656 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7662 C...Prepare for additional variable choices in 2 -> 3.
7665 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7667 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7668 VINT(204)=PMAS(23,1)
7669 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7670 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7671 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7672 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7673 & VINT(204)=VINT(201)
7675 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7678 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7680 NPTS(1)=2+2*MINT(72)
7681 IF(MINT(47).EQ.1) THEN
7682 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7683 ELSEIF(MINT(47).GE.5) THEN
7684 IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
7690 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7691 IF(MINT(47).GE.2) NPTS(2)=2
7692 IF(MINT(47).GE.5) NPTS(2)=3
7695 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7697 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7698 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7701 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7702 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7704 C...Reset coefficients of cross-section weighting.
7708 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
7709 & .AND.ISUB.LE.380)) THEN
7726 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7727 C...in grid of phase space points.
7733 IF(METAU.EQ.1) GOTO 150
7734 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7735 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7736 IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
7738 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
7742 C...Special case when both resonances have same mass,
7743 C...as is often the case in process 194.
7744 c IF(MINT(72).GE.2) THEN
7745 c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7746 c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7747 c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7749 c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7754 CALL PYKMAP(1,MTAU,RTAU)
7755 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7758 IF(METAUP.EQ.1) GOTO 150
7759 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7761 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7762 CALL PYKMAP(4,MTAUP,0.5D0)
7764 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7768 IF(MEYST.EQ.1) GOTO 150
7769 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7770 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7771 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7772 CALL PYKMAP(2,MYST,0.5D0)
7776 IF(MECTH.EQ.1) GOTO 150
7777 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7778 MCTH=1+MOD(ITRY-1,NPTS(4))
7779 CALL PYKMAP(3,MCTH,0.5D0)
7781 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7783 C...Store position and limits.
7786 IF(MINT(51).EQ.1) GOTO 150
7789 MVARPT(NACC,2)=MTAUP
7793 VINTPT(NACC,J)=VINT(10+J)
7796 C...Normal case: calculate cross-section.
7798 CALL PYSIGH(NCHN,SIGS)
7804 C..2 -> 3: find highest value out of a number of tries.
7807 DO 140 IKIN3=1,MSTP(129)
7808 CALL PYKMAP(5,0,0D0)
7809 IF(MINT(51).EQ.1) GOTO 140
7810 CALL PYSIGH(NCHN,SIGTMP)
7815 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7819 C...Store cross-section.
7821 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7822 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7823 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7826 WRITE(MSTU(11),5100) ISUB
7829 ELSEIF(SIGSAM.EQ.0D0) THEN
7830 WRITE(MSTU(11),5300) ISUB
7834 IF(ISUB.NE.96) NPOSI=NPOSI+1
7836 C...Calculate integrals in tau over maximal phase space limits.
7839 ATAU1=LOG(TAUMAX/TAUMIN)
7840 IF(NPTS(1).GE.2) THEN
7841 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7843 IF(NPTS(1).GE.4) THEN
7844 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7845 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7848 IF(NPTS(1).GE.6) THEN
7849 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7850 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7853 IF(NPTS(1).GE.8) THEN
7854 ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
7855 ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
7858 IF(IPEAK7.EQ.1) THEN
7859 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7862 C...Reset. Sum up cross-sections in points calculated.
7864 IF(NPTS(IVAR).EQ.1) GOTO 320
7865 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7876 IBIN=MVARPT(IACC,IVAR)
7878 IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
7880 ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
7884 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7885 NAREL(IBIN)=NAREL(IBIN)+1
7886 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7888 C...Sum up tau cross-section pieces in points used.
7891 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7892 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7894 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7895 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7896 & ((TAU-TAUR1)**2+GAMR1**2)
7899 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7900 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7901 & ((TAU-TAUR2)**2+GAMR2**2)
7903 IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
7904 WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
7905 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7906 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
7907 WTMAT(IBIN,7)=WTMAT(IBIN,7)
7908 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7910 IF(MINT(72).EQ.3) THEN
7911 WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
7912 & +(ATAU1/ATAU8)/(TAU+TAUR3)
7913 WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
7914 & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
7916 C...Sum up tau' cross-section pieces in points used.
7917 ELSEIF(IVAR.EQ.2) THEN
7919 TAUP=VINTPT(IACC,16)
7920 TAUPMN=VINTPT(IACC,6)
7921 TAUPMX=VINTPT(IACC,26)
7922 ATAUP1=LOG(TAUPMX/TAUPMN)
7923 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
7924 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7925 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
7926 & (1D0-TAU/TAUP)**3/TAUP
7928 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
7929 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
7930 & TAUP/MAX(2D-10,1D0-TAUP)
7933 C...Sum up y* cross-section pieces in points used.
7934 ELSEIF(IVAR.EQ.3) THEN
7936 YSTMIN=VINTPT(IACC,2)
7937 YSTMAX=VINTPT(IACC,22)
7939 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
7941 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
7942 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
7943 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
7944 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
7945 IF(MINT(45).EQ.3) THEN
7946 TAUE=VINTPT(IACC,11)
7947 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7948 YST0=-0.5D0*LOG(TAUE)
7949 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
7950 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
7951 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
7952 & MAX(1D-10,1D0-EXP(YST-YST0))
7954 IF(MINT(46).EQ.3) THEN
7955 TAUE=VINTPT(IACC,11)
7956 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7957 YST0=-0.5D0*LOG(TAUE)
7958 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
7959 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
7960 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
7961 & MAX(1D-10,1D0-EXP(-YST-YST0))
7964 C...Sum up cos(theta-hat) cross-section pieces in points used.
7966 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
7968 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
7970 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
7973 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
7974 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
7975 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
7976 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
7978 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7979 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
7980 & MAX(RM34,RSQM-CTH)
7981 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
7982 & MAX(RM34,RSQM+CTH)
7983 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
7984 & MAX(RM34,RSQM-CTH)**2
7985 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
7986 & MAX(RM34,RSQM+CTH)**2
7990 C...Check that equation system solvable.
7991 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
7995 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
7996 & IRED=1,NBIN),WTREL(IBIN)
7997 IF(NAREL(IBIN).EQ.0) MSOLV=0
7998 WTRELS=WTRELS+WTREL(IBIN)
8000 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
8002 C...Solve to find relative importance of cross-section pieces.
8005 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
8006 WTRSAV(IBIN)=WTREL(IBIN)
8008 C...Auxiliary vectors to record order of permutations
8013 DO 230 IRED=1,NBIN-1
8015 RESMAX=ABS(WTREL(MROW))
8016 C...Find row with largest residual
8018 IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN
8020 RESMAX=ABS(WTREL(MROW))
8023 IF(RESMAX.LT.1D-20) THEN
8028 AMAX = ABS(WTMAT(MROW,MCOL))
8029 C...Find column with largest entry
8031 IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN
8033 AMAX = ABS(WTMAT(MROW,MCOL))
8036 C...Swap rows if necessary
8037 IF(MROW.NE.IRED) THEN
8039 TMPE=WTMAT(IRED,JBIN)
8040 WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN)
8041 WTMAT(MROW,JBIN)=TMPE
8044 WTREL(IRED)=WTREL(MROW)
8050 C...Swap columns if necessary
8051 IF(MCOL.NE.IRED) THEN
8053 TMPE=WTMAT(JBIN,IRED)
8054 WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL)
8055 WTMAT(JBIN,MCOL)=TMPE
8061 C...Begin eliminating equations
8062 DO 220 IBIN=IRED+1,NBIN
8063 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8067 C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
8068 RQTU=WTMAT(IBIN,IRED)
8069 RQTL=WTMAT(IRED,IRED)
8070 C...Switch order of operations
8071 WTREL(IBIN)=WTREL(IBIN)-RQTU*
8072 $ (WTREL(IRED)/RQTL)
8073 DO 210 ICOE=IRED,NBIN
8074 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-
8075 $ RQTU*(WTMAT(IRED,ICOE)/RQTL)
8079 DO 250 IRED=NBIN,1,-1
8080 DO 240 ICOE=IRED+1,NBIN
8081 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
8083 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8087 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
8088 TEMPC(IRED)=COEFU(IRED)
8090 C...Return to original order
8093 COEFU(MTMP)=TEMPC(IBIN)
8097 C...Share evenly if failure.
8098 260 IF(MSOLV.EQ.0) THEN
8102 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
8103 & WTRSAV(IBIN)/WTRELS)
8107 C...Normalize coefficients, with piece shared democratically.
8111 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
8112 COEFSU=COEFSU+COEFU(IBIN)
8113 WTRELS=WTRELS+WTRELN(IBIN)
8115 IF(COEFSU.GT.0D0) THEN
8117 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
8118 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
8122 COEFO(IBIN)=1D0/NBIN
8125 IF(IVAR.EQ.1) IOFF=0
8126 IF(IVAR.EQ.2) IOFF=17
8127 IF(IVAR.EQ.3) IOFF=7
8128 IF(IVAR.EQ.4) IOFF=12
8132 IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
8136 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
8137 IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
8138 COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
8140 COEF(ISUB,ICOF)=COEFO(IBIN)
8144 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
8145 & (COEFO(IBIN),IBIN=1,NBIN)
8149 C...Find two most promising maxima among points previously determined.
8157 VINT(10+J)=VINTPT(IACC,J)
8160 CALL PYSIGH(NCHN,SIGS)
8167 DO 350 IKIN3=1,MSTP(129)
8168 CALL PYKMAP(5,0,0D0)
8169 IF(MINT(51).EQ.1) GOTO 350
8170 CALL PYSIGH(NCHN,SIGTMP)
8175 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8180 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
8183 DO 370 IMV=NMAX,1,-1
8185 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
8186 IACCMX(IMV+1)=IACCMX(IMV)
8187 SIGSMX(IMV+1)=SIGSMX(IMV)
8190 380 IACCMX(IIN)=IACC
8192 IF(NMAX.LE.1) NMAX=NMAX+1
8196 C...Read out starting position for search.
8197 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
8202 MTAUP=MVARPT(IACC,2)
8210 C...Starting point and step size in parameter space.
8213 IF(NPTS(IVAR).EQ.1) GOTO 420
8214 IF(IVAR.EQ.1) VVAR=VTAU
8215 IF(IVAR.EQ.2) VVAR=VTAUP
8216 IF(IVAR.EQ.3) VVAR=VYST
8217 IF(IVAR.EQ.4) VVAR=VCTH
8218 IF(IVAR.EQ.1) MVAR=MTAU
8219 IF(IVAR.EQ.2) MVAR=MTAUP
8220 IF(IVAR.EQ.3) MVAR=MYST
8221 IF(IVAR.EQ.4) MVAR=MCTH
8222 IF(IRPT.EQ.1) VDEL=0.1D0
8223 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
8225 IF(IRPT.EQ.1) VMAR=0.02D0
8226 IF(IRPT.EQ.2) VMAR=0.002D0
8228 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
8231 C...Define new point in parameter space.
8235 ELSEIF(IMOV.EQ.1) THEN
8238 ELSEIF(IMOV.EQ.2) THEN
8241 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
8242 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
8248 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
8249 & VVAR-2D0*VDEL.GT.VMAR) THEN
8255 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
8269 C...Convert to relevant variables and find derived new limits.
8273 CALL PYKMAP(1,MTAU,VTAU)
8274 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8276 IF(MINT(51).EQ.1) ILERR=1
8279 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
8281 IF(IVAR.EQ.2) VTAUP=VNEW
8282 CALL PYKMAP(4,MTAUP,VTAUP)
8284 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
8286 IF(MINT(51).EQ.1) ILERR=1
8288 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
8289 IF(IVAR.EQ.3) VYST=VNEW
8290 CALL PYKMAP(2,MYST,VYST)
8292 IF(MINT(51).EQ.1) ILERR=1
8294 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
8296 IF(IVAR.EQ.4) VCTH=VNEW
8297 CALL PYKMAP(3,MCTH,VCTH)
8299 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
8301 C...Evaluate cross-section. Save new maximum. Final maximum.
8304 ELSEIF(ISTSB.NE.5) THEN
8305 CALL PYSIGH(NCHN,SIGS)
8312 DO 400 IKIN3=1,MSTP(129)
8313 CALL PYKMAP(5,0,0D0)
8314 IF(MINT(51).EQ.1) GOTO 400
8315 CALL PYSIGH(NCHN,SIGTMP)
8320 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8324 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
8325 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
8326 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
8331 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
8332 XSEC(ISUB,1)=1.05D0*SIGSAM
8333 C...Add extra headroom for UED
8334 IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0
8335 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
8336 & WTGAGA*XSEC(ISUB,1)
8338 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
8339 & PARP(174)*XSEC(ISUB,1)
8340 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
8344 C...Print summary table.
8345 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
8346 IF(MSTP(127).NE.1) THEN
8347 WRITE(MSTU(11),5900)
8350 WRITE(MSTU(11),6400)
8354 IF(MSTP(122).GE.1) THEN
8355 WRITE(MSTU(11),6000)
8356 WRITE(MSTU(11),6100)
8358 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
8359 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
8360 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
8362 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
8363 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
8364 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
8365 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
8366 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
8368 WRITE(MSTU(11),6300)
8371 C...Format statements for maximization results.
8372 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
8373 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
8374 &'cth',9X,'tau''',7X,'sigma')
8375 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
8376 &'phase space.'/1X,'Process switched off!')
8377 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
8378 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
8379 &'cross-section.'/1X,'Process switched off!')
8380 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
8381 5500 FORMAT(1X,1P,10D11.3)
8382 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
8383 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
8384 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
8385 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
8386 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
8387 &'cross-section.'/1X,'Execution stopped!')
8388 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
8389 &'cross-section maximum search',1X,8('*'))
8390 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
8391 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
8392 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
8393 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
8394 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
8395 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
8397 &1X,'Execution will stop if you try to generate events.')
8402 C*********************************************************************
8405 C...Initializes multiplicity distribution and selects mutliplicity
8406 C...of pileup events, i.e. several events occuring at the same
8409 SUBROUTINE PYPILE(MPILE)
8411 C...Double precision and integer declarations.
8412 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8413 IMPLICIT INTEGER(I-N)
8414 INTEGER PYK,PYCHGE,PYCOMP
8416 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8417 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8418 COMMON/PYINT1/MINT(400),VINT(400)
8419 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8420 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
8421 C...Local arrays and saved variables.
8422 DIMENSION WTI(0:200)
8423 SAVE IMIN,IMAX,WTI,WTS
8425 C...Sum of allowed cross-sections for pileup events.
8427 VINT(131)=SIGT(0,0,5)
8428 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
8429 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
8430 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
8431 IF(MSTP(133).LE.0) RETURN
8433 C...Initialize multiplicity distribution at maximum.
8434 XNAVE=VINT(131)*PARP(131)
8435 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
8436 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
8439 WTN=WTI(INAVE)*INAVE
8441 C...Find shape of multiplicity distribution below maximum.
8443 DO 100 I=INAVE-1,1,-1
8444 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
8445 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
8446 IF(WTI(I).LT.1D-6) GOTO 110
8452 C...Find shape of multiplicity distribution above maximum.
8454 DO 120 I=INAVE+1,200
8455 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
8456 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
8457 IF(WTI(I).LT.1D-6) GOTO 130
8464 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
8465 & WTS/(WTS+WTI(1)/XNAVE)
8466 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
8467 IF(MSTP(133).GE.2) VINT(134)=XNAVE
8469 C...Pick multiplicity of pileup events.
8471 IF(MSTP(133).LE.0) THEN
8472 MINT(81)=MAX(1,MSTP(134))
8478 IF(WTR.LE.0D0) GOTO 150
8484 C...Format statement for error message.
8485 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
8486 &'crossing too large, ',1P,D12.4)
8491 C*********************************************************************
8494 C...Saves and restores parameter and cross section values for the
8495 C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8496 C...Also makes random choice between alternatives.
8498 SUBROUTINE PYSAVE(ISAVE,IGA)
8500 C...Double precision and integer declarations.
8501 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8502 IMPLICIT INTEGER(I-N)
8503 INTEGER PYK,PYCHGE,PYCOMP
8505 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8506 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8507 COMMON/PYINT1/MINT(400),VINT(400)
8508 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8509 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8510 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8511 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
8512 C...Local arrays and saved variables.
8513 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
8514 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
8515 &INTCP(15,20),RECP(15,20)
8516 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
8518 C...Save list of subprocesses and cross-section information.
8522 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
8525 MSUBCP(IGA,ICP)=MSUB(I)
8527 COEFCP(IGA,ICP,J)=COEF(I,J)
8530 NGENCP(IGA,ICP,J)=NGEN(I,J)
8531 XSECCP(IGA,ICP,J)=XSEC(I,J)
8536 NGENCP(IGA,0,J)=NGEN(0,J)
8537 XSECCP(IGA,0,J)=XSEC(0,J)
8542 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
8547 C...Save various common process variables.
8549 INTCP(IGA,J)=MINT(40+J)
8551 INTCP(IGA,11)=MINT(101)
8552 INTCP(IGA,12)=MINT(102)
8553 INTCP(IGA,13)=MINT(107)
8554 INTCP(IGA,14)=MINT(108)
8555 INTCP(IGA,15)=MINT(123)
8557 RECP(IGA,2)=VINT(318)
8559 C...Save cross-section information only.
8560 ELSEIF(ISAVE.EQ.2) THEN
8561 DO 190 ICP=1,NCP(IGA)
8564 NGENCP(IGA,ICP,J)=NGEN(I,J)
8565 XSECCP(IGA,ICP,J)=XSEC(I,J)
8569 NGENCP(IGA,0,J)=NGEN(0,J)
8570 XSECCP(IGA,0,J)=XSEC(0,J)
8573 C...Choose between allowed alternatives.
8574 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8577 DO 210 IG=1,MINT(121)
8578 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8580 XSUMCP=XSUMCP*PYR(0)
8581 DO 220 IG=1,MINT(121)
8583 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8584 IF(XSUMCP.LE.0D0) GOTO 230
8589 C...Restore cross-section information.
8593 DO 270 ICP=1,NCP(IGA)
8595 MSUB(I)=MSUBCP(IGA,ICP)
8597 COEF(I,J)=COEFCP(IGA,ICP,J)
8600 NGEN(I,J)=NGENCP(IGA,ICP,J)
8601 XSEC(I,J)=XSECCP(IGA,ICP,J)
8605 NGEN(0,J)=NGENCP(IGA,0,J)
8606 XSEC(0,J)=XSECCP(IGA,0,J)
8611 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8616 C...Restore various common process variables.
8618 MINT(40+J)=INTCP(IGA,J)
8620 MINT(101)=INTCP(IGA,11)
8621 MINT(102)=INTCP(IGA,12)
8622 MINT(107)=INTCP(IGA,13)
8623 MINT(108)=INTCP(IGA,14)
8624 MINT(123)=INTCP(IGA,15)
8627 VINT(318)=RECP(IGA,2)
8629 C...Sum up cross-section info (for PYSTAT).
8630 ELSEIF(ISAVE.EQ.5) THEN
8641 DO 350 IG=1,MINT(121)
8642 DO 340 ICP=1,NCP(IG)
8644 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8645 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8646 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8647 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8649 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8650 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8651 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8652 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8659 C*********************************************************************
8662 C...For lepton beams it gives photon-hadron or photon-photon systems
8663 C...to be treated with the ordinary machinery and combines this with a
8664 C...description of the lepton -> lepton + photon branching.
8666 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8668 C...Double precision and integer declarations.
8669 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8670 IMPLICIT INTEGER(I-N)
8671 INTEGER PYK,PYCHGE,PYCOMP
8673 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8674 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8675 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8676 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8677 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8678 COMMON/PYINT1/MINT(400),VINT(400)
8679 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8680 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8682 C...Local variables and data statement.
8683 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8684 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8685 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8688 C...Initialize generation of photons inside leptons.
8691 C...Save quantities on incoming lepton system.
8695 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8697 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8698 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8699 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8701 C...Calculate range of x and Q2 values allowed in generation.
8703 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8704 IF(MINT(140+I).NE.0) THEN
8705 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8706 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8708 YMIN=MAX(CKIN(71+2*I),EPS)
8709 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8710 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8711 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8712 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8713 THEMIN=MAX(CKIN(67+2*I),0D0)
8714 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8715 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8716 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8717 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8718 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8719 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8720 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8721 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8722 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8723 C...W limits when lepton on one side only.
8724 IF(MINT(143-I).EQ.0) THEN
8725 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8726 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8727 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8732 C...W limits when lepton on both sides.
8733 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8734 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8735 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8736 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8737 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8738 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8739 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8740 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8741 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8742 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8744 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8745 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8749 C...Q2 and W values and photon flux weight factors for initialization.
8750 ELSEIF(IGAGA.EQ.2) THEN
8755 C...W value for photon on one or both sides, and for processes
8756 C...with gamma-gamma cross section peaked at small shat.
8757 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8758 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8759 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8760 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8761 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8762 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8763 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8765 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8766 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8768 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8770 C...Upper estimate of photon flux weight factor.
8771 C...Initialization Q2 scale. Flag incoming unresolved photon.
8774 IF(MINT(140+I).NE.0) THEN
8775 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8776 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8777 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8779 Q2INIT=5D0+Q2MIN(3-I)
8780 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8781 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8782 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8783 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8784 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8785 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8787 ELSEIF(ISUB.EQ.140) THEN
8792 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8793 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8795 VINT(306+I)=VINT(2+I)**2
8800 C...Update pTmin and cross section information.
8801 IF(MSTP(82).LE.1) THEN
8802 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8804 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8806 VINT(149)=4D0*PTMN**2/VINT(2)
8811 C...Generate photons inside leptons and
8812 C...calculate photon flux weight factors.
8813 ELSEIF(IGAGA.EQ.3) THEN
8818 C...Generate phase space point and check against cuts.
8822 IF(MINT(140+I).NE.0) THEN
8824 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8825 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8826 C...Cuts on internal consistency in x and Q2.
8827 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8828 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8829 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8830 C...Cuts on y and theta.
8831 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8832 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8833 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8834 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8835 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8836 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8837 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8840 C...Phi angle isotropic. Reconstruct pT.
8841 PHI(I)=PARU(2)*PYR(0)
8842 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8843 & PMS(I))*SIN(THETA(I))
8845 C...Store info on variables selected, for documentation purposes.
8846 VINT(2+I)=-SQRT(Q2(I))
8850 VINT(310+I)=THETA(I)
8861 C...Cut on W combines info from two sides.
8862 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8863 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8864 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8865 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8866 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8867 IF(W2.LT.W2MIN) GOTO 120
8868 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8871 ELSEIF(MINT(141).NE.0) THEN
8872 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8875 ELSEIF(MINT(142).NE.0) THEN
8876 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8881 C...Store kinematics info for photon(s) in subsystem cm frame.
8886 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8887 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8888 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8891 VINT(298)=-VINT(293)
8892 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8893 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8895 C...Assign weight for photon flux; different for transverse and
8896 C...longitudinal photons. Flag incoming unresolved photon.
8899 IF(MINT(140+I).NE.0) THEN
8900 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8901 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8902 IF(MSTP(16).EQ.0) THEN
8905 WTGAGA=WTGAGA*X(I)/Y(I)
8908 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8909 WTGAGA=WTGAGA*(1D0-XY)
8910 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
8911 WTGAGA=WTGAGA*(1D0-XY)
8912 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
8913 WTGAGA=WTGAGA*(1D0-XY)
8915 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
8916 & PMS(I)*XY**2/Q2(I))
8918 IF(MINT(106+I).EQ.0) MINT(14+I)=22
8924 C...Update pTmin and cross section information.
8925 IF(MSTP(82).LE.1) THEN
8926 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8928 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8930 VINT(149)=4D0*PTMN**2/VINT(2)
8934 C...Reconstruct kinematics of photons inside leptons.
8935 ELSEIF(IGAGA.EQ.4) THEN
8937 C...Make place for incoming particles and scattered leptons.
8939 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
8940 MINT(4)=MINT(4)+MOVE
8941 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
8942 IF(K(I,1).EQ.21) THEN
8948 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8949 & K(I+MOVE,3)=K(I,3)+MOVE
8950 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
8951 & K(I+MOVE,4)=K(I,4)+MOVE
8952 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
8953 & K(I+MOVE,5)=K(I,5)+MOVE
8956 DO 170 I=MINT(84)+1,N
8957 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8958 & K(I,3)=K(I,3)+MOVE
8961 C...Fill in incoming particles.
8962 DO 190 I=MINT(83)+1,MINT(83)+MOVE
8971 IF(MINT(140+I).NE.0) THEN
8972 K(MINT(83)+I,2)=MINT(140+I)
8973 P(MINT(83)+I,5)=VINT(302+I)
8975 K(MINT(83)+I,2)=MINT(10+I)
8976 P(MINT(83)+I,5)=VINT(2+I)
8978 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
8979 & VINT(302))*(-1D0)**(I+1)
8980 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
8983 C...New mother-daughter relations in documentation section.
8984 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8985 K(MINT(83)+1,4)=MINT(83)+3
8986 K(MINT(83)+1,5)=MINT(83)+5
8987 K(MINT(83)+2,4)=MINT(83)+4
8988 K(MINT(83)+2,5)=MINT(83)+6
8989 K(MINT(83)+3,3)=MINT(83)+1
8990 K(MINT(83)+5,3)=MINT(83)+1
8991 K(MINT(83)+4,3)=MINT(83)+2
8992 K(MINT(83)+6,3)=MINT(83)+2
8993 ELSEIF(MINT(141).NE.0) THEN
8994 K(MINT(83)+1,4)=MINT(83)+3
8995 K(MINT(83)+1,5)=MINT(83)+4
8996 K(MINT(83)+2,4)=MINT(83)+5
8997 K(MINT(83)+3,3)=MINT(83)+1
8998 K(MINT(83)+4,3)=MINT(83)+1
8999 K(MINT(83)+5,3)=MINT(83)+2
9000 ELSEIF(MINT(142).NE.0) THEN
9001 K(MINT(83)+1,4)=MINT(83)+4
9002 K(MINT(83)+2,4)=MINT(83)+3
9003 K(MINT(83)+2,5)=MINT(83)+5
9004 K(MINT(83)+3,3)=MINT(83)+2
9005 K(MINT(83)+4,3)=MINT(83)+1
9006 K(MINT(83)+5,3)=MINT(83)+2
9009 C...Fill scattered lepton(s).
9011 IF(MINT(140+I).NE.0) THEN
9012 LSC=MINT(83)+MIN(I+2,MOVE)
9014 K(LSC,2)=MINT(140+I)
9015 P(LSC,1)=PT(I)*COS(PHI(I))
9016 P(LSC,2)=PT(I)*SIN(PHI(I))
9017 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
9018 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
9020 P(LSC,5)=VINT(302+I)
9024 C...Find incoming four-vectors to subprocess.
9026 IF(MINT(141).NE.0) THEN
9028 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
9032 P(N+1,J)=P(MINT(83)+1,J)
9036 IF(MINT(142).NE.0) THEN
9038 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
9042 P(N+2,J)=P(MINT(83)+2,J)
9046 C...Define boost and rotation between hadronic subsystem and
9047 C...collision rest frame; boost hadronic subsystem to this frame.
9049 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
9051 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
9052 BPHI=PYANGL(P(N+1,1),P(N+1,2))
9053 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
9054 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
9055 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
9058 C...Add on scattered leptons to final state.
9060 IF(MINT(140+I).NE.0) THEN
9061 LSC=MINT(83)+MIN(I+2,MOVE)
9077 C*********************************************************************
9080 C...Generates quantities characterizing the high-pT scattering at the
9081 C...parton level according to the matrix elements. Chooses incoming,
9082 C...reacting partons, their momentum fractions and one of the possible
9087 C...Double precision and integer declarations.
9088 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9089 IMPLICIT INTEGER(I-N)
9090 INTEGER PYK,PYCHGE,PYCOMP
9091 C...Parameter statement to help give large particle numbers.
9092 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
9093 &KEXCIT=4000000,KDIMEN=5000000)
9095 C...User process initialization and event commonblocks.
9097 PARAMETER (MAXPUP=100)
9098 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
9099 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
9100 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
9101 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
9104 PARAMETER (MAXNUP=500)
9105 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
9106 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
9107 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
9108 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
9109 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
9110 SAVE /HEPRUP/,/HEPEUP/
9113 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9114 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9115 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9116 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9117 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9118 COMMON/PYINT1/MINT(400),VINT(400)
9119 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9120 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9121 COMMON/PYINT4/MWID(500),WIDS(500,5)
9122 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
9123 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
9124 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
9125 COMMON/PYTCCO/COEFX(194:380,2)
9126 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
9127 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
9128 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
9131 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
9133 C...Parameters and data used in elastic/diffractive treatment.
9134 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
9135 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
9137 C...Initial values, specifically for (first) semihard interaction.
9146 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
9155 C...Start by assuming incoming photon is entering subprocess.
9156 IF(MINT(11).EQ.22) THEN
9158 VINT(307)=VINT(3)**2
9160 IF(MINT(12).EQ.22) THEN
9162 VINT(308)=VINT(4)**2
9167 C...Choice of process type - first event of pileup.
9169 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
9170 ELSEIF(MINT(82).EQ.1) THEN
9172 C...For gamma-p or gamma-gamma first pick between alternatives.
9174 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
9177 C...For real gamma + gamma with different nature, flip at random.
9178 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
9179 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
9189 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
9192 C...Pick process type, possibly by user process machinery.
9193 C...(If the latter, also event will be picked here.)
9194 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
9197 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
9202 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
9203 & ISUB.LT.500) GOTO 110
9205 RSUB=XSEC(0,1)*PYR(0)
9207 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
9210 IF(RSUB.LE.0D0) GOTO 130
9212 130 IF(ISUB.EQ.95) ISUB=96
9213 IF(ISUB.EQ.96) INMULT=1
9214 IF(ISET(ISUB).EQ.11) THEN
9221 C...Choice of inclusive process type - pileup events.
9222 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
9223 RSUB=VINT(131)*PYR(0)
9225 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
9226 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
9227 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
9228 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
9230 IF(ISUB.EQ.96) INMULT=1
9233 C...Choice of photon energy and flux factor inside lepton.
9234 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9235 CALL PYGAGA(3,WTGAGA)
9236 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
9237 CKIN(3)=MAX(VINT(285),VINT(154))
9240 C...When necessary set direct/resolved photon by hand.
9241 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
9242 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
9243 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
9246 C...Restrict direct*resolved processes to pTmin >= Q,
9247 C...to avoid doublecounting with DIS.
9248 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
9249 IF(MINT(15).EQ.22) THEN
9250 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
9252 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
9257 C...Set up for multiple interactions (may include impact parameter).
9258 IF(INMULT.EQ.1) THEN
9259 IF(MINT(35).LE.1) CALL PYMULT(2)
9260 IF(MINT(35).GE.2) CALL PYMIGN(2)
9263 C...Loopback point for minimum bias in photon physics.
9266 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
9267 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
9268 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
9269 &NGEN(97,1)=NGEN(97,1)+MINT(143)
9273 C...Random choice of flavour for some SUSY processes.
9274 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
9275 C...~e_L ~nu_e or ~mu_L ~nu_mu.
9276 IF(ISUB.EQ.210) THEN
9277 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
9278 KFPR(ISUB,2)=KFPR(ISUB,1)+1
9279 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9280 ELSEIF(ISUB.EQ.213) THEN
9281 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
9282 KFPR(ISUB,2)=KFPR(ISUB,1)
9283 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9284 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
9286 IF(ISUB.GE.258) THEN
9291 IF(MOD(ISUB,2).EQ.0) THEN
9292 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
9294 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
9296 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9297 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
9298 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
9301 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
9304 ELSEIF(PYR(0).LT.0.5D0) THEN
9311 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
9312 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
9313 C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9314 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
9315 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
9316 KFPR(ISUB,2)=KFPR(ISUB,1)
9317 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
9318 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
9319 KFPR(ISUB,2)=KFPR(ISUB,1)
9320 C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9321 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
9322 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
9325 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
9328 ELSEIF(PYR(0).LT.0.5D0) THEN
9335 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
9340 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
9344 C...Random choice of flavours for some UED processes
9345 c...The production processes can generate a doublet pair,
9346 c...a singlet pair, or a doublet + singlet.
9348 C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
9349 IF(PYR(0).LE.0.1)THEN
9350 KFPR(ISUB,1)=5100001
9352 KFPR(ISUB,1)=5100002
9354 KFPR(ISUB,2)=KFPR(ISUB,1)
9355 ELSEIF(ISUB.EQ.314.OR.ISUB.EQ.315)THEN
9356 C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
9357 C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
9358 IF(PYR(0).LE.0.1)THEN
9359 KFPR(ISUB,1)=5100001
9361 KFPR(ISUB,1)=5100002
9363 KFPR(ISUB,2)=-KFPR(ISUB,1)
9364 ELSEIF(ISUB.EQ.316)THEN
9365 C...qi + qbarj -> q*_Di + q*_Sbarj
9366 IF(PYR(0).LE.0.5)THEN
9367 KFPR(ISUB,1)=5100001
9368 c Changed from private pythia6410_ued code
9369 c KFPR(ISUB,2)=-5010001
9370 KFPR(ISUB,2)=-6100002
9372 KFPR(ISUB,1)=5100002
9373 c Changed from private pythia6410_ued code
9374 c KFPR(ISUB,2)=-5010002
9375 KFPR(ISUB,2)=-6100001
9377 ELSEIF(ISUB.EQ.317)THEN
9378 C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
9379 IF(PYR(0).LE.0.5)THEN
9380 KFPR(ISUB,1)=5100001
9381 KFPR(ISUB,2)=-5100002
9383 KFPR(ISUB,1)=5100002
9384 KFPR(ISUB,2)=-5100001
9386 ELSEIF(ISUB.EQ.318)THEN
9387 C...qi + qj -> q*_Di + q*_Sj
9388 IF(PYR(0).LE.0.5)THEN
9389 KFPR(ISUB,1)=5100001
9390 KFPR(ISUB,2)=6100002
9392 KFPR(ISUB,1)=5100002
9393 KFPR(ISUB,2)=6100001
9397 C...Find resonances (explicit or implicit in cross-section).
9400 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
9402 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
9403 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
9405 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
9408 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
9410 IF(MSTP(46).EQ.5) THEN
9413 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
9417 IF(CKMX.LE.0D0) CKMX=VINT(1)
9420 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
9421 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
9424 TAUR1=PMAS(KCR1,1)**2/VINT(2)
9425 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
9433 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
9434 $(ISUB.GE.361.AND.ISUB.LE.380))
9437 IF(ISUB.EQ.141) THEN
9439 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
9440 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
9443 TAUR2=PMAS(KCR2,1)**2/VINT(2)
9444 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
9450 C...3 resonances at work: rho, omega, a
9451 ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
9452 & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
9455 VINT(73)=XMAS(1)**2/VINT(2)
9456 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
9462 VINT(75)=XMAS(2)**2/VINT(2)
9463 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
9469 VINT(77)=XMAS(3)**2/VINT(2)
9470 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
9475 C...Charged current: rho+- and a+-
9476 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
9479 VINT(73)=YMAS(1)**2/VINT(2)
9480 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
9486 VINT(75)=YMAS(2)**2/VINT(2)
9487 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
9494 IF(ISUB.NE.141) THEN
9495 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
9497 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
9499 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
9504 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
9512 ELSEIF(KFR1.NE.0) THEN
9514 ELSEIF(KFR2.NE.0) THEN
9519 ELSEIF(KFR3.NE.0) THEN
9528 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
9530 ELSEIF(KFR2.NE.0) THEN
9545 C...Find product masses and minimum pT of process,
9546 C...optionally with broadening according to a truncated Breit-Wigner.
9551 IF(MINT(82).GE.2) VINT(71)=0D0
9553 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9557 IF(KFPR(ISUB,I).EQ.0) THEN
9558 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
9560 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
9563 C...This prevents SUSY/t particles from becoming too light.
9565 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9568 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9569 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9570 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9571 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9572 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9573 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9574 PMMN(I)=MIN(PMMN(I),PMSUM)
9577 ELSEIF(KFLW.EQ.6) THEN
9578 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9585 CKIN(41)=MAX(PMMN(1),CKIN(41))
9586 CKIN(43)=MAX(PMMN(2),CKIN(43))
9587 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
9590 IF(MINT(51).EQ.1) THEN
9591 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9601 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
9602 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
9605 C...Prepare for additional variable choices in 2 -> 3.
9608 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
9610 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
9611 VINT(204)=PMAS(23,1)
9612 IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
9613 & VINT(204)=PMAS(24,1)
9614 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
9615 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
9616 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
9617 & VINT(204)=VINT(201)
9619 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
9622 C...Select incoming VDM particle (rho/omega/phi/J/psi).
9623 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
9624 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
9625 VRN=PYR(0)*SIGT(0,0,5)
9626 IF(MINT(101).LE.1) THEN
9633 IF(MINT(102).LE.1) THEN
9644 VRN=VRN-SIGT(I1,I2,5)
9645 IF(VRN.LE.0D0) GOTO 190
9648 190 IF(MINT(101).GE.2) MINT(103)=KFV1
9649 IF(MINT(102).GE.2) MINT(104)=KFV2
9653 C...Elastic scattering or single or double diffractive scattering.
9655 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9660 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
9662 VRN=PYR(0)*SIGT(0,0,JJ)
9663 IF(MINT(101).LE.1) THEN
9670 IF(MINT(102).LE.1) THEN
9681 VRN=VRN-SIGT(I1,I2,JJ)
9682 IF(VRN.LE.0D0) GOTO 220
9685 220 IF(MINT(101).GE.2) THEN
9689 IF(MINT(102).GE.2) THEN
9697 C...Select mass for GVMD states (rejecting previous assignment).
9699 Q1S=4D0*VINT(154)**2
9703 IF(MINT(106+JT).EQ.3) THEN
9705 PMM(JT)=SQRT((Q0S+PS)*(Q1S+PS)/
9706 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS)
9707 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9708 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9711 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9712 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9717 C...Side/sides of diffractive system.
9720 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9721 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9723 C...Find masses of particles and minimal masses of diffractive states.
9726 VINT(68+JT)=PDIF(JT)
9727 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9734 SMRES1=(PMM(1)+PMRC)**2
9735 SMRES2=(PMM(2)+PMRC)**2
9737 C...Find elastic slope and lower limit diffractive slope.
9738 IHA=MAX(2,IABS(MINT(103))/110)
9740 IHB=MAX(2,IABS(MINT(104))/110)
9743 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9744 ELSEIF(ISUB.EQ.92) THEN
9745 BMN=MAX(2D0,2D0*BHAD(IHB))
9746 ELSEIF(ISUB.EQ.93) THEN
9747 BMN=MAX(2D0,2D0*BHAD(IHA))
9748 ELSEIF(ISUB.EQ.94) THEN
9752 C...Determine maximum possible t range and coefficient of generation.
9753 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9754 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9755 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9756 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9757 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9758 & (SQM1*SQM4-SQM2*SQM3)/SH
9759 THL=-0.5D0*(THA+THB)
9761 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9763 C...Select diffractive mass/masses according to dm^2/m^2.
9767 IF(MINT(16+JT).EQ.0) THEN
9771 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9772 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9778 C..Additional mass factors, including resonance enhancement.
9779 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9780 IF(LOOP3.LT.100) GOTO 260
9784 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9785 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9786 ELSEIF(ISUB.EQ.93) THEN
9787 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9788 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9789 ELSEIF(ISUB.EQ.94) THEN
9790 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9791 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9792 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9793 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9796 C...Select t according to exp(Bmn*t) and correct to right slope.
9797 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9800 BADD=2D0*ALP*LOG(SH/SQM3)
9801 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9802 ELSEIF(ISUB.EQ.93) THEN
9803 BADD=2D0*ALP*LOG(SH/SQM4)
9804 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9805 ELSEIF(ISUB.EQ.94) THEN
9806 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9808 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9811 C...Check whether m^2 and t choices are consistent.
9812 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9813 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9814 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9815 IF(THB.LE.1D-8) GOTO 260
9816 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9817 & (SQM1*SQM4-SQM2*SQM3)/SH
9818 THLM=-0.5D0*(THA+THB)
9820 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9822 C...Information to output.
9825 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9827 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9830 VINT(283)=PMM(1)**2/4D0
9831 VINT(284)=PMM(2)**2/4D0
9833 C...Note: in the following, by In is meant the integral over the
9834 C...quantity multiplying coefficient cn.
9835 C...Choose tau according to h1(tau)/tau, where
9836 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9837 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9838 C...I1/I5*c5*1/(tau+tau_R') +
9839 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9840 C...I1/I7*c7*tau/(1.-tau), and
9841 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9842 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9844 IF(MINT(51).NE.0) THEN
9845 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9854 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9855 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9856 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9857 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9859 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9860 & COEF(ISUB,5)) MTAU=6
9861 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9862 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9863 C...Additional check to handle techni-processes with extra resonance
9864 C....Only modify tau treatment
9865 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
9867 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9868 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
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)
9871 & +COEFX(ISUB,1)) MTAU=9
9873 CALL PYKMAP(1,MTAU,PYR(0))
9875 C...2 -> 3, 4 processes:
9876 C...Choose tau' according to h4(tau,tau')/tau', where
9877 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9878 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9879 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9881 IF(MINT(51).NE.0) THEN
9882 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9891 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9892 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9893 CALL PYKMAP(4,MTAUP,PYR(0))
9896 C...Choose y* according to h2(y*), where
9897 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9898 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9899 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9900 C...and c1 + c2 + c3 + c4 + c5 = 1.
9902 IF(MINT(51).NE.0) THEN
9903 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9912 IF(RYST.GT.COEF(ISUB,8)) MYST=2
9913 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
9914 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
9915 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
9916 & COEF(ISUB,11)) MYST=5
9917 CALL PYKMAP(2,MYST,PYR(0))
9919 C...2 -> 2 processes:
9920 C...Choose cos(theta-hat) (cth) according to h3(cth), where
9921 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
9922 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
9923 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
9924 C...and c0 + c1 + c2 + c3 + c4 = 1.
9926 IF(MINT(51).NE.0) THEN
9927 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9934 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9937 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
9938 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
9939 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
9940 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
9941 & COEF(ISUB,16)) MCTH=5
9942 CALL PYKMAP(3,MCTH,PYR(0))
9945 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
9947 CALL PYKMAP(5,0,0D0)
9948 IF(MINT(51).NE.0) THEN
9949 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9958 C...DIS as f + gamma* -> f process: set dummy values.
9959 ELSEIF(ISTSB.EQ.8) THEN
9966 C...Low-pT or multiple interactions (first semihard interaction).
9967 ELSEIF(ISTSB.EQ.9) THEN
9968 IF(MINT(35).LE.1) CALL PYMULT(3)
9969 IF(MINT(35).GE.2) CALL PYMIGN(3)
9972 C...Study user-defined process: kinematics plus weight.
9973 ELSEIF(ISTSB.EQ.11) THEN
9974 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
9975 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
9980 IF(MINT(82).EQ.1) THEN
9981 NGEN(0,1)=NGEN(0,1)-1
9982 NGEN(ISUB,1)=NGEN(ISUB,1)-1
9984 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9988 C...Extract cross section event weight.
9989 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
9992 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
9994 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
9995 VINT(97)=SIGN(1D0,XWGTUP)
9997 VINT(97)=1D-9*XWGTUP
10000 C...Construct 'trivial' kinematical variables needed.
10003 VINT(41)=PUP(4,1)/EBMUP(1)
10004 VINT(42)=PUP(4,2)/EBMUP(2)
10005 IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
10006 CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
10007 & '(listing follows):')
10010 VINT(21)=VINT(41)*VINT(42)
10011 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
10012 VINT(44)=VINT(21)*VINT(2)
10013 VINT(43)=SQRT(MAX(0D0,VINT(44)))
10015 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
10016 VINT(56)=VINT(55)**2
10020 C...Construct other kinematical variables needed (approximately).
10023 VINT(45)=-0.5D0*VINT(44)
10024 VINT(46)=-0.5D0*VINT(44)
10033 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
10034 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
10036 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
10037 & '(PYRAND:) unacceptable ISTUP code for particles')
10038 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
10039 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
10040 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
10043 VINT(47)=SQRT(VINT(48))
10046 C...Choose azimuthal angle.
10048 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
10050 C...Check against user cuts on kinematics at parton level.
10052 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
10053 IF(MINT(51).NE.0) THEN
10054 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10055 IF(MFAIL.EQ.1) THEN
10061 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
10063 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
10064 & CALL PYKCUT(MCUT)
10066 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10067 IF(MFAIL.EQ.1) THEN
10075 IF(ISTSB.LE.10) THEN
10076 C... If internal process, call PYSIGH
10077 CALL PYSIGH(NCHN,SIGS)
10079 C... If external process, still have to set MI starting scale
10080 IF (MSTP(86).EQ.1) THEN
10081 C... Limit phase space by xT2 of hard interaction
10082 C... (gives undercounting of MI when ext proc != dijets)
10085 C... All accessible phase space allowed
10086 C... (gives double counting of MI when ext proc = dijets)
10087 XT2GMX = (1D0-VINT(41))*(1D0-VINT(42))
10089 VINT(62)=0.25D0*XT2GMX*VINT(2)
10090 VINT(61)=SQRT(MAX(0D0,VINT(62)))
10094 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
10096 C...Multiply cross section by lepton -> photon flux factor.
10097 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
10100 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
10102 SIGLPT=WTGAGA*SIGLPT
10105 C...Multiply cross-section by user-defined weights.
10106 IF(MSTP(173).EQ.1) THEN
10107 SIGS=PARP(173)*SIGS
10109 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
10111 SIGLPT=PARP(173)*SIGLPT
10117 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
10118 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
10119 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
10122 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
10125 C...Calculations for Monte Carlo estimate of all cross-sections.
10126 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
10127 IF(MSTP(142).LE.1) THEN
10128 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10130 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
10132 ELSEIF(MINT(82).EQ.1) THEN
10133 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10135 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
10136 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
10138 C...Multiple interactions: store results of cross-section calculation.
10139 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
10141 IF(MINT(35).LE.1) CALL PYMULT(4)
10142 IF(MINT(35).GE.2) CALL PYMIGN(4)
10145 C...Ratio of actual to maximum cross section.
10146 IF(ISTSB.NE.11) THEN
10147 VIOL=SIGSWT/XSEC(ISUB,1)
10148 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
10149 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
10150 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
10151 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
10152 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
10157 C...Check that weight not negative.
10158 IF(MSTP(123).LE.0) THEN
10159 IF(VIOL.LT.-1D-3) THEN
10160 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
10161 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10162 & VINT(22),VINT(23),VINT(26)
10166 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
10168 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
10169 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10170 & VINT(22),VINT(23),VINT(26)
10174 C...Weighting using estimate of maximum of differential cross-section.
10176 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
10177 IF(VIOL.LT.PYR(0)) THEN
10178 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10179 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
10182 ELSEIF(MFAIL.EQ.0) THEN
10183 RATND=SIGLPT/XSEC(95,1)
10185 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
10186 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
10187 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
10188 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10192 IF(VIOL.LT.PYR(0)) THEN
10195 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
10196 IF(VIOL.LT.PYR(0)) THEN
10198 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10202 RATND=SIGLPT/XSEC(95,1)
10203 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
10205 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10209 IF(VIOL.LT.PYR(0)) THEN
10210 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10215 C...Check for possible violation of estimated maximum of differential
10216 C...cross-section used in weighting.
10217 IF(MSTP(123).LE.0) THEN
10218 IF(VIOL.GT.1D0) THEN
10219 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
10220 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10221 & VINT(22),VINT(23),VINT(26)
10224 ELSEIF(MSTP(123).EQ.1) THEN
10225 IF(VIOL.GT.VINT(108)) THEN
10227 IF(VIOL.GT.1.0001D0) THEN
10229 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10230 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10231 & VINT(22),VINT(23),VINT(26)
10234 ELSEIF(VIOL.GT.VINT(108)) THEN
10236 IF(VIOL.GT.1D0) THEN
10238 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10239 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
10241 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
10242 IF(KFPR(ISUB,1).LE.9) THEN
10243 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
10244 & XMAXUP(KFPR(ISUB,1))
10245 ELSEIF(KFPR(ISUB,1).LE.99) THEN
10246 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
10247 & XMAXUP(KFPR(ISUB,1))
10249 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
10250 & XMAXUP(KFPR(ISUB,1))
10253 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
10254 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
10255 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
10256 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
10257 & XSEC(0,1)=XSEC(0,1)+XDIF
10258 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10259 & VINT(22),VINT(23),VINT(26)
10261 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
10262 ELSEIF(ISUB.LE.99) THEN
10263 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
10265 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
10272 C...Multiple interactions: choose impact parameter (if not already done).
10273 IF(MINT(39).EQ.0) VINT(148)=1D0
10274 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
10275 &MSTP(82).GE.3) THEN
10276 IF(MINT(35).LE.1) CALL PYMULT(5)
10277 IF(MINT(35).GE.2) CALL PYMIGN(5)
10278 IF(VINT(150).LT.PYR(0)) THEN
10279 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10280 IF(MFAIL.EQ.1) THEN
10287 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
10288 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
10289 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
10290 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
10292 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
10294 C...Choose flavour of reacting partons (and subprocess).
10295 IF(ISTSB.GE.11) GOTO 320
10298 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
10299 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
10300 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
10301 &PYR(0).GT.RQQBAR)) THEN
10305 MINT(2)=ISIG(ICHN,3)
10306 RSIGS=RSIGS-SIGH(ICHN)
10307 IF(RSIGS.LE.0D0) GOTO 320
10310 C...Multiple interactions: choose qqbar preferentially at small pT.
10311 ELSEIF(ISUB.EQ.96) THEN
10312 MINT(105)=MINT(103)
10313 MINT(109)=MINT(107)
10314 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
10315 MINT(105)=MINT(104)
10316 MINT(109)=MINT(108)
10317 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
10320 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
10322 C...Low-pT: choose string drawing configuration.
10328 IF(RSIGS.GT.1D0) MINT(2)=2
10329 IF(RSIGS.GT.2D0) MINT(2)=3
10332 C...Reassign QCD process. Partons before initial state radiation.
10333 320 IF(MINT(2).GT.10) THEN
10335 MINT(2)=MOD(MINT(2),10)
10337 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
10348 C...Calculate x value of photon for parton inside photon inside e.
10353 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
10354 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
10355 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
10356 IF(MSPLI.EQ.2) THEN
10360 MINT(105)=MINT(102+JT)
10361 MINT(109)=MINT(106+JT)
10362 VINT(120)=VINT(2+JT)
10364 C.... Store side in MINT(124)
10367 IF(MSTP(57).LE.1) THEN
10368 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
10370 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
10373 IF(MSTP(13).EQ.2) THEN
10374 Q2PMS=Q2HRD/PMAS(11,1)**2
10375 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
10377 330 XE=XHRD**PYR(0)
10378 XG=MIN(1D0-1D-10,XHRD/XE)
10379 IF(MSTP(57).LE.1) THEN
10380 CALL PYPDFU(22,XG,Q2HRD,XPQ)
10382 CALL PYPDFL(22,XG,Q2HRD,XPQ)
10384 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
10385 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
10386 IF(WT.LT.PYR(0)*WTMX) GOTO 330
10390 XSFX(JT,KFLS)=XPQ(KFLS)
10395 C...Pick scale where photon is resolved.
10399 IF(MINT(107).EQ.3) THEN
10400 IF(MSTP(66).EQ.1) THEN
10401 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
10402 ELSEIF(MSTP(66).EQ.2) THEN
10404 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10405 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10406 Q2INT=SQRT(Q0S*Q2EFF)
10407 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10408 ELSEIF(MSTP(66).EQ.3) THEN
10409 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
10410 ELSEIF(MSTP(66).GE.4) THEN
10411 PS=0.25D0*VINT(3)**2
10412 VINT(283)=(Q0S+PS)*(Q1S+PS)/
10413 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10417 IF(MINT(108).EQ.3) THEN
10418 IF(MSTP(66).EQ.1) THEN
10419 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
10420 ELSEIF(MSTP(66).EQ.2) THEN
10422 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10423 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10424 Q2INT=SQRT(Q0S*Q2EFF)
10425 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10426 ELSEIF(MSTP(66).EQ.3) THEN
10427 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
10428 ELSEIF(MSTP(66).GE.4) THEN
10429 PS=0.25D0*VINT(4)**2
10430 VINT(284)=(Q0S+PS)*(Q1S+PS)/
10431 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10434 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10436 C...Format statements for differential cross-section maximum violations.
10437 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
10438 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10439 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
10440 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
10441 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
10443 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
10444 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10445 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
10447 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
10448 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
10449 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
10450 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
10451 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
10452 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
10457 C*********************************************************************
10460 C...Finds outgoing flavours and event type; sets up the kinematics
10461 C...and colour flow of the hard scattering
10465 C...Double precision and integer declarations
10466 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10467 IMPLICIT INTEGER(I-N)
10468 INTEGER PYK,PYCHGE,PYCOMP
10469 C...Parameter statement to help give large particle numbers.
10470 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
10471 &KEXCIT=4000000,KDIMEN=5000000)
10472 C...Parameter statement for maximum size of showers.
10473 PARAMETER (MAXNUR=1000)
10475 C...User process event common block.
10477 PARAMETER (MAXNUP=500)
10478 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10479 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10480 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
10481 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
10482 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
10486 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
10487 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10488 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10489 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10490 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
10491 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10492 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10493 COMMON/PYINT1/MINT(400),VINT(400)
10494 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10495 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10496 COMMON/PYINT4/MWID(500),WIDS(500,5)
10497 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10498 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
10499 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
10500 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
10501 COMMON/PYPUED/IUED(0:99),RUED(0:99)
10502 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
10503 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
10505 C...Local arrays and saved variables
10506 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
10507 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
10508 INTEGER IOKFLA(6),IIFLAV
10509 C...UED related declarations:
10510 C...equivalences between ordered particles (451->475)
10511 C...and UED particle code (5 000 000 + id)
10512 DIMENSION IUEDEQ(475),MUED(2)
10513 DATA (IUEDEQ(I),I=451,475)/
10514 & 6100001,6100002,6100003,6100004,6100005,6100006,
10515 & 5100001,5100002,5100003,5100004,5100005,5100006,
10516 & 6100011,6100013,6100015,
10517 & 5100012,5100011,5100014,5100013,5100016,5100015,
10518 & 5100021,5100022,5100023,5100024/
10521 C...Read out process
10525 C...Restore information for low-pT processes
10526 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
10528 100 VINT(J)=VINTSV(J)
10531 C...Convert H' or A process into equivalent H one
10534 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
10535 &ISUB.LE.190)) THEN
10537 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
10539 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
10540 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
10541 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
10542 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
10543 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
10544 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
10545 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
10546 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
10547 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
10548 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
10549 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
10550 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
10553 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
10555 C...Convert bottomonium process into equivalent charmonium ones.
10556 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
10558 C...Choice of subprocess, number of documentation lines
10560 IF(ISUB.EQ.95) IDOC=8
10561 IF(ISET(ISUB).EQ.5) IDOC=9
10562 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
10564 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
10573 C...Reset K, P and V vectors. Store incoming particles
10574 DO 120 JT=1,MSTP(126)+100
10576 IF(I.GT.MSTU(4)) GOTO 120
10588 P(I,J)=VINT(285+5*JT+J)
10594 C...Store incoming partons in their CM-frame. Save pdf value.
10597 SHP=VINT(26)*VINT(2)
10600 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
10605 K(I,3)=MINT(83)+2+JT
10606 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
10607 P(I,4)=0.5D0*SHUSER
10608 IF(MINT(14+JT).GE.-40.AND.MINT(14+JT).LE.40) THEN
10609 VINT(38+JT)=XSFX(JT,MINT(14+JT))
10615 C...Copy incoming partons to documentation lines
10627 C...Choose new quark/lepton flavour for relevant annihilation graphs
10628 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
10629 &ISUB.EQ.314.OR.ISUB.EQ.319.OR.ISUB.EQ.316.OR.
10630 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
10632 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
10633 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
10634 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
10635 DO 190 I=1,MDCY(IGLGA,3)
10636 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
10637 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
10638 IF(RKFL.LE.0D0) GOTO 200
10641 IF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319
10642 & .OR.ISUB.EQ.316).AND.MINT(2).LE.2) THEN
10643 IF(KFLF.GE.4) GOTO 180
10644 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10645 & OR.ISUB.EQ.316).AND.MINT(2).LE.4) THEN
10648 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10649 & OR.ISUB.EQ.316) THEN
10652 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
10653 & .AND.IABS(KFLF).GE.3) THEN
10654 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
10656 FACCIB=VINT(46)**2/RTCM(41)**4
10657 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
10658 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
10661 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
10662 IF(KFLF.EQ.5) GOTO 180
10663 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10664 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
10665 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
10666 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
10670 C...Final state flavours and colour flow: default values
10677 KCS=ISIGN(1,MINT(15))
10679 IF(ISET(ISUB).EQ.11) THEN
10680 C...User-defined processes: find products
10683 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
10684 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
10685 MINT(21+IUP)=IDUP(IUP)
10686 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
10687 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
10688 ELSEIF(IDUP(IUP).EQ.0) THEN
10691 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
10695 ELSEIF(ISUB.LE.10) THEN
10697 C...f + fbar -> gamma*/Z0
10700 ELSEIF(ISUB.EQ.2) THEN
10701 C...f + fbar' -> W+/-
10702 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10703 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10704 KFRES=ISIGN(24,KCH1+KCH2)
10706 ELSEIF(ISUB.EQ.3) THEN
10707 C...f + fbar -> h0 (or H0, or A0)
10710 ELSEIF(ISUB.EQ.4) THEN
10711 C...gamma + W+/- -> W+/-
10713 ELSEIF(ISUB.EQ.5) THEN
10718 PMQ(1)=PYMASS(MINT(21))
10719 PMQ(2)=PYMASS(MINT(22))
10720 220 JT=INT(1.5D0+PYR(0))
10721 ZMIN=2D0*PMQ(JT)/SHPR
10722 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10723 & (SHPR*(SHPR-PMQ(3-JT)))
10724 ZMAX=MIN(1D0-XH,ZMAX)
10725 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10726 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10727 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
10728 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10729 IF(SQC1.LT.1D-8) GOTO 220
10731 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10732 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10733 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10734 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10735 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10736 IF(SQC1.LT.1D-8) GOTO 220
10738 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10739 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10740 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10741 PHIR=PARU(2)*PYR(0)
10743 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10744 & SQRT(1D0-CTHE(2)**2)*CPHI
10746 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10747 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10748 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10749 & PMQ(3-JT)**2/SHP))
10750 ZMIN=2D0*PMQ(3-JT)/SHPR
10751 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10752 ZMAX=MIN(1D0-XH,ZMAX)
10753 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10757 ELSEIF(ISUB.EQ.6) THEN
10758 C...Z0 + W+/- -> W+/-
10760 ELSEIF(ISUB.EQ.7) THEN
10763 ELSEIF(ISUB.EQ.8) THEN
10770 RVCKM=VINT(180+I)*PYR(0)
10773 IPM=(5-ISIGN(1,I))/2
10775 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10776 MINT(20+JT)=ISIGN(IB,I)
10777 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10778 IF(RVCKM.LE.0D0) GOTO 250
10781 IB=2*((IA+1)/2)-1+MOD(IA,2)
10782 MINT(20+JT)=ISIGN(IB,I)
10784 250 PMQ(JT)=PYMASS(MINT(20+JT))
10786 JT=INT(1.5D0+PYR(0))
10787 ZMIN=2D0*PMQ(JT)/SHPR
10788 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10789 & (SHPR*(SHPR-PMQ(3-JT)))
10790 ZMAX=MIN(1D0-XH,ZMAX)
10791 IF(ZMIN.GE.ZMAX) GOTO 230
10792 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10793 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10794 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10795 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10796 IF(SQC1.LT.1D-8) GOTO 230
10798 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10799 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10800 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10801 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10802 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10803 IF(SQC1.LT.1D-8) GOTO 230
10805 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10806 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10807 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10808 PHIR=PARU(2)*PYR(0)
10810 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10811 & SQRT(1D0-CTHE(2)**2)*CPHI
10813 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10814 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10815 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10816 & PMQ(3-JT)**2/SHP))
10817 ZMIN=2D0*PMQ(3-JT)/SHPR
10818 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10819 ZMAX=MIN(1D0-XH,ZMAX)
10820 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10824 ELSEIF(ISUB.EQ.10) THEN
10825 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10826 IF(MINT(2).EQ.1) THEN
10829 C...W exchange: need to mix flavours according to CKM matrix
10834 RVCKM=VINT(180+I)*PYR(0)
10837 IPM=(5-ISIGN(1,I))/2
10839 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10840 MINT(20+JT)=ISIGN(IB,I)
10841 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10842 IF(RVCKM.LE.0D0) GOTO 280
10845 IB=2*((IA+1)/2)-1+MOD(IA,2)
10846 MINT(20+JT)=ISIGN(IB,I)
10853 ELSEIF(ISUB.LE.20) THEN
10854 IF(ISUB.EQ.11) THEN
10855 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10857 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10859 ELSEIF(ISUB.EQ.12) THEN
10860 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10861 MINT(21)=ISIGN(KFLF,MINT(15))
10865 ELSEIF(ISUB.EQ.13) THEN
10866 C...f + fbar -> g + g; th arbitrary
10871 ELSEIF(ISUB.EQ.14) THEN
10872 C...f + fbar -> g + gamma; th arbitrary
10873 IF(PYR(0).GT.0.5D0) JS=2
10878 ELSEIF(ISUB.EQ.15) THEN
10879 C...f + fbar -> g + Z0; th arbitrary
10880 IF(PYR(0).GT.0.5D0) JS=2
10885 ELSEIF(ISUB.EQ.16) THEN
10886 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10887 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10888 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10889 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10891 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10894 ELSEIF(ISUB.EQ.17) THEN
10895 C...f + fbar -> g + h0; th arbitrary
10896 IF(PYR(0).GT.0.5D0) JS=2
10901 ELSEIF(ISUB.EQ.18) THEN
10902 C...f + fbar -> gamma + gamma; th arbitrary
10906 ELSEIF(ISUB.EQ.19) THEN
10907 C...f + fbar -> gamma + Z0; th arbitrary
10908 IF(PYR(0).GT.0.5D0) JS=2
10912 ELSEIF(ISUB.EQ.20) THEN
10913 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
10914 C...(p(fbar')-p(W+))**2
10915 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10916 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10917 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10919 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10922 ELSEIF(ISUB.LE.30) THEN
10923 IF(ISUB.EQ.21) THEN
10924 C...f + fbar -> gamma + h0; th arbitrary
10925 IF(PYR(0).GT.0.5D0) JS=2
10929 ELSEIF(ISUB.EQ.22) THEN
10930 C...f + fbar -> Z0 + Z0; th arbitrary
10934 ELSEIF(ISUB.EQ.23) THEN
10935 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10936 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10937 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10938 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10940 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10942 ELSEIF(ISUB.EQ.24) THEN
10943 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
10944 IF(PYR(0).GT.0.5D0) JS=2
10948 ELSEIF(ISUB.EQ.25) THEN
10949 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
10950 MINT(21)=-ISIGN(24,MINT(15))
10953 ELSEIF(ISUB.EQ.26) THEN
10954 C...f + fbar' -> W+/- + h0 (or H0, or A0);
10955 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10956 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10957 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10958 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10959 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
10962 ELSEIF(ISUB.EQ.27) THEN
10963 C...f + fbar -> h0 + h0
10965 ELSEIF(ISUB.EQ.28) THEN
10966 C...f + g -> f + g; th = (p(f)-p(f))**2
10967 IF(MINT(15).EQ.21) JS=2
10969 IF(MINT(15).EQ.21) KCC=KCC+2
10970 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10971 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10973 ELSEIF(ISUB.EQ.29) THEN
10974 C...f + g -> f + gamma; th = (p(f)-p(f))**2
10975 IF(MINT(15).EQ.21) JS=2
10978 KCS=ISIGN(1,MINT(14+JS))
10980 ELSEIF(ISUB.EQ.30) THEN
10981 C...f + g -> f + Z0; th = (p(f)-p(f))**2
10982 IF(MINT(15).EQ.21) JS=2
10985 KCS=ISIGN(1,MINT(14+JS))
10988 ELSEIF(ISUB.LE.40) THEN
10989 IF(ISUB.EQ.31) THEN
10990 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
10991 IF(MINT(15).EQ.21) JS=2
10994 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10995 RVCKM=VINT(180+I)*PYR(0)
10998 IPM=(5-ISIGN(1,I))/2
11000 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
11001 MINT(20+JS)=ISIGN(IB,I)
11002 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11003 IF(RVCKM.LE.0D0) GOTO 300
11006 KCS=ISIGN(1,MINT(14+JS))
11008 ELSEIF(ISUB.EQ.32) THEN
11009 C...f + g -> f + h0; th = (p(f)-p(f))**2
11010 IF(MINT(15).EQ.21) JS=2
11013 KCS=ISIGN(1,MINT(14+JS))
11015 ELSEIF(ISUB.EQ.33) THEN
11016 C...f + gamma -> f + g; th=(p(f)-p(f))**2
11017 IF(MINT(15).EQ.22) JS=2
11020 KCS=ISIGN(1,MINT(14+JS))
11022 ELSEIF(ISUB.EQ.34) THEN
11023 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
11024 IF(MINT(15).EQ.22) JS=2
11026 KCS=ISIGN(1,MINT(14+JS))
11028 ELSEIF(ISUB.EQ.35) THEN
11029 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
11030 IF(MINT(15).EQ.22) JS=2
11034 ELSEIF(ISUB.EQ.36) THEN
11035 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
11036 IF(MINT(15).EQ.22) JS=2
11039 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11041 RVCKM=VINT(180+I)*PYR(0)
11044 IPM=(5-ISIGN(1,I))/2
11046 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
11047 MINT(20+JS)=ISIGN(IB,I)
11048 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11049 IF(RVCKM.LE.0D0) GOTO 320
11052 IB=2*((IA+1)/2)-1+MOD(IA,2)
11053 MINT(20+JS)=ISIGN(IB,I)
11057 ELSEIF(ISUB.EQ.37) THEN
11058 C...f + gamma -> f + h0
11060 ELSEIF(ISUB.EQ.38) THEN
11061 C...f + Z0 -> f + g
11063 ELSEIF(ISUB.EQ.39) THEN
11064 C...f + Z0 -> f + gamma
11066 ELSEIF(ISUB.EQ.40) THEN
11067 C...f + Z0 -> f + Z0
11070 ELSEIF(ISUB.LE.50) THEN
11071 IF(ISUB.EQ.41) THEN
11072 C...f + Z0 -> f' + W+/-
11074 ELSEIF(ISUB.EQ.42) THEN
11075 C...f + Z0 -> f + h0
11077 ELSEIF(ISUB.EQ.43) THEN
11078 C...f + W+/- -> f' + g
11080 ELSEIF(ISUB.EQ.44) THEN
11081 C...f + W+/- -> f' + gamma
11083 ELSEIF(ISUB.EQ.45) THEN
11084 C...f + W+/- -> f' + Z0
11086 ELSEIF(ISUB.EQ.46) THEN
11087 C...f + W+/- -> f' + W+/-
11089 ELSEIF(ISUB.EQ.47) THEN
11090 C...f + W+/- -> f' + h0
11092 ELSEIF(ISUB.EQ.48) THEN
11093 C...f + h0 -> f + g
11095 ELSEIF(ISUB.EQ.49) THEN
11096 C...f + h0 -> f + gamma
11098 ELSEIF(ISUB.EQ.50) THEN
11099 C...f + h0 -> f + Z0
11102 ELSEIF(ISUB.LE.60) THEN
11103 IF(ISUB.EQ.51) THEN
11104 C...f + h0 -> f' + W+/-
11106 ELSEIF(ISUB.EQ.52) THEN
11107 C...f + h0 -> f + h0
11109 ELSEIF(ISUB.EQ.53) THEN
11110 C...g + g -> f + fbar; th arbitrary
11111 KCS=(-1)**INT(1.5D0+PYR(0))
11112 MINT(21)=ISIGN(KFLF,KCS)
11116 ELSEIF(ISUB.EQ.54) THEN
11117 C...g + gamma -> f + fbar; th arbitrary
11118 KCS=(-1)**INT(1.5D0+PYR(0))
11119 MINT(21)=ISIGN(KFLF,KCS)
11122 IF(MINT(16).EQ.21) KCC=28
11124 ELSEIF(ISUB.EQ.55) THEN
11125 C...g + Z0 -> f + fbar
11127 ELSEIF(ISUB.EQ.56) THEN
11128 C...g + W+/- -> f + fbar'
11130 ELSEIF(ISUB.EQ.57) THEN
11131 C...g + h0 -> f + fbar
11133 ELSEIF(ISUB.EQ.58) THEN
11134 C...gamma + gamma -> f + fbar; th arbitrary
11135 KCS=(-1)**INT(1.5D0+PYR(0))
11136 MINT(21)=ISIGN(KFLF,KCS)
11140 ELSEIF(ISUB.EQ.59) THEN
11141 C...gamma + Z0 -> f + fbar
11143 ELSEIF(ISUB.EQ.60) THEN
11144 C...gamma + W+/- -> f + fbar'
11147 ELSEIF(ISUB.LE.70) THEN
11148 IF(ISUB.EQ.61) THEN
11149 C...gamma + h0 -> f + fbar
11151 ELSEIF(ISUB.EQ.62) THEN
11152 C...Z0 + Z0 -> f + fbar
11154 ELSEIF(ISUB.EQ.63) THEN
11155 C...Z0 + W+/- -> f + fbar'
11157 ELSEIF(ISUB.EQ.64) THEN
11158 C...Z0 + h0 -> f + fbar
11160 ELSEIF(ISUB.EQ.65) THEN
11161 C...W+ + W- -> f + fbar
11163 ELSEIF(ISUB.EQ.66) THEN
11164 C...W+/- + h0 -> f + fbar'
11166 ELSEIF(ISUB.EQ.67) THEN
11167 C...h0 + h0 -> f + fbar
11169 ELSEIF(ISUB.EQ.68) THEN
11170 C...g + g -> g + g; th arbitrary
11172 KCS=(-1)**INT(1.5D0+PYR(0))
11174 ELSEIF(ISUB.EQ.69) THEN
11175 C...gamma + gamma -> W+ + W-; th arbitrary
11180 ELSEIF(ISUB.EQ.70) THEN
11181 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
11182 IF(MINT(15).EQ.22) MINT(21)=23
11183 IF(MINT(16).EQ.22) MINT(22)=23
11187 ELSEIF(ISUB.LE.80) THEN
11188 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
11189 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
11193 PMQ(1)=PYMASS(MINT(21))
11194 PMQ(2)=PYMASS(MINT(22))
11195 330 JT=INT(1.5D0+PYR(0))
11196 ZMIN=2D0*PMQ(JT)/SHPR
11197 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11198 & (SHPR*(SHPR-PMQ(3-JT)))
11199 ZMAX=MIN(1D0-XH,ZMAX)
11200 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11201 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11202 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
11203 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11204 IF(SQC1.LT.1D-8) GOTO 330
11206 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11207 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11208 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11209 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11210 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11211 IF(SQC1.LT.1D-8) GOTO 330
11213 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11214 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11215 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11216 PHIR=PARU(2)*PYR(0)
11218 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11219 & SQRT(1D0-CTHE(2)**2)*CPHI
11221 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11222 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11223 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11224 & PMQ(3-JT)**2/SHP))
11225 ZMIN=2D0*PMQ(3-JT)/SHPR
11226 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11227 ZMAX=MIN(1D0-XH,ZMAX)
11228 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
11231 ELSEIF(ISUB.EQ.73) THEN
11232 C...Z0 + W+/- -> Z0 + W+/-
11239 RVCKM=VINT(180+I)*PYR(0)
11242 IPM=(5-ISIGN(1,I))/2
11244 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
11245 MINT(20+JT)=ISIGN(IB,I)
11246 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11247 IF(RVCKM.LE.0D0) GOTO 360
11250 IB=2*((IA+1)/2)-1+MOD(IA,2)
11251 MINT(20+JT)=ISIGN(IB,I)
11253 360 PMQ(JT)=PYMASS(MINT(20+JT))
11254 MINT(23-JT)=MINT(17-JT)
11255 PMQ(3-JT)=PYMASS(MINT(23-JT))
11256 JT=INT(1.5D0+PYR(0))
11257 ZMIN=2D0*PMQ(JT)/SHPR
11258 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11259 & (SHPR*(SHPR-PMQ(3-JT)))
11260 ZMAX=MIN(1D0-XH,ZMAX)
11261 IF(ZMIN.GE.ZMAX) GOTO 340
11262 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11263 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11264 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
11265 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11266 IF(SQC1.LT.1D-8) GOTO 340
11268 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11269 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11270 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11271 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11272 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11273 IF(SQC1.LT.1D-8) GOTO 340
11275 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11276 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11277 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11278 PHIR=PARU(2)*PYR(0)
11280 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11281 & SQRT(1D0-CTHE(2)**2)*CPHI
11283 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11284 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11285 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11286 & PMQ(3-JT)**2/SHP))
11287 ZMIN=2D0*PMQ(3-JT)/SHPR
11288 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11289 ZMAX=MIN(1D0-XH,ZMAX)
11290 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
11293 ELSEIF(ISUB.EQ.74) THEN
11294 C...Z0 + h0 -> Z0 + h0
11296 ELSEIF(ISUB.EQ.75) THEN
11297 C...W+ + W- -> gamma + gamma
11299 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
11300 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
11306 RVCKM=VINT(180+I)*PYR(0)
11309 IPM=(5-ISIGN(1,I))/2
11311 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
11312 MINT(20+JT)=ISIGN(IB,I)
11313 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11314 IF(RVCKM.LE.0D0) GOTO 390
11317 IB=2*((IA+1)/2)-1+MOD(IA,2)
11318 MINT(20+JT)=ISIGN(IB,I)
11320 390 PMQ(JT)=PYMASS(MINT(20+JT))
11322 JT=INT(1.5D0+PYR(0))
11323 ZMIN=2D0*PMQ(JT)/SHPR
11324 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11325 & (SHPR*(SHPR-PMQ(3-JT)))
11326 ZMAX=MIN(1D0-XH,ZMAX)
11327 IF(ZMIN.GE.ZMAX) GOTO 370
11328 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11329 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11330 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
11331 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11332 IF(SQC1.LT.1D-8) GOTO 370
11334 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11335 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11336 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11337 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11338 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11339 IF(SQC1.LT.1D-8) GOTO 370
11341 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11342 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11343 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11344 PHIR=PARU(2)*PYR(0)
11346 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11347 & SQRT(1D0-CTHE(2)**2)*CPHI
11349 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11350 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11351 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11352 & PMQ(3-JT)**2/SHP))
11353 ZMIN=2D0*PMQ(3-JT)/SHPR
11354 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11355 ZMAX=MIN(1D0-XH,ZMAX)
11356 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
11359 ELSEIF(ISUB.EQ.78) THEN
11360 C...W+/- + h0 -> W+/- + h0
11362 ELSEIF(ISUB.EQ.79) THEN
11363 C...h0 + h0 -> h0 + h0
11365 ELSEIF(ISUB.EQ.80) THEN
11366 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11367 IF(MINT(15).EQ.22) JS=2
11370 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
11372 MINT(20+JS)=ISIGN(IB,I)
11376 ELSEIF(ISUB.LE.90) THEN
11377 IF(ISUB.EQ.81) THEN
11378 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11379 MINT(21)=ISIGN(MINT(55),MINT(15))
11383 ELSEIF(ISUB.EQ.82) THEN
11384 C...g + g -> Q + Qbar; th arbitrary
11385 KCS=(-1)**INT(1.5D0+PYR(0))
11386 MINT(21)=ISIGN(MINT(55),KCS)
11390 ELSEIF(ISUB.EQ.83) THEN
11391 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11393 IF(MINT(2).EQ.2) KFOLD=MINT(15)
11395 IF(KFAOLD.GT.10) THEN
11396 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
11398 RCKM=VINT(180+KFOLD)*PYR(0)
11399 IPM=(5-ISIGN(1,KFOLD))/2
11400 KFANEW=-MOD(KFAOLD+1,2)
11401 410 KFANEW=KFANEW+2
11402 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
11403 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
11404 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
11405 & VCKM(KFAOLD/2,(KFANEW+1)/2)
11406 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
11407 & VCKM(KFANEW/2,(KFAOLD+1)/2)
11409 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
11411 IF(MINT(2).EQ.1) THEN
11412 MINT(21)=ISIGN(MINT(55),MINT(15))
11413 MINT(22)=ISIGN(KFANEW,MINT(16))
11415 MINT(21)=ISIGN(KFANEW,MINT(15))
11416 MINT(22)=ISIGN(MINT(55),MINT(16))
11421 ELSEIF(ISUB.EQ.84) THEN
11422 C...g + gamma -> Q + Qbar; th arbitary
11423 KCS=(-1)**INT(1.5D0+PYR(0))
11424 MINT(21)=ISIGN(MINT(55),KCS)
11427 IF(MINT(16).EQ.21) KCC=28
11429 ELSEIF(ISUB.EQ.85) THEN
11430 C...gamma + gamma -> F + Fbar; th arbitary
11431 KCS=(-1)**INT(1.5D0+PYR(0))
11432 MINT(21)=ISIGN(MINT(56),KCS)
11436 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
11437 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11438 MINT(21)=KFPR(ISUB,1)
11439 MINT(22)=KFPR(ISUB,2)
11441 KCS=(-1)**INT(1.5D0+PYR(0))
11444 ELSEIF(ISUB.LE.100) THEN
11445 IF(ISUB.EQ.95) THEN
11446 C...Low-pT ( = energyless g + g -> g + g)
11448 KCS=(-1)**INT(1.5D0+PYR(0))
11450 ELSEIF(ISUB.EQ.96) THEN
11451 C...Multiple interactions (should be reassigned to QCD process)
11454 ELSEIF(ISUB.LE.110) THEN
11455 IF(ISUB.EQ.101) THEN
11456 C...g + g -> gamma*/Z0
11460 ELSEIF(ISUB.EQ.102) THEN
11461 C...g + g -> h0 (or H0, or A0)
11465 ELSEIF(ISUB.EQ.103) THEN
11466 C...gamma + gamma -> h0 (or H0, or A0)
11470 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
11471 C...g + g -> chi_0c or chi_2c.
11475 ELSEIF(ISUB.EQ.106) THEN
11476 C...g + g -> J/Psi + gamma
11477 MINT(21)=KFPR(ISUB,1)
11478 MINT(22)=KFPR(ISUB,2)
11481 ELSEIF(ISUB.EQ.107) THEN
11482 C...g + gamma -> J/Psi + g
11483 MINT(21)=KFPR(ISUB,1)
11484 MINT(22)=KFPR(ISUB,2)
11486 IF(MINT(16).EQ.22) KCC=33
11488 ELSEIF(ISUB.EQ.108) THEN
11489 C...gamma + gamma -> J/Psi + gamma
11490 MINT(21)=KFPR(ISUB,1)
11491 MINT(22)=KFPR(ISUB,2)
11493 ELSEIF(ISUB.EQ.110) THEN
11494 C...f + fbar -> gamma + h0; th arbitrary
11495 IF(PYR(0).GT.0.5D0) JS=2
11500 ELSEIF(ISUB.LE.120) THEN
11501 IF(ISUB.EQ.111) THEN
11502 C...f + fbar -> g + h0; th arbitrary
11503 IF(PYR(0).GT.0.5D0) JS=2
11508 ELSEIF(ISUB.EQ.112) THEN
11509 C...f + g -> f + h0; th = (p(f) - p(f))**2
11510 IF(MINT(15).EQ.21) JS=2
11513 KCS=ISIGN(1,MINT(14+JS))
11515 ELSEIF(ISUB.EQ.113) THEN
11516 C...g + g -> g + h0; th arbitrary
11517 IF(PYR(0).GT.0.5D0) JS=2
11520 KCS=(-1)**INT(1.5D0+PYR(0))
11522 ELSEIF(ISUB.EQ.114) THEN
11523 C...g + g -> gamma + gamma; th arbitrary
11524 IF(PYR(0).GT.0.5D0) JS=2
11529 ELSEIF(ISUB.EQ.115) THEN
11530 C...g + g -> g + gamma; th arbitrary
11531 IF(PYR(0).GT.0.5D0) JS=2
11534 KCS=(-1)**INT(1.5D0+PYR(0))
11536 ELSEIF(ISUB.EQ.116) THEN
11537 C...g + g -> gamma + Z0
11539 ELSEIF(ISUB.EQ.117) THEN
11540 C...g + g -> Z0 + Z0
11542 ELSEIF(ISUB.EQ.118) THEN
11543 C...g + g -> W+ + W-
11546 ELSEIF(ISUB.LE.140) THEN
11547 IF(ISUB.EQ.121) THEN
11548 C...g + g -> Q + Qbar + h0
11549 KCS=(-1)**INT(1.5D0+PYR(0))
11550 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11552 KCC=11+INT(0.5D0+PYR(0))
11555 ELSEIF(ISUB.EQ.122) THEN
11556 C...q + qbar -> Q + Qbar + h0
11557 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
11562 ELSEIF(ISUB.EQ.123) THEN
11563 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11568 ELSEIF(ISUB.EQ.124) THEN
11569 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11575 RVCKM=VINT(180+I)*PYR(0)
11578 IPM=(5-ISIGN(1,I))/2
11580 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
11581 MINT(20+JT)=ISIGN(IB,I)
11582 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11583 IF(RVCKM.LE.0D0) GOTO 430
11586 IB=2*((IA+1)/2)-1+MOD(IA,2)
11587 MINT(20+JT)=ISIGN(IB,I)
11593 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
11594 C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11595 IF(MINT(15).EQ.22) JS=2
11598 KCS=ISIGN(1,MINT(14+JS))
11600 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
11601 C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11602 IF(MINT(15).EQ.22) JS=2
11604 KCS=ISIGN(1,MINT(14+JS))
11606 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
11607 C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11608 KCS=(-1)**INT(1.5D0+PYR(0))
11609 MINT(21)=ISIGN(KFLF,KCS)
11612 IF(MINT(16).EQ.21) KCC=28
11614 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
11615 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11616 KCS=(-1)**INT(1.5D0+PYR(0))
11617 MINT(21)=ISIGN(KFLF,KCS)
11623 ELSEIF(ISUB.LE.160) THEN
11624 IF(ISUB.EQ.141) THEN
11625 C...f + fbar -> gamma*/Z0/Z'0
11628 ELSEIF(ISUB.EQ.142) THEN
11629 C...f + fbar' -> W'+/-
11630 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11631 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11632 KFRES=ISIGN(34,KCH1+KCH2)
11634 ELSEIF(ISUB.EQ.143) THEN
11635 C...f + fbar' -> H+/-
11636 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11637 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11638 KFRES=ISIGN(37,KCH1+KCH2)
11640 ELSEIF(ISUB.EQ.144) THEN
11642 KFRES=ISIGN(41,MINT(15)+MINT(16))
11644 ELSEIF(ISUB.EQ.145) THEN
11645 C...q + l -> LQ (leptoquark)
11646 IF(IABS(MINT(16)).LE.8) JS=2
11647 KFRES=ISIGN(42,MINT(14+JS))
11649 KCS=ISIGN(1,MINT(14+JS))
11651 ELSEIF(ISUB.EQ.146) THEN
11652 C...e + gamma -> e* (excited lepton)
11653 IF(MINT(15).EQ.22) JS=2
11654 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11657 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
11658 C...q + g -> q* (excited quark)
11659 IF(MINT(15).EQ.21) JS=2
11660 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11662 KCS=ISIGN(1,MINT(14+JS))
11664 ELSEIF(ISUB.EQ.149) THEN
11665 C...g + g -> eta_tc
11668 KCS=(-1)**INT(1.5D0+PYR(0))
11671 ELSEIF(ISUB.LE.200) THEN
11672 IF(ISUB.EQ.161) THEN
11673 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11674 IF(MINT(15).EQ.21) JS=2
11677 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
11678 IB=IA+MOD(IA,2)-MOD(IA+1,2)
11679 MINT(20+JS)=ISIGN(IB,I)
11681 KCS=ISIGN(1,MINT(14+JS))
11683 ELSEIF(ISUB.EQ.162) THEN
11684 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11685 IF(MINT(15).EQ.21) JS=2
11686 MINT(20+JS)=ISIGN(42,MINT(14+JS))
11687 KFLQL=KFDP(MDCY(42,2),2)
11688 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
11690 KCS=ISIGN(1,MINT(14+JS))
11692 ELSEIF(ISUB.EQ.163) THEN
11693 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11694 KCS=(-1)**INT(1.5D0+PYR(0))
11695 MINT(21)=ISIGN(42,KCS)
11699 ELSEIF(ISUB.EQ.164) THEN
11700 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11701 MINT(21)=ISIGN(42,MINT(15))
11705 ELSEIF(ISUB.EQ.165) THEN
11706 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11707 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11710 ELSEIF(ISUB.EQ.166) THEN
11711 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11712 IF(MOD(MINT(15),2).EQ.0) THEN
11713 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11714 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11716 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11717 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11720 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
11721 C...q + q' -> q" + q* (excited quark)
11722 KFQSTR=KFPR(ISUB,2)
11723 KFQEXC=MOD(KFQSTR,KEXCIT)
11725 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11726 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
11727 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11731 ELSEIF(ISUB.EQ.169) THEN
11732 C...q + qbar -> e + e* (excited lepton)
11733 KFQSTR=KFPR(ISUB,2)
11734 KFQEXC=MOD(KFQSTR,KEXCIT)
11736 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11737 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11740 ELSEIF(ISUB.EQ.191) THEN
11741 C...f + fbar -> rho_tc0.
11744 ELSEIF(ISUB.EQ.192) THEN
11745 C...f + fbar' -> rho_tc+/-
11746 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11747 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11748 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11750 ELSEIF(ISUB.EQ.193) THEN
11751 C...f + fbar -> omega_tc0.
11754 ELSEIF(ISUB.EQ.194) THEN
11755 C...f + fbar -> f' + fbar' via mixture of s-channel
11756 C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11757 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11760 ELSEIF(ISUB.EQ.195) THEN
11761 C...f + fbar' -> f'' + fbar''' via s-channel
11762 C...rho_tc+ th=(p(f)-p(f'))**2
11763 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11764 IF(MOD(MINT(15),2).EQ.0) THEN
11765 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11766 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11768 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11769 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11774 ELSEIF(ISUB.LE.215) THEN
11775 IF(ISUB.EQ.201) THEN
11776 C...f + fbar -> ~e_L + ~e_Lbar
11777 MINT(21)=ISIGN(KSUSY1+11,KCS)
11780 ELSEIF(ISUB.EQ.202) THEN
11781 C...f + fbar -> ~e_R + ~e_Rbar
11782 MINT(21)=ISIGN(KSUSY2+11,KCS)
11785 ELSEIF(ISUB.EQ.203) THEN
11786 C...f + fbar -> ~e_L + ~e_Rbar
11787 IF(MINT(15).LT.0) JS=2
11788 IF(MINT(2).EQ.1) THEN
11789 MINT(20+JS)=KFPR(ISUB,1)
11790 MINT(23-JS)=-KFPR(ISUB,2)
11792 MINT(20+JS)=-KFPR(ISUB,1)
11793 MINT(23-JS)=KFPR(ISUB,2)
11796 ELSEIF(ISUB.EQ.204) THEN
11797 C...f + fbar -> ~mu_L + ~mu_Lbar
11798 MINT(21)=ISIGN(KSUSY1+13,KCS)
11801 ELSEIF(ISUB.EQ.205) THEN
11802 C...f + fbar -> ~mu_R + ~mu_Rbar
11803 MINT(21)=ISIGN(KSUSY2+13,KCS)
11806 ELSEIF(ISUB.EQ.206) THEN
11807 C...f + fbar -> ~mu_L + ~mu_Rbar
11808 IF(MINT(15).LT.0) JS=2
11809 IF(MINT(2).EQ.1) THEN
11810 MINT(20+JS)=KFPR(ISUB,1)
11811 MINT(23-JS)=-KFPR(ISUB,2)
11813 MINT(20+JS)=-KFPR(ISUB,1)
11814 MINT(23-JS)=KFPR(ISUB,2)
11817 ELSEIF(ISUB.EQ.207) THEN
11818 C...f + fbar -> ~tau_1 + ~tau_1bar
11819 MINT(21)=ISIGN(KSUSY1+15,KCS)
11822 ELSEIF(ISUB.EQ.208) THEN
11823 C...f + fbar -> ~tau_2 + ~tau_2bar
11824 MINT(21)=ISIGN(KSUSY2+15,KCS)
11827 ELSEIF(ISUB.EQ.209) THEN
11828 C...f + fbar -> ~tau_1 + ~tau_2bar
11829 IF(MINT(15).LT.0) JS=2
11830 IF(MINT(2).EQ.1) THEN
11831 MINT(20+JS)=KFPR(ISUB,1)
11832 MINT(23-JS)=-KFPR(ISUB,2)
11834 MINT(20+JS)=-KFPR(ISUB,1)
11835 MINT(23-JS)=KFPR(ISUB,2)
11838 ELSEIF(ISUB.EQ.210) THEN
11839 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11840 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11841 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11842 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11843 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11845 ELSEIF(ISUB.EQ.211) THEN
11846 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11847 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11848 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11849 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11850 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11852 ELSEIF(ISUB.EQ.212) THEN
11853 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11854 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11855 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11856 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11857 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11859 ELSEIF(ISUB.EQ.213) THEN
11860 C...f + fbar -> ~nul + ~nulbar
11861 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11864 ELSEIF(ISUB.EQ.214) THEN
11865 C...f + fbar -> ~nutau + ~nutaubar
11866 MINT(21)=ISIGN(KSUSY1+16,KCS)
11870 ELSEIF(ISUB.LE.225) THEN
11871 IF(ISUB.EQ.216) THEN
11872 C...f + fbar -> ~chi01 + ~chi01
11876 ELSEIF(ISUB.EQ.217) THEN
11877 C...f + fbar -> ~chi02 + ~chi02
11881 ELSEIF(ISUB.EQ.218 ) THEN
11882 C...f + fbar -> ~chi03 + ~chi03
11886 ELSEIF(ISUB.EQ.219 ) THEN
11887 C...f + fbar -> ~chi04 + ~chi04
11891 ELSEIF(ISUB.EQ.220 ) THEN
11892 C...f + fbar -> ~chi01 + ~chi02
11893 IF(MINT(15).LT.0) JS=2
11894 C IF(PYR(0).GT.0.5D0) JS=2
11895 MINT(20+JS)=KSUSY1+22
11896 MINT(23-JS)=KSUSY1+23
11898 ELSEIF(ISUB.EQ.221 ) THEN
11899 C...f + fbar -> ~chi01 + ~chi03
11900 IF(MINT(15).LT.0) JS=2
11901 C IF(PYR(0).GT.0.5D0) JS=2
11902 MINT(20+JS)=KSUSY1+22
11903 MINT(23-JS)=KSUSY1+25
11905 ELSEIF(ISUB.EQ.222) THEN
11906 C...f + fbar -> ~chi01 + ~chi04
11907 IF(MINT(15).LT.0) JS=2
11908 C IF(PYR(0).GT.0.5D0) JS=2
11909 MINT(20+JS)=KSUSY1+22
11910 MINT(23-JS)=KSUSY1+35
11912 ELSEIF(ISUB.EQ.223) THEN
11913 C...f + fbar -> ~chi02 + ~chi03
11914 IF(MINT(15).LT.0) JS=2
11915 C IF(PYR(0).GT.0.5D0) JS=2
11916 MINT(20+JS)=KSUSY1+23
11917 MINT(23-JS)=KSUSY1+25
11919 ELSEIF(ISUB.EQ.224) THEN
11920 C...f + fbar -> ~chi02 + ~chi04
11921 IF(MINT(15).LT.0) JS=2
11922 C IF(PYR(0).GT.0.5D0) JS=2
11923 MINT(20+JS)=KSUSY1+23
11924 MINT(23-JS)=KSUSY1+35
11926 ELSEIF(ISUB.EQ.225) THEN
11927 C...f + fbar -> ~chi03 + ~chi04
11928 IF(MINT(15).LT.0) JS=2
11929 C IF(PYR(0).GT.0.5D0) JS=2
11930 MINT(20+JS)=KSUSY1+25
11931 MINT(23-JS)=KSUSY1+35
11934 ELSEIF(ISUB.LE.236) THEN
11935 IF(ISUB.EQ.226) THEN
11936 C...f + fbar -> ~chi+-1 + ~chi-+1
11937 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
11938 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11939 MINT(21)=ISIGN(KSUSY1+24,KCH1)
11942 ELSEIF(ISUB.EQ.227) THEN
11943 C...f + fbar -> ~chi+-2 + ~chi-+2
11944 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11945 MINT(21)=ISIGN(KSUSY1+37,KCH1)
11948 ELSEIF(ISUB.EQ.228) THEN
11949 C...f + fbar -> ~chi+-1 + ~chi-+2
11950 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
11951 C...js=1 if pyr<.5, js=2 if pyr>.5
11952 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
11953 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
11954 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
11955 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
11956 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11958 IF(MINT(2).EQ.1) THEN
11959 MINT(21)= ISIGN(KSUSY1+24,KCH1)
11960 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
11961 c IF(KCH2.EQ.0) JS=2
11963 MINT(21)= ISIGN(KSUSY1+37,KCH1)
11964 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
11966 c IF(KCH2.EQ.1) JS=2
11969 ELSEIF(ISUB.EQ.229) THEN
11970 C...q + qbar' -> ~chi01 + ~chi+-1
11971 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
11972 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11973 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11975 IF(MOD(MINT(15),2).EQ.0) JS=2
11976 MINT(20+JS)=KSUSY1+22
11977 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11979 ELSEIF(ISUB.EQ.230) THEN
11980 C...q + qbar' -> ~chi02 + ~chi+-1
11981 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11982 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11983 IF(MOD(MINT(15),2).EQ.0) JS=2
11984 MINT(20+JS)=KSUSY1+23
11985 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11987 ELSEIF(ISUB.EQ.231) THEN
11988 C...q + qbar' -> ~chi03 + ~chi+-1
11989 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11990 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11991 IF(MOD(MINT(15),2).EQ.0) JS=2
11992 MINT(20+JS)=KSUSY1+25
11993 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11995 ELSEIF(ISUB.EQ.232) THEN
11996 C...q + qbar' -> ~chi04 + ~chi+-1
11997 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11998 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11999 IF(MOD(MINT(15),2).EQ.0) JS=2
12000 MINT(20+JS)=KSUSY1+35
12001 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12003 ELSEIF(ISUB.EQ.233) THEN
12004 C...q + qbar' -> ~chi01 + ~chi+-2
12005 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12006 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12007 IF(MOD(MINT(15),2).EQ.0) JS=2
12008 MINT(20+JS)=KSUSY1+22
12009 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12011 ELSEIF(ISUB.EQ.234) THEN
12012 C...q + qbar' -> ~chi02 + ~chi+-2
12013 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12014 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12015 IF(MOD(MINT(15),2).EQ.0) JS=2
12016 MINT(20+JS)=KSUSY1+23
12017 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12019 ELSEIF(ISUB.EQ.235) THEN
12020 C...q + qbar' -> ~chi03 + ~chi+-2
12021 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12022 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12023 IF(MOD(MINT(15),2).EQ.0) JS=2
12024 MINT(20+JS)=KSUSY1+25
12025 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12027 ELSEIF(ISUB.EQ.236) THEN
12028 C...q + qbar' -> ~chi04 + ~chi+-2
12029 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12030 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12031 IF(MOD(MINT(15),2).EQ.0) JS=2
12032 MINT(20+JS)=KSUSY1+35
12033 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12036 ELSEIF(ISUB.LE.245) THEN
12037 IF(ISUB.EQ.237) THEN
12038 C...q + qbar -> ~chi01 + ~g
12040 IF(PYR(0).GT.0.5D0) JS=2
12041 MINT(20+JS)=KSUSY1+21
12042 MINT(23-JS)=KSUSY1+22
12045 ELSEIF(ISUB.EQ.238) THEN
12046 C...q + qbar -> ~chi02 + ~g
12048 IF(PYR(0).GT.0.5D0) JS=2
12049 MINT(20+JS)=KSUSY1+21
12050 MINT(23-JS)=KSUSY1+23
12053 ELSEIF(ISUB.EQ.239) THEN
12054 C...q + qbar -> ~chi03 + ~g
12056 IF(PYR(0).GT.0.5D0) JS=2
12057 MINT(20+JS)=KSUSY1+21
12058 MINT(23-JS)=KSUSY1+25
12061 ELSEIF(ISUB.EQ.240) THEN
12062 C...q + qbar -> ~chi04 + ~g
12064 IF(PYR(0).GT.0.5D0) JS=2
12065 MINT(20+JS)=KSUSY1+21
12066 MINT(23-JS)=KSUSY1+35
12069 ELSEIF(ISUB.EQ.241) THEN
12070 C...q + qbar' -> ~chi+-1 + ~g
12071 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12072 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12073 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12074 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12075 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12076 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12077 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12079 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12080 MINT(20+JS)=KSUSY1+21
12081 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12084 ELSEIF(ISUB.EQ.242) THEN
12085 C...q + qbar' -> ~chi+-2 + ~g
12086 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12087 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12088 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12089 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12090 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12091 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12092 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12094 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12095 MINT(20+JS)=KSUSY1+21
12096 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12099 ELSEIF(ISUB.EQ.243) THEN
12100 C...q + qbar -> ~g + ~g ; th arbitrary
12105 ELSEIF(ISUB.EQ.244) THEN
12106 C...g + g -> ~g + ~g ; th arbitrary
12108 KCS=(-1)**INT(1.5D0+PYR(0))
12113 ELSEIF(ISUB.LE.260) THEN
12114 IF(ISUB.EQ.246) THEN
12115 C...qj + g -> ~qj_L + ~chi01
12116 IF(MINT(15).EQ.21) JS=2
12119 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12120 MINT(23-JS)=KSUSY1+22
12122 KCS=ISIGN(1,MINT(14+JS))
12124 ELSEIF(ISUB.EQ.247) THEN
12125 C...qj + g -> ~qj_R + ~chi01
12126 IF(MINT(15).EQ.21) JS=2
12129 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12130 MINT(23-JS)=KSUSY1+22
12132 KCS=ISIGN(1,MINT(14+JS))
12134 ELSEIF(ISUB.EQ.248) THEN
12135 C...qj + g -> ~qj_L + ~chi02
12136 IF(MINT(15).EQ.21) JS=2
12139 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12140 MINT(23-JS)=KSUSY1+23
12142 KCS=ISIGN(1,MINT(14+JS))
12144 ELSEIF(ISUB.EQ.249) THEN
12145 C...qj + g -> ~qj_R + ~chi02
12146 IF(MINT(15).EQ.21) JS=2
12149 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12150 MINT(23-JS)=KSUSY1+23
12152 KCS=ISIGN(1,MINT(14+JS))
12154 ELSEIF(ISUB.EQ.250) THEN
12155 C...qj + g -> ~qj_L + ~chi03
12156 IF(MINT(15).EQ.21) JS=2
12159 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12160 MINT(23-JS)=KSUSY1+25
12162 KCS=ISIGN(1,MINT(14+JS))
12164 ELSEIF(ISUB.EQ.251) THEN
12165 C...qj + g -> ~qj_R + ~chi03
12166 IF(MINT(15).EQ.21) JS=2
12169 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12170 MINT(23-JS)=KSUSY1+25
12172 KCS=ISIGN(1,MINT(14+JS))
12174 ELSEIF(ISUB.EQ.252) THEN
12175 C...qj + g -> ~qj_L + ~chi04
12176 IF(MINT(15).EQ.21) JS=2
12179 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12180 MINT(23-JS)=KSUSY1+35
12182 KCS=ISIGN(1,MINT(14+JS))
12184 ELSEIF(ISUB.EQ.253) THEN
12185 C...qj + g -> ~qj_R + ~chi04
12186 IF(MINT(15).EQ.21) JS=2
12189 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12190 MINT(23-JS)=KSUSY1+35
12192 KCS=ISIGN(1,MINT(14+JS))
12194 ELSEIF(ISUB.EQ.254) THEN
12195 C...qj + g -> ~qk_L + ~chi+-1
12196 IF(MINT(15).EQ.21) JS=2
12199 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12200 IB=-IA+INT((IA+1)/2)*4-1
12201 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12203 KCS=ISIGN(1,MINT(14+JS))
12205 ELSEIF(ISUB.EQ.255) THEN
12206 C...qj + g -> ~qk_L + ~chi+-1
12207 IF(MINT(15).EQ.21) JS=2
12210 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12211 IB=-IA+INT((IA+1)/2)*4-1
12212 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12214 KCS=ISIGN(1,MINT(14+JS))
12216 ELSEIF(ISUB.EQ.256) THEN
12217 C...qj + g -> ~qk_L + ~chi+-2
12218 IF(MINT(15).EQ.21) JS=2
12221 IB=-IA+INT((IA+1)/2)*4-1
12222 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12223 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12225 KCS=ISIGN(1,MINT(14+JS))
12227 ELSEIF(ISUB.EQ.257) THEN
12228 C...qj + g -> ~qk_R + ~chi+-2
12229 IF(MINT(15).EQ.21) JS=2
12232 IB=-IA+INT((IA+1)/2)*4-1
12233 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12234 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12236 KCS=ISIGN(1,MINT(14+JS))
12238 ELSEIF(ISUB.EQ.258) THEN
12239 C...qj + g -> ~qj_L + ~g
12240 IF(MINT(15).EQ.21) JS=2
12243 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12244 MINT(23-JS)=KSUSY1+21
12246 IF(JS.EQ.2) KCC=KCC+2
12249 ELSEIF(ISUB.EQ.259) THEN
12250 C...qj + g -> ~qj_R + ~g
12251 IF(MINT(15).EQ.21) JS=2
12254 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12255 MINT(23-JS)=KSUSY1+21
12257 IF(JS.EQ.2) KCC=KCC+2
12261 ELSEIF(ISUB.LE.270) THEN
12262 IF(ISUB.EQ.261) THEN
12263 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
12265 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12266 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12268 C...Correct color combination
12269 IF(MINT(43).EQ.4) KCC=4
12271 ELSEIF(ISUB.EQ.262) THEN
12272 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
12274 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12275 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12277 C...Correct color combination
12278 IF(MINT(43).EQ.4) KCC=4
12280 ELSEIF(ISUB.EQ.263) THEN
12281 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
12282 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
12283 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
12284 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12285 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
12288 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
12289 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
12291 C...Correct color combination
12292 IF(MINT(43).EQ.4) KCC=4
12294 ELSEIF(ISUB.EQ.264) THEN
12295 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
12296 KCS=(-1)**INT(1.5D0+PYR(0))
12297 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12301 ELSEIF(ISUB.EQ.265) THEN
12302 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
12303 KCS=(-1)**INT(1.5D0+PYR(0))
12304 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12309 ELSEIF(ISUB.LE.296) THEN
12310 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
12311 C...qi + qj -> ~qi_L + ~qj_L
12313 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12314 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12315 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12317 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
12318 C...qi + qj -> ~qi_R + ~qj_R
12320 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12321 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12322 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12324 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
12325 C...qi + qj -> ~qi_L + ~qj_R
12326 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12327 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12329 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12331 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
12332 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
12333 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12334 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12336 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12338 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
12339 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12340 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12341 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12343 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12345 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
12346 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12347 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12348 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12350 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12352 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
12353 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12355 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12356 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12358 IF(MINT(43).EQ.4) KCC=4
12360 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
12361 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12363 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12364 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12366 IF(MINT(43).EQ.4) KCC=4
12368 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
12369 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12371 KCS=(-1)**INT(1.5D0+PYR(0))
12372 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12376 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
12377 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12378 KCS=(-1)**INT(1.5D0+PYR(0))
12379 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12383 ELSEIF(ISUB.EQ.294) THEN
12384 C...qj + g -> ~qj_L + ~g
12385 IF(MINT(15).EQ.21) JS=2
12388 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12389 MINT(23-JS)=KSUSY1+21
12391 IF(JS.EQ.2) KCC=KCC+2
12394 ELSEIF(ISUB.EQ.295) THEN
12395 C...qj + g -> ~qj_R + ~g
12396 IF(MINT(15).EQ.21) JS=2
12399 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12400 MINT(23-JS)=KSUSY1+21
12402 IF(JS.EQ.2) KCC=KCC+2
12406 ELSEIF(ISUB.LE.330) THEN
12407 IF(ISUB.EQ.311)THEN
12408 C...g + g -> g* + g* (UED)
12410 KCS=(-1)**INT(1.5D0+PYR(0))
12413 MINT(21)=IUEDEQ(472)
12414 MINT(22)=IUEDEQ(472)
12415 ELSEIF(ISUB.EQ.312)THEN
12416 C...q + g -> q*_D + g*, q*_S + g*
12417 C...The two channels have the same cross section
12419 IF(PYR(0).GT.0.5)KKFLMI=456
12420 IF(MINT(15).EQ.21) JS=2
12422 IF(MINT(15).EQ.21)KCC=KCC+2
12423 IF(MINT(15).NE.21)THEN
12424 KCS=ISIGN(1,MINT(15))
12426 MUED(1)=KCS*(KKFLMI+IABS(MINT(15)))
12427 MINT(22)=IUEDEQ(472)
12428 MINT(21)=KCS*IUEDEQ(KKFLMI+IABS(MINT(15)))
12430 IF(MINT(16).NE.21)THEN
12431 KCS=ISIGN(1,MINT(16))
12432 MUED(2)=KCS*(KKFLMI+IABS(MINT(16)))
12434 MINT(22)=KCS*IUEDEQ(KKFLMI+IABS(MINT(16)))
12435 MINT(21)=IUEDEQ(472)
12437 ELSEIF(ISUB.EQ.313)THEN
12438 C...q + q' -> q*_D + q*_D',q*_S+q*_S'
12439 C...The two channels have the same cross section
12441 IF(PYR(0).GT.0.5)KKFLMI=456
12443 IF(MINT(15).EQ.MINT(16))THEN
12444 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12446 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12449 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12450 MUED(2)=SIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12451 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12452 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12454 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12455 ELSEIF(ISUB.EQ.314)THEN
12456 C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar
12457 C...The two channels have the same cross section
12459 IF(PYR(0).GT.0.5)KKFLMI=456
12460 KCS=(-1)**INT(1.5D0+PYR(0))
12462 IF(XFLAOUT.LE.0.2)THEN
12463 MUED(1)=ISIGN(1,KCS)*(KKFLMI+1)
12464 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+1)
12465 ELSEIF(XFLAOUT.LE.0.4)THEN
12466 MUED(1)=ISIGN(1,KCS)*(KKFLMI+2)
12467 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+2)
12468 ELSEIF(XFLAOUT.LE.0.6)THEN
12469 MUED(1)=ISIGN(1,KCS)*(KKFLMI+3)
12470 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+3)
12471 ELSEIF(XFLAOUT.LE.0.8)THEN
12472 MUED(1)=ISIGN(1,KCS)*(KKFLMI+4)
12473 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+4)
12475 MUED(1)=ISIGN(1,KCS)*(KKFLMI+5)
12476 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+5)
12481 ELSEIF(ISUB.EQ.315)THEN
12482 C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar
12483 C...The two channels have the same cross section
12485 IF(PYR(0).GT.0.5)KKFLMI=456
12486 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12488 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12491 ELSEIF(ISUB.EQ.316)THEN
12492 C...q + qbar' -> q*_D + q*_S_bar'
12493 MUED(1)=ISIGN(1,MINT(15))*(456+IABS(MINT(15)))
12494 MUED(2)=ISIGN(1,MINT(16))*(450+IABS(MINT(16)))
12495 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12496 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12498 ELSEIF(ISUB.EQ.317)THEN
12499 C...q + qbar' -> q*_D + q*_D_bar', q*_S + q*_S_bar
12500 C...The two channels have the same cross section
12502 IF(PYR(0).GT.0.5)KKFLMI=456
12503 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12504 MUED(2)=ISIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12505 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12506 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12508 ELSEIF(ISUB.EQ.318)THEN
12509 C...q + q' -> q*_D + q*_S'
12511 MUED(1)=SIGN(1,MINT(15))*(456+IABS(MINT(15)))
12512 MUED(2)=SIGN(1,MINT(16))*(450+IABS(MINT(16)))
12513 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12514 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12515 ELSEIF(ISUB.EQ.319)THEN
12516 C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar'
12517 C...The two channels have the same cross section
12519 IF(PYR(0).GT.0.5)KKFLMI=456
12522 C...N.B. NFLAVOURS=IUED(3)
12525 IF(I.NE.IABS(MINT(15)))THEN
12530 FLASTEP=1./(IUED(3)-1)
12533 IF(XFLAOUT.LE.FLAVV)THEN
12534 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IOKFLA(I))
12535 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IOKFLA(I))
12540 IF(IABS(MUED(1)).LT.451.AND.IABS(MUED(1)).GT.462)THEN
12541 WRITE(MSTU(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!'
12542 CALL PYSTOP(5000000)
12548 ELSEIF(ISUB.LE.340) THEN
12550 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
12551 C...q + qbar' -> H+ + H0
12552 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12553 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12554 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12555 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
12556 MINT(23-JS)=KFPR(ISUB,2)
12557 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
12558 C...f + fbar -> A0 + H0; th arbitrary
12559 IF(PYR(0).GT.0.5D0) JS=2
12560 MINT(20+JS)=KFPR(ISUB,1)
12561 MINT(23-JS)=KFPR(ISUB,2)
12562 ELSEIF(ISUB.EQ.301) THEN
12563 C...f + fbar -> H+ H-
12564 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12569 ELSEIF(ISUB.LE.360) THEN
12571 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
12572 C...l + l -> H_L++/--, H_R++/--
12573 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12574 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12575 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12577 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
12578 C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12579 IF(MINT(15).EQ.22) JS=2
12580 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
12581 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
12584 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
12585 C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12586 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
12589 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
12590 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12591 C...as inner process).
12596 RVCKM=VINT(180+I)*PYR(0)
12599 IPM=(5-ISIGN(1,I))/2
12601 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
12602 MINT(20+JT)=ISIGN(IB,I)
12603 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12604 IF(RVCKM.LE.0D0) GOTO 450
12607 IB=2*((IA+1)/2)-1+MOD(IA,2)
12608 MINT(20+JT)=ISIGN(IB,I)
12612 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
12613 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
12615 ELSEIF(ISUB.EQ.353) THEN
12616 C...f + fbar -> Z_R0
12619 ELSEIF(ISUB.EQ.354) THEN
12620 C...f + fbar' -> W+/-
12621 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12622 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12623 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12627 ELSEIF(ISUB.LE.380) THEN
12629 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
12630 C...f + fbar -> charged+ charged- technicolor
12631 KSW=(-1)**INT(1.5D0+PYR(0))
12632 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
12633 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
12635 ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
12636 C...f + fbar -> neutral neutral technicolor
12637 MINT(21)=KFPR(ISUB,1)
12638 MINT(22)=KFPR(ISUB,2)
12640 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
12641 C...f + fbar' -> neutral charged technicolor
12644 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12645 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12646 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12647 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12648 MINT(20+JS)=KFPR(ISUB,IN)
12650 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
12651 C...f + fbar' -> charged neutral technicolor
12654 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12655 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12656 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12657 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12658 MINT(23-JS)=KFPR(ISUB,IN)
12661 ELSEIF(ISUB.LE.400) THEN
12662 IF(ISUB.EQ.381) THEN
12663 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12665 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12667 ELSEIF(ISUB.EQ.382) THEN
12668 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12669 MINT(21)=ISIGN(KFLF,MINT(15))
12673 ELSEIF(ISUB.EQ.383) THEN
12674 C...f + fbar -> g + g; th arbitrary, TC extensions
12679 ELSEIF(ISUB.EQ.384) THEN
12680 C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12681 IF(MINT(15).EQ.21) JS=2
12683 IF(MINT(15).EQ.21) KCC=KCC+2
12684 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12685 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12687 ELSEIF(ISUB.EQ.385) THEN
12688 C...g + g -> f + fbar; th arbitrary, TC extensions
12689 KCS=(-1)**INT(1.5D0+PYR(0))
12690 MINT(21)=ISIGN(KFLF,KCS)
12694 ELSEIF(ISUB.EQ.386) THEN
12695 C...g + g -> g + g; th arbitrary, TC extensions
12697 KCS=(-1)**INT(1.5D0+PYR(0))
12699 ELSEIF(ISUB.EQ.387) THEN
12700 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12701 MINT(21)=ISIGN(MINT(55),MINT(15))
12705 ELSEIF(ISUB.EQ.388) THEN
12706 C...g + g -> Q + Qbar; th arbitrary, TC extensions
12707 KCS=(-1)**INT(1.5D0+PYR(0))
12708 MINT(21)=ISIGN(MINT(55),KCS)
12712 ELSEIF(ISUB.EQ.391) THEN
12713 C...f + fbar -> G*.
12716 ELSEIF(ISUB.EQ.392) THEN
12721 ELSEIF(ISUB.EQ.393) THEN
12722 C...q + qbar -> g + G*; th arbitrary.
12723 IF(PYR(0).GT.0.5D0) JS=2
12724 MINT(20+JS)=KFPR(ISUB,1)
12725 MINT(23-JS)=KFPR(ISUB,2)
12728 ELSEIF(ISUB.EQ.394) THEN
12729 C...q + g -> q + G*; th = (p(f) - p(f))**2
12730 IF(MINT(15).EQ.21) JS=2
12731 MINT(23-JS)=KFPR(ISUB,2)
12733 KCS=ISIGN(1,MINT(14+JS))
12735 ELSEIF(ISUB.EQ.395) THEN
12736 C...g + g -> G* + g; th arbitrary.
12737 IF(PYR(0).GT.0.5D0) JS=2
12738 MINT(23-JS)=KFPR(ISUB,2)
12742 ELSEIF(ISUB.LE.420) THEN
12743 IF(ISUB.EQ.401) THEN
12744 C...g + g -> t + b + H+/-
12745 KCS=(-1)**INT(1.5D0+PYR(0))
12746 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
12747 MINT(22)=ISIGN(5,-KCS)
12748 KCC=11+INT(0.5D0+PYR(0))
12749 KFRES=ISIGN(KFHIGG,-KCS)
12751 ELSEIF(ISUB.EQ.402) THEN
12752 C...q + qbar -> t + b + H+/-
12753 KFL=(-1)**INT(1.5D0+PYR(0))
12754 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
12755 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
12757 KFRES=ISIGN(KFHIGG,-KFL*KCS)
12761 C...Additional code by Stefan Wolf
12762 ELSEIF(ISUB.LE.430) THEN
12763 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
12764 C...g + g -> QQ~[n] + g
12765 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12766 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12767 C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12768 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12769 C...or from ISUB.EQ.68 (for ISUB.NE.421)
12770 C...[g + g -> g + g; th arbitrary]
12771 MINT(21)=KFPR(ISUBSV,1)
12772 MINT(22)=KFPR(ISUBSV,2)
12773 IF(ISUB.EQ.421) THEN
12775 KCS=(-1)**INT(1.5D0+PYR(0))
12778 KCS=(-1)**INT(1.5D0+PYR(0))
12781 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
12782 C...q + g -> q + QQ~[n]
12783 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12784 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12785 C...KCC copied from ISUB.EQ.28
12786 C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12787 IF(MINT(15).EQ.21) JS=2
12788 MINT(23-JS)=KFPR(ISUBSV,2)
12790 IF(MINT(15).EQ.21) KCC=KCC+2
12791 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12792 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12794 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
12795 C...q + q~ -> g + QQ~[n]
12796 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12797 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12798 C...KCC copied from ISUB.EQ.13
12799 C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12800 IF(PYR(0).GT.0.5) JS=2
12802 MINT(23-JS)=KFPR(ISUBSV,2)
12806 ELSEIF(ISUB.LE.440) THEN
12807 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
12808 C...g + g -> QQ~[n] + g
12809 C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12810 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12811 C...KCC and KCS copied from ISUB.EQ.86-89
12812 C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12813 MINT(21)=KFPR(ISUBSV,1)
12814 MINT(22)=KFPR(ISUBSV,2)
12816 KCS=(-1)**INT(1.5D0+PYR(0))
12818 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
12819 C...q + g -> q + QQ~[n]
12820 C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12821 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12822 C...KCC and KCS copied from ISUB.EQ.112
12823 C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12824 IF(MINT(15).EQ.21) JS=2
12825 MINT(23-JS)=KFPR(ISUBSV,2)
12827 KCS=ISIGN(1,MINT(14+JS))
12829 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
12830 C...q + q~ -> g + QQ~[n]
12831 C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12832 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12833 C...KCC copied from ISUB.EQ.111
12834 C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12835 IF(PYR(0).GT.0.5) JS=2
12837 MINT(23-JS)=KFPR(ISUBSV,2)
12844 IF(ISET(ISUB).EQ.11) THEN
12845 C...Store documentation for user-defined processes
12846 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
12847 KUPPO(1)=MINT(83)+5
12848 KUPPO(2)=MINT(83)+6
12852 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
12861 IF(IDUP(IUP).EQ.0) K(I,2)=90
12863 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
12871 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
12874 C...Store final state partons for user-defined processes
12879 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
12881 IF(IDUP(IUP).EQ.0) K(N,2)=90
12882 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
12885 K(N,3)=MINT(84)+MOTHUP(1,IUP)
12889 C...Search for daughters of intermediate colourless particles.
12890 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
12891 DO 475 IUPDAU=IUP+1,NUP
12892 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
12894 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
12902 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
12904 C...Arrange colour flow for user-defined processes
12908 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
12909 IF(K(I1,1).EQ.1) K(I1,1)=3
12910 IF(K(I1,1).EQ.11) K(I1,1)=14
12911 C...Find a not yet considered colour/anticolour line.
12913 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
12916 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
12920 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
12921 C...Find all others belonging to same line.
12924 DO 520 IUP2=IUP1+1,NUP
12927 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
12928 IF(ISDE2.EQ.ISDE1) THEN
12929 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
12930 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
12932 ELSEIF(I4.NE.0) THEN
12933 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
12934 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
12936 ELSEIF(IUP2.LE.2) THEN
12937 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
12938 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
12941 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
12942 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
12952 ELSEIF(IDOC.EQ.7) THEN
12953 C...Resonance not decaying; store kinematics
12968 C...Special cases: colour flow in coloured resonances
12969 KCRES=PYCOMP(KFRES)
12970 IF(KCHG(KCRES,2).NE.0) THEN
12974 IF(KCS.EQ.-1) JC=3-J
12975 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12976 & MINT(84)+ICOL(KCC,1,JC)
12977 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12978 & MINT(84)+ICOL(KCC,2,JC)
12979 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12980 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12989 ELSEIF(IDOC.EQ.8) THEN
12990 C...2 -> 2 processes: store outgoing partons in their CM-frame
12993 KCA=PYCOMP(MINT(20+JT))
12995 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12997 K(I,3)=MINT(83)+IDOC+JT-2
12999 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
13000 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13002 P(I,5)=PYMASS(K(I,2))
13004 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
13005 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
13007 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
13008 KFA1=IABS(MINT(21))
13009 KFA2=IABS(MINT(22))
13010 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
13018 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
13019 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
13020 P(IPU4,4)=SHR-P(IPU3,4)
13021 P(IPU4,3)=-P(IPU3,3)
13026 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
13027 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
13029 ELSEIF(IDOC.EQ.9) THEN
13030 C...2 -> 3 processes: store outgoing partons in their CM frame
13033 KCA=PYCOMP(MINT(20+JT))
13035 IF(KCHG(KCA,2).NE.0) K(I,1)=3
13037 K(I,3)=MINT(83)+IDOC+JT-3
13039 C...t and b in opposide order in event list as compared to
13040 C...matrix element?
13041 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
13042 IF(IABS(K(I,2)).LE.22) THEN
13043 P(I,5)=PYMASS(K(I,2))
13045 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
13047 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
13048 P(I,1)=PT*COS(VINT(198+5*JTA))
13049 P(I,2)=PT*SIN(VINT(198+5*JTA))
13053 K(IPU5,3)=MINT(83)+IDOC
13055 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13056 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13057 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
13058 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
13059 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
13061 P(IPU5,3)=PMT3*SINH(VINT(211))
13062 P(IPU5,4)=PMT3*COSH(VINT(211))
13063 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
13064 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
13065 IF(SQL12.LE.0D0) THEN
13069 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
13070 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13071 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
13072 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
13073 C...t and b in opposide order in event list as compared to
13075 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
13076 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13077 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
13079 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
13080 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
13086 ELSEIF(IDOC.EQ.11) THEN
13087 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
13088 PHI(1)=PARU(2)*PYR(0)
13093 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13095 K(I,3)=MINT(83)+IDOC+JT-2
13096 P(I,5)=PYMASS(K(I,2))
13097 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
13101 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13102 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13103 P(I,1)=PTABS*COS(PHI(JT))
13104 P(I,2)=PTABS*SIN(PHI(JT))
13105 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13106 P(I,4)=0.5D0*SHPR*Z(JT)
13110 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
13114 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13115 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13116 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13123 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13124 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13125 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
13126 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
13135 ELSEIF(IDOC.EQ.12) THEN
13136 C...Z0 and W+/- scattering: store bosons and outgoing partons
13137 PHI(1)=PARU(2)*PYR(0)
13139 JTRAN=INT(1.5D0+PYR(0))
13143 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13145 K(I,3)=MINT(83)+IDOC+JT-2
13146 P(I,5)=PYMASS(K(I,2))
13147 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
13148 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13149 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13150 P(I,1)=PTABS*COS(PHI(JT))
13151 P(I,2)=PTABS*SIN(PHI(JT))
13152 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13153 P(I,4)=0.5D0*SHPR*Z(JT)
13156 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
13159 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
13164 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13165 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13166 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13169 K(IPU,2)=KFPR(ISUB,JT)
13170 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
13171 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
13172 K(IPU,3)=MINT(83)+8+JT
13173 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
13174 P(IPU,5)=PYMASS(K(IPU,2))
13176 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13178 MINT(22+JT)=K(IPU,2)
13180 C...Find rotation and boost for hard scattering subsystem
13183 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
13184 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
13185 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
13186 GAMCM=(P(I1,4)+P(I2,4))/SHR
13187 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
13188 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
13189 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
13190 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
13191 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
13192 PHICM=PYANGL(PX,PY)
13193 C...Store hard scattering subsystem. Rotate and boost it
13194 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
13196 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
13198 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
13199 PHIWZ=VINT(24)-PHICM
13200 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
13201 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
13202 P(IPU5,3)=PABS*CTHWZ
13203 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
13204 P(IPU6,1)=-P(IPU5,1)
13205 P(IPU6,2)=-P(IPU5,2)
13206 P(IPU6,3)=-P(IPU5,3)
13207 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
13208 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
13220 MINT(8)=MINT(83)+10
13223 IF(ISET(ISUB).EQ.11) THEN
13224 ELSEIF(IDOC.GE.8) THEN
13225 C...Store colour connection indices
13228 IF(KCS.EQ.-1) JC=3-J
13229 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13230 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
13231 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13232 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
13233 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
13234 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13235 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13236 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13239 C...Copy outgoing partons to documentation lines
13241 IF(IDOC.EQ.9) IMAX=3
13243 I1=MINT(83)+IDOC-IMAX+I
13247 IF(IDOC.LE.9) K(I1,3)=0
13248 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
13254 ELSEIF(IDOC.EQ.9) THEN
13255 C...Store colour connection indices
13258 IF(KCS.EQ.-1) JC=3-J
13259 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13260 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
13261 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
13262 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13263 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
13264 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
13265 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13266 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13267 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
13268 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13271 C...Copy outgoing partons to documentation lines
13273 I1=MINT(83)+IDOC-3+I
13284 C...Copy outgoing partons to list of allowed radiators.
13286 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
13287 DO 690 I=MINT(84)+3,N
13290 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
13294 C...Low-pT events: remove gluons used for string drawing purposes
13295 IF(ISUB.EQ.95) THEN
13296 IF(MINT(35).LE.1) THEN
13297 K(IPU3,1)=K(IPU3,1)+10
13298 K(IPU4,1)=K(IPU4,1)+10
13304 DO 720 I=MINT(83)+5,MINT(83)+8
13314 C***********************************************************************
13317 C...Handles intertwined pT-ordered spacelike initial-state parton
13318 C...and multiple interactions.
13320 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
13321 C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
13322 C...MODE = 0 : (Re-)initialize ISR/MI evolution.
13323 C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
13325 C...Double precision and integer declarations.
13326 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13327 IMPLICIT INTEGER(I-N)
13328 INTEGER PYK,PYCHGE,PYCOMP
13331 DOUBLE PRECISION PYALPS
13332 C...Parameter statement for maximum size of showers.
13333 PARAMETER (MAXNUR=1000)
13335 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13336 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13337 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13338 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13339 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13340 COMMON/PYINT1/MINT(400),VINT(400)
13341 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13342 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13343 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
13344 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
13345 & XMI(2,240),PT2MI(240),IMISEP(0:240)
13346 COMMON/PYCTAG/NCT,MCT(4000,2)
13347 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
13348 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
13349 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
13350 C...Local arrays and saved variables.
13351 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
13352 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
13355 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
13356 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
13358 C----------------------------------------------------------------------
13359 C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
13360 C...done only once per event, while MODE=0 is repeated each time the
13361 C...evolution needs to be restarted.
13362 IF (MODE.EQ.-1) THEN
13366 C...Store hard scattering variables
13383 C...Set shat for hardest scattering
13385 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
13388 C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
13392 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
13393 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
13394 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
13396 C----------------------------------------------------------------------
13397 C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
13398 C...interaction initiators, with no previous evolution. Check the input
13399 C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
13400 C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
13401 C...smaller than the CM energy / 2.)
13402 ELSEIF (MODE.EQ.0) THEN
13403 C...Reset counters and switches
13409 C...Reset hard scattering variables
13420 P(MINT(83)+4+IS,J)=PSAV(IS,J)
13421 V(MINT(83)+4+IS,J)=VSAV(IS,J)
13424 C...Reset statistics on activity in event.
13429 C...Reset extra companion reweighting factor
13432 C...We do not generate MI for soft process (ISUB=95), but the
13433 C...initialization must be done regardless, for later purposes.
13436 C...Initialize multiple interactions.
13437 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
13438 IF(MINT(51).NE.0) RETURN
13440 C...Decide whether quarks in hard scattering were valence or sea
13444 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
13445 IF(MINT(51).NE.0) RETURN
13448 C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
13450 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
13451 IF (MSTP(70).EQ.2) THEN
13452 C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
13453 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
13454 ELSEIF (MSTP(70).EQ.3) THEN
13455 C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73)
13456 ALPHA0 = MAX(1D-6,PARP(73))
13457 Q20 = ALAM3**2/PARP(64)
13458 IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2
13459 VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0)
13461 C...Also store PT2MIN in VINT(17).
13462 180 VINT(17)=PT2MIN
13464 C...Set FS masses zero now.
13468 C...Initialize IS showers with VINT(56) as max scale.
13471 IF (MSTP(70).EQ.0) THEN
13472 PT20=MAX(PT2MIN,PARP(62)**2)
13473 ELSEIF (MSTP(70).EQ.1) THEN
13474 PT20=MAX(PT2MIN,(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13476 CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL)
13477 IF(MINT(51).NE.0) RETURN
13481 C----------------------------------------------------------------------
13482 C...MODE= 1: Evolve event from PTMAX to PTMIN.
13483 ELSEIF (MODE.EQ.1) THEN
13485 C...Skip if no phase space.
13486 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
13488 C...Starting pT2 max scale (to be udpated successively).
13491 C...Evolve two sides of the event to find which branches at highest pT.
13496 C...Loop over current shower initiators.
13497 IF (MSTP(61).GE.1) THEN
13498 DO 230 MI=1,MINT(31)
13499 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
13501 IF (MI.EQ.1) ISUB=ISUBHD
13504 C...Set up shat, initiator x values, and x remaining in BR.
13506 VINT(141)=XMI(1,MI)
13507 VINT(142)=XMI(2,MI)
13510 DO 210 JI=1,MINT(31)
13511 IF (JI.EQ.MINT(36)) GOTO 210
13512 VINT(143)=VINT(143)-XMI(1,JI)
13513 VINT(144)=VINT(144)-XMI(2,JI)
13515 C...Loop over sides.
13516 C...Generate trial branchings for this interaction. The hardest
13517 C...branching so far is automatically updated if necessary in /PYISMX/.
13521 IF (MSTP(70).EQ.0) THEN
13522 PT20=MAX(PT2MIN,PARP(62)**2)
13523 ELSEIF (MSTP(70).EQ.1) THEN
13525 & (PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13527 CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL)
13528 IF (MINT(51).NE.0) RETURN
13533 C...Generate trial additional interaction.
13534 MINT(36)=MINT(31)+1
13535 240 IF (MOD(MSTP(81),10).GE.1) THEN
13537 C...Set up X remaining in BR.
13540 DO 250 JI=1,MINT(31)
13541 VINT(143)=VINT(143)-XMI(1,JI)
13542 VINT(144)=VINT(144)-XMI(2,JI)
13544 C...Generate trial interaction
13545 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13546 IF (MINT(51).EQ.1) RETURN
13549 C...And the winner is:
13550 IF (PT2MX.LT.PT2MIN) THEN
13552 ELSEIF (JSMX.EQ.0) THEN
13553 C...Accept additional interaction (may still fail).
13554 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13555 IF(MINT(51).NE.0) RETURN
13556 IF (IFAIL.EQ.0) THEN
13557 SHAT(MINT(36))=VINT(44)
13558 C...Decide on flavours (valence/sea/companion).
13561 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13562 IF(MINT(51).NE.0) RETURN
13565 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
13566 C...Reconstruct kinematics of acceptable ISR branching.
13567 C...Set up shat, initiator x values, and x remaining in BR.
13570 VINT(44)=SHAT(MINT(36))
13571 VINT(141)=XMI(1,MINT(36))
13572 VINT(142)=XMI(2,MINT(36))
13575 DO 280 JI=1,MINT(31)
13576 IF (JI.EQ.MINT(36)) GOTO 280
13577 VINT(143)=VINT(143)-XMI(1,JI)
13578 VINT(144)=VINT(144)-XMI(2,JI)
13581 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
13582 IF (MINT(51).EQ.1) RETURN
13583 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
13584 C...Bookeep joining. Cannot (yet) be constructed kinematically.
13585 MINT(354)=MINT(354)+1
13586 VINT(354)=VINT(354)+SQRT(PT2MX)
13587 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
13588 MJOIND(JSMX-2,MJN1MX)=MJN2MX
13589 MJOIND(JSMX-2,MJN2MX)=MJN1MX
13592 C...Update PT2 iteration scale.
13595 C...Loop back to continue evolution.
13596 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13597 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
13599 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
13602 C----------------------------------------------------------------------
13603 C...MODE= 2: (Re-)store user information on hardest interaction etc.
13604 ELSEIF (MODE.EQ.2) THEN
13606 C...Revert to "ordinary" meanings of some parameters.
13608 MINT(12+JS)=K(IMI(JS,1,1),2)
13609 VINT(140+JS)=XMI(JS,1)
13610 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
13612 DO 300 MI=1,MINT(31)
13613 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
13617 C...Restore saved quantities for hardest interaction.
13632 C*********************************************************************
13635 C...Generates spacelike parton showers.
13637 SUBROUTINE PYSSPA(IPU1,IPU2)
13639 C...Double precision and integer declarations.
13640 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13641 IMPLICIT INTEGER(I-N)
13642 INTEGER PYK,PYCHGE,PYCOMP
13643 PARAMETER (MAXNUR=1000)
13645 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13646 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13647 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13648 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13649 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13650 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13651 COMMON/PYINT1/MINT(400),VINT(400)
13652 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13653 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13654 COMMON/PYCTAG/NCT,MCT(4000,2)
13655 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,
13656 &/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/
13657 C...Local arrays and data.
13658 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
13659 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
13660 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
13661 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
13662 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
13665 C...Read out basic information; set global Q^2 scale.
13670 VINT2R=VINT(2)*VINT(143)*VINT(144)
13671 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
13672 &MIN(VINT2R,PARP(67)*VINT(56))
13675 C...Define which processes ME corrections have been implemented for.
13677 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13678 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
13679 & ISUB.EQ.144) MECOR=1
13680 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13681 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
13684 C...Initialize QCD evolution and check phase space.
13688 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
13691 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13692 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13693 Q2INT=SQRT(Q0S*Q2EFF)
13694 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
13695 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
13696 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
13698 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
13701 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13702 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13703 Q2INT=SQRT(Q0S*Q2EFF)
13704 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
13705 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
13706 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
13713 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
13715 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
13716 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
13717 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
13718 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
13722 C...Initialize QED evolution and check phase space.
13726 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
13727 &SPME=PMAS(13,1)**2
13728 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
13729 &SPME=PMAS(15,1)**2
13730 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
13733 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
13735 TEMX=LOG(Q2MX/SPME)
13736 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
13738 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13743 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
13745 C...Loopback point in case of failure to reconstruct kinematics.
13754 IF(LOOP.GT.100) THEN
13765 C...Initial values: flavours, momenta, virtualities.
13768 KFBEAM(JT)=MINT(10+JT)
13769 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
13770 KFLS(JT)=MINT(14+JT)
13771 KFLS(JT+2)=KFLS(JT)
13773 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
13774 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
13776 Q2S(JT)=FCQ2MX*Q2MX
13783 C...Calculate initial parton distribution weights.
13784 MINT(105)=MINT(102+JT)
13785 MINT(109)=MINT(106+JT)
13786 VINT(120)=VINT(2+JT)
13788 C.... Store side in MINT(124)
13791 IF(XS(JT).LT.1D0-XEE) THEN
13792 IF(MINT(31).GE.2) MINT(30)=JT
13793 IF(MSTP(57).LE.1) THEN
13794 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13796 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13800 XFS(JT,KFL)=XFB(KFL)
13802 C...Special kinematics check for c/b quarks (that g -> c cbar or
13803 C...b bbar kinematically possible).
13804 KFLCB=IABS(KFLS(JT))
13805 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
13806 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
13813 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
13815 C...Find if interference with final state partons.
13817 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
13821 KCA=PYCOMP(IABS(KFLS(I)))
13822 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
13824 IF(KCFI(I).NE.0) THEN
13825 IF(I.EQ.1) IPFS=IPUS1
13826 IF(I.EQ.2) IPFS=IPUS2
13828 ICSI=MOD(K(IPFS,3+J),MSTU(5))
13829 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
13830 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
13832 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
13834 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
13839 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
13842 C...Pick up leg with highest virtuality.
13846 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
13847 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
13848 IF(MORE(JT).EQ.0) JT=3-JT
13853 XFB(KFL)=XFS(JT,KFL)
13858 C...Check if allowed to branch.
13860 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
13862 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
13863 IF(XB.GE.1D0-2D0*XEC) MCEV=0
13866 IF(MINT(44+JT).EQ.3) THEN
13868 IF(XB.GE.1D0-2D0*XEE) MEEV=0
13869 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
13871 C***Currently kill QED shower for resolved photoproduction.
13872 IF(MINT(18+JT).EQ.1) MEEV=0
13873 C***Currently kill shower for W inside electron.
13874 IF(IABS(KFLB).EQ.24) THEN
13879 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
13881 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13886 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
13890 IF(MSTP(62).LE.1) THEN
13891 IF(ZS(JT).GT.0.99999D0) THEN
13894 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
13895 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
13896 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
13898 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13899 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13902 ALSDUM=PYALPS(FQ2C*Q2B)
13903 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
13905 B0=(33D0-2D0*MSTU(118))/6D0
13907 IF(MEEV.EQ.2) TEVEB=TEVCB
13911 C...Select side for interference with final state partons.
13912 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
13915 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
13917 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
13918 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
13919 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
13921 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
13925 C...Calculate preweighting factor for ME-corrected processes.
13926 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
13928 C...Calculate Altarelli-Parisi weights.
13934 C...q -> q (g or gamma emission), g -> q.
13935 IF(IABS(KFLB).LE.10) THEN
13936 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
13937 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
13939 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
13940 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
13942 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13943 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
13944 WTAPC(21)=WTGF*WTAPC(21)
13945 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13947 C...f -> f, gamma -> f.
13948 ELSEIF(IABS(KFLB).LE.20) THEN
13949 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
13950 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
13951 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
13952 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
13953 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13954 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13955 WTAPE(22)=WTGF*WTAPE(22)
13957 C...f -> g, g -> g.
13958 ELSEIF(KFLB.EQ.21) THEN
13959 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
13960 DO 180 KFL=1,MSTP(58)
13964 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
13965 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13966 DO 190 KFL=1,MSTP(58)
13967 WTAPC(KFL)=WTFG*WTAPC(KFL)
13968 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
13970 WTAPC(21)=WTGG*WTAPC(21)
13972 C...f -> gamma, W+, W-.
13973 ELSEIF(KFLB.EQ.22) THEN
13974 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
13977 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13978 WTAPE(11)=WTFG*WTAPE(11)
13979 WTAPE(-11)=WTFG*WTAPE(-11)
13981 ELSEIF(KFLB.EQ.24) THEN
13982 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13983 & (XEE*(XB+XEE)))/XB
13984 ELSEIF(KFLB.EQ.-24) THEN
13985 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13986 & (XEE*(XB+XEE)))/XB
13989 C...Calculate parton distribution weights and sum.
13992 IF(NTRY.GT.500) THEN
13998 XFBO=MAX(1D-10,XFB(KFLB))
14000 WTSF(KFL)=XFB(KFL)/XFBO
14001 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
14002 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
14004 WTSUMC=MAX(0.0001D0,WTSUMC)
14005 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
14007 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
14010 IF(NTRY2.GT.500) THEN
14015 IF(MSTP(64).LE.0) THEN
14016 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
14017 ELSEIF(MSTP(64).EQ.1) THEN
14018 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
14020 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
14024 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
14025 & (PARU(101)*FWTE*WTSUME*TEMX)))
14026 ELSEIF(MEEV.EQ.2) THEN
14027 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
14030 C...Translate t into Q2 scale; choose between QCD and QED evolution.
14031 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
14032 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
14033 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
14034 C...Ensure that Q2 is above threshold for charm/bottom.
14036 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14038 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
14039 Q2CB=1.1D0*PMAS(KFLCB,1)**2
14040 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14041 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
14044 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14046 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
14049 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
14050 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
14051 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
14052 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
14053 IF(Q2EB.GT.Q2MNE) MCE=2
14054 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
14055 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
14056 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
14057 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
14058 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
14059 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
14061 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
14062 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
14065 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
14066 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
14069 C...Evolution possibly ended. Update t values.
14073 ELSEIF(MCE.EQ.1) THEN
14076 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
14077 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14081 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14084 C...Select flavour for branching parton.
14085 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
14086 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
14089 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
14090 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
14091 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
14092 IF(KFLA.EQ.25) THEN
14097 C...Choose z value and corrective weight.
14099 C...q -> q + g or q -> q + gamma.
14100 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
14101 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
14102 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
14103 WTZ=0.5D0*(1D0+Z**2)
14105 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
14106 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
14107 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14108 C...f -> f + gamma.
14109 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14110 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
14111 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
14112 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
14114 Z=XB+XB*(XEE/(1D0-XEE))*
14115 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14117 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
14118 C...f -> gamma + f.
14119 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
14120 Z=XB+XB*(XEE/(1D0-XEE))*
14121 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14122 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
14124 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
14125 Z=XB+XB*(XEE/(1D0-XEE))*
14126 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14127 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
14128 & (Q2B/(Q2B+PMAS(24,1)**2))
14130 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
14131 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
14132 WTZ=1D0-2D0*Z*(1D0-Z)
14134 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14135 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
14136 WTZ=(1D0-Z*(1D0-Z))**2
14137 C...gamma -> f + fbar.
14138 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
14139 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
14140 WTZ=1D0-2D0*Z*(1D0-Z)
14142 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
14144 C...Option with resummation of soft gluon emission as effective z shift.
14146 IF(MSTP(65).GE.1) THEN
14148 IF(KFLB.NE.21) RSOFT=8D0/3D0
14149 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
14150 IF(Z.LE.XB) GOTO 220
14153 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
14154 IF(MSTP(64).GE.2) THEN
14155 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
14156 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
14157 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
14158 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
14162 C...Remove kinematically impossible branchings.
14163 UHAT=Q2B-DSH*(1D0-Z)/Z
14164 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
14166 C...Select phi angle of branching at random.
14167 PHIBR=PARU(2)*PYR(0)
14169 C...Matrix-element corrections for some processes.
14170 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14171 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14172 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
14174 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
14175 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
14177 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14178 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
14180 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14181 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
14186 C...Impose angular constraint in first branching from interference
14187 C...with final state partons.
14189 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
14190 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
14191 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
14192 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
14193 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
14194 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
14198 C...Option with angular ordering requirement.
14199 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
14200 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
14201 IF(THE2T.GT.THE2(JT)) GOTO 220
14205 C...Weighting with new parton distributions.
14206 MINT(105)=MINT(102+JT)
14207 MINT(109)=MINT(106+JT)
14208 VINT(120)=VINT(2+JT)
14209 IF(MINT(31).GE.2) MINT(30)=JT
14211 C.... Store side in MINT(124)
14214 IF(MSTP(57).LE.1) THEN
14215 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
14217 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
14220 IF(XFBN.LT.1D-20) THEN
14221 IF(KFLA.EQ.KFLB) THEN
14227 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
14228 TEVCB=0.5D0*(TEVCBS+TEVCB)
14230 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
14231 TEVEB=0.5D0*(TEVEBS+TEVEB)
14243 C.... Store side in MINT(124)
14246 IF(MINT(31).GE.2) MINT(30)=JT
14247 IF(MSTP(57).LE.1) THEN
14248 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
14250 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
14253 IF(XFAN.LT.1D-20) GOTO 200
14255 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
14257 C...Define two hard scatterers in their CM-frame.
14258 260 IF(N.EQ.NS+2) THEN
14260 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
14263 IF(JR.EQ.1) IPO=IPUS1
14264 IF(JR.EQ.2) IPO=IPUS2
14274 P(I,3)=DPLCM*(-1)**(JR+1)
14275 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
14276 P(I,5)=-SQRT(DQ2(JR))
14279 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
14280 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
14281 MCT(I,1)=MCT(IPO,1)
14282 MCT(I,2)=MCT(IPO,2)
14285 C...Find maximum allowed mass of timelike parton.
14286 ELSEIF(N.GT.NS+2) THEN
14291 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
14292 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
14293 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
14294 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
14295 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
14297 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
14298 & 1D-10*DPD(1)) IKIN=1
14299 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
14300 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
14301 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
14302 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
14304 C...Generate timelike parton shower (if required).
14311 C...f -> f + g (gamma).
14312 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
14314 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
14315 C...f -> g (gamma, W+-) + f.
14316 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
14318 IF(KFLS(JT+2).EQ.24) THEN
14320 ELSEIF(KFLS(JT+2).EQ.-24) THEN
14323 C...g (gamma) -> f + fbar, g + g.
14325 K(IT,2)=-KFLS(JT+2)
14326 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
14329 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
14330 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
14331 P(IT,5)=PYMASS(K(IT,2))
14332 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
14333 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
14336 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
14337 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
14338 IF(MSTP(63).EQ.1) THEN
14340 ELSEIF(MSTP(63).EQ.2) THEN
14341 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
14345 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14346 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
14347 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
14348 PARJ(85)=SQRT(MAX(0D0,DPT2))*
14349 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
14351 C...Only do timelike shower here if using PYSHOW
14352 IF (MSTJ(41).NE.11.AND.MSTJ(41).NE.12) THEN
14353 CALL PYSHOW(IT,0,SQRT(Q2TIM))
14357 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
14360 C...Reconstruct kinematics of branching: timelike parton shower.
14362 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14363 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
14364 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
14365 & (4D0*DSH*DPC(3)**2)
14366 IF(DPT2.LT.0D0) GOTO 100
14367 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
14368 & DSHR)/DPC(3)-DPC(3)
14370 P(IT,3)=DPB(1)*(-1)**(JT+1)
14371 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
14373 DPB(1)=SQRT(DPB(1)**2+DPT2)
14374 DPB(2)=SQRT(DPB(1)**2+DMS)
14376 DPB(4)=SQRT(DPB(3)**2+DMS)
14377 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
14379 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
14380 THE=PYANGL(P(IT,3),P(IT,1))
14381 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
14384 C...Reconstruct kinematics of branching: spacelike parton.
14393 P(N+1,3)=P(IT,3)+P(IS(JT),3)
14394 P(N+1,4)=P(IT,4)+P(IS(JT),4)
14395 P(N+1,5)=-SQRT(DQ2(3))
14399 C...Define colour flow of branching.
14404 C...f -> f + gamma (Z, W).
14405 IF(IABS(K(IT,2)).GE.22) THEN
14409 C...f -> gamma (Z, W) + f.
14410 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
14413 C...gamma -> q + qbar, g + g.
14414 ELSEIF(K(N+1,2).EQ.22) THEN
14420 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
14424 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
14427 C...qbar -> qbar + g.
14428 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
14431 C...qbar -> g + qbar.
14432 ELSEIF(K(N+1,2).LT.0) THEN
14435 C...g -> g + g; g -> q + qbar.
14436 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14443 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
14444 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
14445 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14446 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14447 IF(ID1.NE.ID2) THEN
14448 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14449 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14452 IF(K(IT,1).EQ.1) THEN
14457 C...Boost to new CM-frame.
14458 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
14459 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
14460 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
14461 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
14462 IR=N+(JT-1)*(IS(1)-N)
14463 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
14466 C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
14467 IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN
14470 PTPART(NPART)=SQRT(PARP(71)*DPT2)
14473 C...Global statistics.
14474 MINT(352)=MINT(352)+1
14475 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14476 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14480 C...Update kinematics variables.
14483 IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
14486 C...Save quantities; loop back.
14490 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
14491 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
14492 KFLS(JT+2)=KFLS(JT)
14497 XFS(JT,KFL)=XFA(KFL)
14506 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14507 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
14508 IF(MSTU(21).GE.1) N=NS
14509 IF(MSTU(21).GE.1) RETURN
14511 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
14513 C...Boost hard scattering partons to frame of shower initiators.
14515 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
14521 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
14522 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
14523 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
14525 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
14526 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
14527 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
14529 C...Store user information. Reset Lambda value.
14530 IF(MINT(31).LE.1) THEN
14531 K(IPU1,3)=MINT(83)+3
14532 K(IPU2,3)=MINT(83)+4
14534 K(IPU1,3)=MINT(83)+1
14535 K(IPU2,3)=MINT(83)+2
14538 MINT(12+JT)=KFLS(JT)
14539 VINT(140+JT)=XS(JT)
14540 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
14541 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
14548 C*********************************************************************
14551 C...Generates pT-ordered spacelike initial-state parton showers and
14552 C...trial joinings.
14553 C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14554 C... interaction initiators at PT2NOW.
14555 C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14556 C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14557 C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14558 C... is below PT2CUT.
14559 C... (Also generate test joinings if MSTP(96)=1.)
14560 C...MODE= 1: Accept stored shower branching. Update event record etc.
14561 C...PT2NOW : Starting (max) PT2 scale for evolution.
14562 C...PT2CUT : Lower limit for evolution.
14563 C...PT2 : Result of evolution. Generated PT2 for trial emission.
14564 C...IFAIL : Status return code. IFAIL=0 when all is well.
14566 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14568 C...Double precision and integer declarations.
14569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14570 IMPLICIT INTEGER(I-N)
14571 INTEGER PYK,PYCHGE,PYCOMP
14572 C...Parameter statement for maximum size of showers.
14573 PARAMETER (MAXNUR=1000)
14575 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14576 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14577 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14578 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14579 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14580 COMMON/PYINT1/MINT(400),VINT(400)
14581 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14582 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14583 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14584 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14585 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14586 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14587 COMMON/PYCTAG/NCT,MCT(4000,2)
14588 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
14589 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
14590 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
14591 C...Local variables
14592 DIMENSION ZSAV(2,240),PT2SAV(2,240),
14593 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
14594 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
14595 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
14596 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
14597 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
14598 C...For check on excessive weights.
14601 C...Only give errors for very large weights, otherwise just warnings
14602 DATA WTEMAX /1.5D0/
14603 C...Only give errors for large pT, otherwise just warnings
14608 C----------------------------------------------------------------------
14609 C...MODE=-1: Initialize initial state showers from scratch, i.e.
14610 C...starting from the hardest interaction initiators.
14611 IF (MODE.EQ.-1) THEN
14612 C...Set hard scattering SHAT.
14614 C...Mass thresholds and Lambda for QCD evolution.
14615 AEM2PI=PARU(101)/PARU(2)
14619 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
14620 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
14621 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
14622 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
14623 C...Optionally use Lambda_MC = Lambda_CMW
14624 IF (MSTP(64).EQ.3) THEN
14625 ALAM5 = ALAM5 * 1.569
14626 ALAM4 = ALAM4 * 1.618
14627 ALAM3 = ALAM3 * 1.661
14631 C...Massive quark forced creation threshold (in M**2).
14633 C...Set upper limit for X (ensures some X left for beam remnant).
14634 XMXC=1D0-2D0*PARP(111)/VINT(1)
14636 IF (MSTP(61).GE.1) THEN
14637 C...Initial values: flavours, momenta, virtualities.
14641 C...Special kinematics check for c/b quarks (that g -> c cbar or
14642 C...b bbar kinematically possible).
14643 KFLB=K(IMI(JS,1,1),2)
14645 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14646 C...Check PT2MAX > mQ^2
14647 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
14648 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14649 & 'No Q creation possible.')
14653 C...Check for physical z values (m == MQ / sqrt(s))
14654 C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14655 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
14656 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
14657 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
14658 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
14669 C...Zero joining array
14675 C----------------------------------------------------------------------
14676 C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14677 C...MINT(30). Store if emission PT2 scale is largest so far.
14678 C...Also generate test joinings if MSTP(96)=1.
14679 ELSEIF(MODE.EQ.0) THEN
14684 C...No shower for structureless beam
14685 IF (MINT(44+JS).EQ.1) RETURN
14688 C...Absolute shower max scale = VINT(56)
14689 PT2=MIN(PT2NOW,VINT(56))
14690 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
14691 C...Define for which processes ME corrections have been implemented.
14692 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
14693 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
14694 & .142.OR.ISUB.EQ.144) MECOR=1
14695 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
14696 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
14697 C...Calculate preweighting factor for ME-corrected processes.
14698 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14700 C...Basic info on daughter for which to find mother.
14701 KFLB=K(IMI(JS,MI,1),2)
14703 C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14704 C...second companion.
14705 KSVCB=MAX(-1,IMI(JS,MI,2))
14706 C...Treat "first" companion of a pair like an ordinary sea quark
14707 C...(except that creation diagram is not allowed)
14708 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
14709 C...X (rescaled to [0,1])
14710 XB=XMI(JS,MI)/VINT(142+JS)
14711 C...Massive quarks (use physical masses.)
14714 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14716 IF (KFLBA.EQ.5) RMQ2=RMB2
14717 C...Special threshold treatment for non-photon beams
14718 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
14721 C...Flags for parton distribution calls.
14722 MINT(105)=MINT(102+JS)
14723 MINT(109)=MINT(106+JS)
14724 VINT(120)=VINT(2+JS)
14727 C.... Store side in MINT(124)
14730 C...Calculate initial parton distribution weights.
14731 IF(XB.GE.XMXC) THEN
14733 ELSEIF(MQMASS.EQ.0) THEN
14734 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14736 C...Initialize massive quark PT2 dependent pdf underestimate.
14738 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
14739 C.!.Tentative treatment of massive valence quarks.
14740 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
14742 TPM0=LOG(PT20/RMQ2)
14745 IF (KFLBA.LE.6) THEN
14746 C...For quarks, only include respective sea, val, or cmp part.
14747 IF (KSVCB.LE.0) THEN
14748 XFB(KFLB)=XPSVC(KFLB,KSVCB)
14750 C...Find companion's companion
14753 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
14757 C...Momentum fraction of the companion quark.
14758 C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
14760 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14764 C...Determine overestimated z range: switch at c and b masses.
14765 130 IF (PT2.GT.TMIN*RMB2) THEN
14767 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
14770 ELSEIF(PT2.GT.TMIN*RMC2) THEN
14772 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
14781 C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
14782 ALAM2=ALAM2/PARP(64)
14783 C...Overestimated ZMAX:
14784 IF (MQMASS.EQ.0) THEN
14786 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
14789 C...Massive (limit for bremsstrahlung diagram > creation)
14790 FMQ=SQRT(RMQ2/SHTNOW(MI))
14795 C...If kinematically impossible then do not evolve.
14796 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
14798 C...Reset Altarelli-Parisi and PDF weights.
14805 C...Zero joining weights and compute X(partner) and X(mother) values.
14806 IF (MSTP(96).NE.0) THEN
14808 DO 150 MJ=1,MINT(31)
14811 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
14812 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
14817 C...Approximate Altarelli-Parisi weights (integrated AP dz).
14818 C...q -> q, g -> q or q -> q + gamma (already set which).
14819 IF(KFLBA.LE.5) THEN
14820 C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
14821 IF (KSVCB.LT.0) THEN
14822 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14824 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
14825 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
14826 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
14828 WTAP(21)=0.5D0*(ZMAX-ZMIN)
14829 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14830 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
14831 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14832 WTAP(KFLB)=WTFF*WTAP(KFLB)
14833 WTAP(21)=WTGF*WTAP(21)
14836 IF (KSVCB.GE.1) THEN
14837 C...Kill normal creation but add joining diagrams for cmp quark.
14839 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14840 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
14841 & " quark here. Not handled yet, giving up!")
14846 C...Check for possible joinings
14847 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
14848 C...Find companion's companion.
14851 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
14852 IF (MJOIND(JS,MJ).EQ.0) THEN
14855 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
14856 IF (WTAPJ(MJ).GT.1D-6) THEN
14862 C...Add trial gluon joinings.
14863 DO 170 MJ=1,MINT(31)
14864 KFLC=K(IMI(JS,MJ,1),2)
14865 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
14866 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14867 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14868 IF (WTAPJ(MJ).GT.1D-6) THEN
14875 ELSEIF (IMI(JS,MI,2).GE.0) THEN
14876 C...Kill creation diagram for val quarks and sea quarks with companions.
14878 ELSEIF (MQMASS.EQ.0) THEN
14879 C...Extra safety factor for massless sea quark creation.
14880 WTAP(21)=WTAP(21)*1.25D0
14883 C... q -> g, g -> g.
14884 ELSEIF(KFLB.EQ.21) THEN
14885 C...Here we decide later whether a quark picked up is valence or
14886 C...sea, so we maintain the extra factor sqrt(z) since we deal
14887 C...with the *sum* of sea and valence in this context.
14888 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
14889 C...new: do not allow backwards evol to pick up heavy flavour.
14890 DO 180 KFL=1,MIN(3,MSTP(58))
14894 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
14895 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14897 WTAP(21)=WTGG*WTAP(21)
14899 C...Check for possible joinings (companions handled separately above)
14900 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
14902 DO 190 MJ=1,MINT(31)
14903 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
14905 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14906 IF (KSVCC.GE.1) GOTO 190
14907 KFLC=K(IMI(JS,MJ,1),2)
14908 C...Only try g -> g + g once.
14909 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
14910 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14911 IF (KFLC.EQ.21) THEN
14912 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14914 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
14916 IF (WTAPJ(MJ).GT.1D-6) THEN
14925 C...Initialize massive quark evolution
14926 IF (MQMASS.NE.0) THEN
14927 RML=(RMQ2+VINT(18))/ALAM2
14929 TPL=LOG((PT2+VINT(18))/ALAM2)
14930 TPM=LOG((PT2+VINT(18))/RMQ2)
14931 WN=WTAP(21)*WPDF0/B0
14935 C...Loopback point for iteration
14939 IF(NTRY.GT.500) THEN
14940 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
14945 C... Calculate PDF weights and sum for evolution rate.
14947 XFBO=MAX(1D-10,XFB(KFLB))
14949 WTPDF(KFL)=XFB(KFL)/XFBO
14950 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
14952 C...Only add gluon mother diagram for massless KFLB.
14953 IF(MQMASS.EQ.0) THEN
14954 WTPDF(21)=XFB(21)/XFBO
14955 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
14957 WTSUM=MAX(0.0001D0,WTSUM)
14959 C...Add joining diagrams where applicable.
14961 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14962 DO 220 MJ=1,MINT(31)
14963 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
14964 WTPDFJ(MJ)=1D0/XFBO
14965 C...x and x*pdf (+ sea/val) for parton C.
14966 KFLC=K(IMI(JS,MJ,1),2)
14968 KSVCC=MAX(-1,IMI(JS,MJ,2))
14969 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14973 C.... Store side in MINT(124)
14976 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14978 IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
14979 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14980 ELSEIF (KSVCC.GE.1) THEN
14981 print*, 'error! parton C is companion!'
14983 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
14984 C...x and x*pdf (+ sea/val) for parton A.
14987 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14990 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14996 C.... Store side in MINT(124)
14999 IF (KSVCA.LE.0) THEN
15000 C...Consider C the "evolved" parton if B is gluon. Val/sea
15001 C...counting will then be done correctly in PYPDFU.
15002 IF (KFLBA.EQ.21) MINT(36)=MJ
15003 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15005 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15007 C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
15008 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
15010 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
15011 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
15015 C...Pick normal pT2 (in overestimated z range).
15018 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
15021 C...Evolve q -> q gamma separately, pick it if larger pT.
15022 IF(KFLBA.LE.5) THEN
15023 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
15024 IF(PT2QED.GT.PT2) THEN
15031 C... Evolve massive quark creation separately.
15033 IF (MQMASS.NE.0) THEN
15034 if (WN .eq. 0.) THEN
15037 ARG = TPM/(TPL*PYR(0)**(-TML/WN)-TPM)
15039 PT2CR=(RMQ2+VINT(18))*(RML**ARG)-VINT(18)
15040 C... Ensure mininimum PT2CR and force creation near threshold.
15041 IF (PT2CR.LT.TMIN*RMQ2) THEN
15043 IF (NTHRES.GT.50) THEN
15044 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
15045 & 'massive quark creation. Gave up trying.')
15047 C...Special return code if failing before any evolution at all: bad event
15048 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
15055 C... Select largest PT2 (brems or creation):
15056 IF (PT2CR.GT.PT2) THEN
15065 C... Compute logarithms for this PT2
15066 TPL=LOG((PT2+VINT(18))/ALAM2)
15067 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
15068 WTCRQQ=TPM/LOG(PT2/RMQ2)
15071 C...Evolve joining separately
15073 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
15074 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
15076 IF (PT2JN.GE.PT2) THEN
15082 C...Loopback if crossed c/b mass thresholds.
15083 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
15086 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
15091 C...Speed up shower. Skip if higher-PT acceptable branching
15092 C...already found somewhere else.
15093 C...Also finish if below lower cutoff.
15095 IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
15097 C...Select parton A flavour (massive Q handled above.)
15098 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
15102 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
15103 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
15104 IF(KFLA.EQ.6) KFLA=21
15105 ELSEIF (MJOIN.EQ.1) THEN
15106 C...Tentative joining accept/reject.
15107 WTRAN=PYR(0)*WTJOIN
15110 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
15111 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
15112 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
15113 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
15117 C...x*pdf (+ sea/val) at new pT2 for parton B.
15118 IF (KSVCB.LE.0) THEN
15121 C.... Store side in MINT(124)
15124 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
15125 IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
15127 C...Companion distributions do not evolve.
15130 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
15131 KFLC=K(IMI(JS,MJ,1),2)
15133 KSVCC=MAX(-1,IMI(JS,MJ,2))
15134 IF (KSVCB.GE.1) KSVCC=-1
15135 C...x*pdf (+ sea/val) at new pT2 for parton C.
15139 C.... Store side in MINT(124)
15142 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
15144 IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
15145 WTVETO=WTVETO/XFJ(KFLC)
15146 C...x and x*pdf (+ sea/val) at new pT2 for parton A.
15149 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
15152 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15156 IF (KSVCA.LE.0) THEN
15159 C.... Store side in MINT(124)
15162 IF (KFLB.EQ.21) MINT(36)=MJ
15163 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15165 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15167 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
15169 WTVETO=WTVETO*XFJ(KFLA)
15170 C...Monte Carlo veto.
15171 IF (WTVETO.LT.PYR(0)) GOTO 200
15172 C...If accept, save PT2 of this joining.
15173 IF (PT2.GT.PT2MX) THEN
15181 C...Exit and continue evolution.
15186 C...Choose z value (still in overestimated range) and corrective weight.
15187 C...Unphysical z will be rejected below when Q2 has is computed.
15190 C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
15191 C...q -> q + g or q -> q + gamma (already set which).
15192 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
15193 IF (KSVCB.LT.0) THEN
15194 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
15196 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
15197 Z=((1-ZFAC)/(1+ZFAC))**2
15199 WTZ=0.5D0*(1D0+Z**2)
15200 C...Massive weight correction.
15201 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
15202 C...Valence quark weight correction (extra sqrt)
15203 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
15206 C...NB: MQ>0 not yet implemented. Forced absent above.
15207 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
15209 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
15210 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
15213 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
15215 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
15216 WTZ=Z**2+(1D0-Z)**2
15217 C...Massive correction
15218 IF (MQMASS.NE.0) THEN
15219 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
15220 C...Extra safety margin for light sea quark creation
15221 ELSEIF (KSVCB.LT.0) THEN
15226 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15228 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
15229 & (ZMAX*(1D0-ZMIN)))**PYR(0))
15230 WTZ=(1D0-Z*(1D0-Z))**2
15233 C...Derive Q2 from pT2.
15235 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
15237 C...Loopback if outside allowed z range for given pT2.
15238 RM2C=PYMASS(KFLC)**2
15239 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
15240 IF (PT2ADJ.LT.1D-6) GOTO 230
15242 C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
15243 C...No modification for very first emission if using ME correction
15245 IF (MECOR.GE.1.AND.NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) THEN
15249 C...For 1st branching, limit phase space by s-hat with color-partner
15250 IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15253 C...Use anticolor tag for antiquark, or for gluon half the time
15254 IF ((KFLB.LT.0.AND.KFLBA.LT.10).OR.(
15255 & KFLB.EQ.21.AND.PYR(0).GT.0.5)) MSIDE=2
15257 MCTAG=MCT(IDIP,MSIDE)
15258 C...Default is to set up phase space using the opposite incoming parton
15259 JDIP=IMI(3-JS,MI,1)
15261 C...Alternatively, look for final-state color partner (pick first if several)
15263 IF (MCT(IPART(IFS),MSIDE).EQ.MCTAG.AND.NDIP.EQ.0) THEN
15268 C...Compute mass of pair
15269 SDIP=(P(IDIP,4)+P(JDIP,4))**2-(P(IDIP,3)+P(JDIP,3))**2
15270 & -(P(IDIP,2)+P(JDIP,2))**2-(P(IDIP,1)+P(JDIP,1))**2
15271 IF (MSTP67.EQ.1) THEN
15272 C...1 Option to completely kill radiation above s_dip * PARP(67)
15273 IF (4*PT2.GT.PARP(67)*SDIP) GOTO 230
15274 ELSE IF (MSTP67.EQ.2) THEN
15275 C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
15276 C... (-> improved power showers?)
15277 IF (4*PT2*PYR(0).GT.PARP(67)*SDIP) GOTO 230
15280 C...For subsequent branchings, loopback if nonordered in angle/rapidity
15281 ELSE IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
15282 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
15286 C...Select phi angle of branching at random.
15289 C...Matrix-element corrections for some processes.
15290 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15291 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
15292 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15294 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
15295 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15297 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
15298 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15300 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15301 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15306 C...Parton distributions at new pT2 but old x.
15309 C.... Store side in MINT(124)
15312 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
15313 C...Treat val and cmp separately
15314 IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
15316 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
15318 IF(XFBN.LT.1D-20) THEN
15319 IF(KFLA.EQ.KFLB) THEN
15332 C...Parton distributions at new pT2 and new x.
15336 C.... Store side in MINT(124)
15339 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
15340 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
15341 C...q -> q + g: only consider respective sea, val, or cmp content.
15342 IF (KSVCB.LE.0) THEN
15343 XFA(KFLA)=XPSVC(KFLA,KSVCB)
15346 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
15350 IF(XFAN.LT.1D-20) THEN
15354 C...If weighting fails continue evolution.
15356 IF (MCRQQ.EQ.0) THEN
15357 WTPDFA=1D0/WTPDF(KFLA)
15358 WTTOT=WTZ*XFAN/XFBN*WTPDFA
15359 ELSEIF(MCRQQ.EQ.1) THEN
15361 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
15363 ELSEIF(MCRQQ.EQ.2) THEN
15364 C...Force massive quark creation.
15368 C...Loop back if trial emission fails.
15369 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
15370 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
15371 IF(WTTOT.LT.0D0) THEN
15372 WRITE(CHWT,'(1P,E12.4)') WTTOT
15373 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
15374 ELSEIF(WTTOT.GT.WTACC) THEN
15375 WRITE(CHWT,'(1P,E12.4)') WTTOT
15376 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
15377 C...Too high weight: write out as error, but do not update error counter
15378 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
15380 & '(PYPTIS:) Weight '//CHWT//' above unity')
15381 IF (PT2.GT.PTEMAX) PTEMAX=PT2
15382 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
15385 & '(PYPTIS:) Weight '//CHWT//' above unity')
15387 C...Useful for debugging but commented out for distribution:
15388 C print*, 'JS, MI',JS, MI
15389 C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
15390 C print*, 'A -> B C',KFLA, KFLB, KFLC
15392 C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
15395 C...Save acceptable branching.
15396 IF(PT2.GT.PT2MX) THEN
15409 C----------------------------------------------------------------------
15410 C...MODE= 1: Accept stored shower branching. Update event record etc.
15411 ELSEIF (MODE.EQ.1) THEN
15416 C...Shift down rest of event record to make room for insertion.
15421 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
15422 KT1=K(I,4)/MSTU(5)**2
15423 KT2=K(I,5)/MSTU(5)**2
15424 ID1=MOD(K(I,4),MSTU(5))
15425 ID2=MOD(K(I,5),MSTU(5))
15426 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
15427 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
15428 IF (ID1.GE.IT) ID1=ID1+2
15429 IF (ID2.GE.IT) ID2=ID2+2
15430 IF (IM1.GE.IT) IM1=IM1+2
15431 IF (IM2.GE.IT) IM2=IM2+2
15432 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
15433 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
15439 MCT(I+2,1)=MCT(I,1)
15440 MCT(I+2,2)=MCT(I,2)
15443 C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
15444 DO 300 JI=1,MINT(31)
15445 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
15446 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
15447 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
15448 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
15449 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
15450 C...Also update companion pointers to the present mother.
15451 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
15454 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
15456 C...Zero entries dedicated for new timelike and mother partons.
15467 C...Define timelike and new mother partons. History.
15474 C...Set mother origin = side.
15475 K(IM,3)=MINT(83)+JS+2
15476 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
15478 C...Define colour flow of branching.
15481 C...q -> q + gamma.
15482 IF(K(IT,2).EQ.22) THEN
15487 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
15491 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
15494 C...qbar -> qbar + g.
15495 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
15498 C...qbar -> g + qbar.
15499 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
15502 C...g -> g + g; g -> q + qbar..
15503 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
15510 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
15511 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
15512 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
15513 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
15514 IF(ID1.NE.ID2) THEN
15515 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
15516 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
15518 IF(K(IT,1).EQ.1) THEN
15522 C...Update IMI and colour tag arrays.
15530 C...If mother flag not yet set for spacelike parton, trace it.
15531 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
15532 IF(MINT(51).NE.0) RETURN
15536 C...If mother flag not yet set for timelike parton, trace it.
15537 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
15538 IF(MINT(51).NE.0) RETURN
15541 C...Boost recoiling parton to compensate for Q2 scale.
15542 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
15543 & (1D0+(1D0+Q2BMX/SHAT)**2)
15545 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
15547 C...Define system to be rotated and boosted
15548 C...(not including the 2 just added partons)
15549 C...(but including the docu lines for first interaction)
15550 IMIN=IMISEP(MI-1)+1
15551 IF (MI.EQ.1) IMIN=MINT(83)+5
15554 C...Rotate back system in phi to compensate for subsequent rotation.
15555 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
15557 C...Define kinematics of new partons in old frame.
15559 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
15560 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
15561 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
15562 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
15564 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
15565 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
15566 P(IT,5)=SQRT(RM2CMX)
15568 C...Update internal line, now spacelike
15569 P(IS,1)=P(IM,1)-P(IT,1)
15570 P(IS,2)=P(IM,2)-P(IT,2)
15571 P(IS,3)=P(IM,3)-P(IT,3)
15572 P(IS,4)=P(IM,4)-P(IT,4)
15573 P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
15574 C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
15575 IF (P(IS,5).LT.0D0) THEN
15576 P(IS,5)=-SQRT(ABS(P(IS,5)))
15578 P(IS,5)=SQRT(P(IS,5))
15581 C...Boost entire system and rotate to new frame.
15582 C...(including docu lines)
15583 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
15584 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
15585 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
15586 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
15591 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
15593 THETA=PYANGL(P(I1,3),P(I1,1))
15594 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
15596 C...Global statistics.
15597 MINT(352)=MINT(352)+1
15598 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
15599 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
15601 C...Add parton with relevant pT scale for timelike shower.
15602 IF (K(IT,2).NE.22) THEN
15605 PTPART(NPART)=SQRT(PT2AMX)
15608 C...Update saved variables.
15609 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15610 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15611 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15612 PT2SAV(JSMX,MIMX)=PT2MX
15617 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15618 C...Gluon reconstructs to quark.
15619 C...Decide whether newly created quark is valence or sea:
15621 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15622 IF(MINT(51).NE.0) RETURN
15624 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15625 C...Quark reconstructs to gluon.
15626 C...Now some guy may have lost his companion. Check.
15628 IF (ICMP.GT.0) THEN
15629 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15630 & //' away. Cannot handle that yet. Giving up.')
15633 ELSEIF(ICMP.LT.0) THEN
15634 C...A sea quark with companion still in BR was reconstructed to a gluon.
15635 C...Companion should now be removed from the beam remnant.
15636 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15639 DO 380 JCMP=ICMP,NVC(JS,IFL)-1
15640 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15641 DO 370 JI=1,MINT(31)
15643 JFL=-K(IMI(JS,JI,1),2)
15644 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15648 NVC(JS,IFL)=NVC(JS,IFL)-1
15650 C...Set gluon IMI(JS,MI,2) = 0.
15652 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15653 C...Quark reconstructing to quark. If sea with companion still in BR
15654 C...then update associated x value.
15655 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15656 IF (IMI(JS,MI,2).LT.0) THEN
15659 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15665 C...If reached this point, normal exit.
15671 C*********************************************************************
15674 C...Generates maximum ME weight in some initial-state showers.
15675 C...Inparameter MECOR: kind of hard scattering process
15676 C...Outparameter WTFF: maximum weight for fermion -> fermion
15677 C... WTGF: maximum weight for gluon/photon -> fermion
15678 C... WTFG: maximum weight for fermion -> gluon/photon
15679 C... WTGG: maximum weight for gluon -> gluon
15681 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15683 C...Double precision and integer declarations.
15684 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15685 IMPLICIT INTEGER(I-N)
15686 INTEGER PYK,PYCHGE,PYCOMP
15688 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15689 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15690 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15691 COMMON/PYINT1/MINT(400),VINT(400)
15692 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15693 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15695 C...Default maximum weight.
15701 C...Select maximum weight by process.
15702 IF(MECOR.EQ.1) THEN
15705 ELSEIF(MECOR.EQ.2) THEN
15713 C*********************************************************************
15716 C...Calculates actual ME weight in some initial-state showers.
15717 C...Inparameter MECOR: kind of hard scattering process
15718 C... IFLCB: flavour combination of branching,
15719 C... 1 for fermion -> fermion,
15720 C... 2 for gluon/photon -> fermion
15721 C... 3 for fermion -> gluon/photon,
15722 C... 4 for gluon -> gluon
15723 C... Q2: Q2 value of shower branching
15724 C... Z: Z value of branching
15725 C...In+outparameter PHIBR: azimuthal angle of branching
15726 C...Outparameter WTME: actual ME weight
15728 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
15730 C...Double precision and integer declarations.
15731 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15732 IMPLICIT INTEGER(I-N)
15733 INTEGER PYK,PYCHGE,PYCOMP
15735 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15736 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15737 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15738 COMMON/PYINT1/MINT(400),VINT(400)
15739 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15740 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15742 C...Default output.
15745 C...Define kinematics of shower branching in Mandelstam variables.
15749 UH=Q2-SQM*(1D0-Z)/Z
15751 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
15752 IF(MECOR.EQ.1) THEN
15753 IF(IFLCB.EQ.1) THEN
15754 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
15755 ELSEIF(IFLCB.EQ.2) THEN
15756 WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
15759 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
15760 ELSEIF(MECOR.EQ.2) THEN
15761 IF(IFLCB.EQ.3) THEN
15762 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
15763 ELSEIF(IFLCB.EQ.4) THEN
15764 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
15767 C...Matrix-element corrections for q + qbar -> Higgs (h0)
15768 ELSEIF(MECOR.EQ.3) THEN
15769 IF(IFLCB.EQ.2) THEN
15770 WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
15771 1 (SH**2+2D0*SQM*(SQM-SH))
15778 C*********************************************************************
15781 C...Handles the generation of additional interactions in the new
15782 C...multiple interactions framework.
15783 C...MODE=-1 : Initalize MI from scratch.
15784 C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
15785 C... Sudakov for PT2, abort if below PT2CUT.
15786 C...MODE= 1 : Accept interaction at PT2NOW and store variables.
15787 C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
15788 C...PT2NOW : Starting (max) PT2 scale for evolution.
15789 C...PT2CUT : Lower limit for evolution.
15790 C...PT2 : Result of evolution. Generated PT2 for trial interaction.
15791 C...IFAIL : Status return code.
15792 C... = 0: All is well.
15793 C... < 0: Phase space exhausted, generation to be terminated.
15794 C... > 0: Additional interaction vetoed, but continue evolution.
15796 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
15797 C...Double precision and integer declarations.
15798 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15799 IMPLICIT INTEGER(I-N)
15800 INTEGER PYK,PYCHGE,PYCOMP
15801 C...Parameter statement for maximum size of showers.
15802 PARAMETER (MAXNUR=1000)
15804 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15805 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15806 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15807 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15808 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15809 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15810 COMMON/PYINT1/MINT(400),VINT(400)
15811 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15812 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15813 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15814 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15815 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
15816 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
15817 & XMI(2,240),PT2MI(240),IMISEP(0:240)
15818 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
15819 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
15820 COMMON/PYCTAG/NCT,MCT(4000,2)
15821 C...Local arrays and saved variables.
15822 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
15824 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
15825 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
15826 & /PYISMX/,/PYCTAG/
15830 C...Set MI subprocess = QCD 2 -> 2.
15833 C----------------------------------------------------------------------
15834 C...MODE=-1: Initialize from scratch
15835 IF (MODE.EQ.-1) THEN
15836 C...Initialize PT2 array.
15838 C...Initialize list of incoming beams and partons from two sides.
15845 IMI(JS,1,1)=MINT(84)+JS
15847 XMI(JS,1)=VINT(40+JS)
15848 C...Rescale x values to fractions of photon energy.
15849 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
15850 C...Hard reset: hard interaction initiators motherless by definition.
15851 K(MINT(84)+JS,3)=2+JS
15852 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
15853 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
15857 IF (MOD(MSTP(81),10).GE.1) THEN
15858 IF(MSTP(82).LE.1) THEN
15859 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
15861 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
15862 & VINT(317)/(VINT(318)*VINT(320))
15863 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
15865 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
15866 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
15869 C...Zero entries relating to scatterings beyond the first.
15875 IMISEP(MI)=IMISEP(1)
15880 C...Initialize factors for PDF reshaping.
15882 KFBEAM(JS)=MINT(10+JS)
15883 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
15884 KFABM=IABS(KFBEAM(JS))
15885 KFSBM=ISIGN(1,KFBEAM(JS))
15887 C...Zero flavour content of incoming beam particle.
15891 C... Flavour content of baryon.
15892 IF(KFABM.GT.1000) THEN
15893 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
15894 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
15895 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
15896 C... Flavour content of pi+-, K+-.
15897 ELSEIF(KFABM.EQ.211) THEN
15898 KFIVAL(JS,1)=KFSBM*2
15899 KFIVAL(JS,2)=-KFSBM
15900 ELSEIF(KFABM.EQ.321) THEN
15901 KFIVAL(JS,1)=-KFSBM*3
15902 KFIVAL(JS,2)=KFSBM*2
15903 C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
15906 C...Zero initial valence and companion content.
15911 C...Set up colour line tags starting from hard interaction initiators.
15913 C...Reset colour tag array and colour processing flags.
15914 DO 150 I=IMISEP(0)+1,N
15917 K(I,4)=MOD(K(I,4),MSTU(5)**2)
15918 K(I,5)=MOD(K(I,5),MSTU(5)**2)
15920 C... Consider each side in turn.
15925 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15927 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
15929 CALL PYCTTR(I1,KCS,I2)
15930 IF(MINT(51).NE.0) RETURN
15934 C...Range checking for companion quark pdf large-x param.
15935 IF (MSTP(87).LT.0) THEN
15936 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15939 ELSEIF (MSTP(87).GT.4) THEN
15940 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15945 C----------------------------------------------------------------------
15946 C...MODE=0: Generate trial interaction. Return codes:
15947 C...IFAIL < 0: Phase space exhausted, generation to be terminated.
15948 C...IFAIL = 0: Additional interaction generated at PT2.
15949 C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
15950 ELSEIF (MODE.EQ.0) THEN
15951 C...Abolute MI max scale = VINT(62)
15952 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
15953 180 IF(MSTP(82).LE.1) THEN
15954 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
15955 IF(XT2.LT.VINT(149)) IFAIL=-2
15957 IF(XT2.LE.0.01001D0*VINT(149)) THEN
15960 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
15961 & LOG(PYR(0)))-VINT(149)
15964 C...Also exit if below lower limit or if higher trial branching
15966 PT2=0.25D0*VINT(2)*XT2
15967 IF (PT2.LE.PT2CUT) IFAIL=-4
15968 IF (PT2.LE.PT2MX) IFAIL=-5
15969 IF (IFAIL.NE.0) THEN
15973 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
15974 VINT(25)=4D0*PT2/VINT(2)
15977 C...Choose tau and y*. Calculate cos(theta-hat).
15978 IF(PYR(0).LE.COEF(ISUB,1)) THEN
15979 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
15980 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
15982 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
15985 C...New: require shat > 1.
15986 IF(TAU*VINT(2).LT.1D0) GOTO 180
15990 IF(RYST.GT.COEF(ISUB,8)) MYST=2
15991 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
15992 CALL PYKMAP(2,MYST,PYR(0))
15993 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
15995 C...Check that x not used up. Accept or reject kinematical variables.
15996 X1M=SQRT(TAU)*EXP(VINT(22))
15997 X2M=SQRT(TAU)*EXP(-VINT(22))
15998 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
15999 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
16000 CALL PYSIGH(NCHN,SIGS)
16001 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
16002 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
16003 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
16005 C...Save if highest PT so far.
16006 IF (PT2.GT.PT2MX) THEN
16012 C----------------------------------------------------------------------
16013 C...MODE=1: Generate and save accepted scattering.
16014 ELSEIF (MODE.EQ.1) THEN
16016 C...Reset K, P, V, and MCT vectors.
16028 C...Choose flavour of reacting partons (and subprocess).
16030 IF (NTRY.GT.50) THEN
16031 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
16032 & //'interaction. Giving up!')
16040 ICONMI=ISIG(ICHN,3)
16041 RSIGS=RSIGS-SIGH(ICHN)
16042 IF(RSIGS.LE.0D0) GOTO 230
16045 C...Reassign to appropriate process codes.
16046 230 ISUBMI=ICONMI/10
16047 ICONMI=MOD(ICONMI,10)
16049 C...Choose new quark flavour for annihilation graphs
16050 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
16051 SH=VINT(21)*VINT(2)
16052 CALL PYWIDT(21,SH,WDTP,WDTE)
16053 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
16054 DO 250 I=1,MDCY(21,3)
16055 KFLF=KFDP(I+MDCY(21,2)-1,1)
16056 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
16057 IF(RKFL.LE.0D0) GOTO 260
16059 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
16060 IF(KFLF.GE.4) GOTO 240
16061 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
16064 ELSEIF(ISUBMI.EQ.53) THEN
16070 C...Final state flavours and colour flow: default values
16077 IF(ISUBMI.EQ.11) THEN
16078 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
16080 IF(KFL1*KFL2.LT.0) KCC=KCC+2
16082 ELSEIF(ISUBMI.EQ.12) THEN
16083 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
16084 KFL3=ISIGN(KFLF,KFL1)
16088 ELSEIF(ISUBMI.EQ.13) THEN
16089 C...f + fbar -> g + g; th arbitrary
16094 ELSEIF(ISUBMI.EQ.28) THEN
16095 C...f + g -> f + g; th = (p(f)-p(f))**2
16096 IF(KFL1.EQ.21) JS=2
16098 IF(KFL1.EQ.21) KCC=KCC+2
16099 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
16100 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
16102 ELSEIF(ISUBMI.EQ.53) THEN
16103 C...g + g -> f + fbar; th arbitrary
16104 KCS=(-1)**INT(1.5D0+PYR(0))
16105 KFL3=ISIGN(KFLF,KCS)
16109 ELSEIF(ISUBMI.EQ.68) THEN
16110 C...g + g -> g + g; th arbitrary
16112 KCS=(-1)**INT(1.5D0+PYR(0))
16115 C...Check that massive sea quarks have non-zero phase space for g -> Q Q
16116 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
16117 & .OR.IABS(KFL4).EQ.5) THEN
16118 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
16119 IF (PT2.LE.1.05*RMMAX2) THEN
16120 IF (NTRY.EQ.2) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
16121 & //' too close to threshold (2nd try).')
16126 C...Store flavours of scattering.
16134 C...Set flavours and mothers of scattering partons.
16143 K(N+1,3)=MINT(83)+1
16144 K(N+2,3)=MINT(83)+2
16148 C...Store colour connection indices.
16151 IF(KCS.EQ.-1) JC=3-J
16152 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
16153 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
16154 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
16155 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
16158 C...Store incoming and outgoing partons in their CM-frame.
16159 SHR=SQRT(VINT(21))*VINT(1)
16162 P(N+2,3)=-0.5D0*SHR
16164 P(N+3,5)=PYMASS(K(N+3,2))
16165 P(N+4,5)=PYMASS(K(N+4,2))
16166 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
16170 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
16171 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
16172 P(N+4,4)=SHR-P(N+3,4)
16175 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
16177 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
16179 C...Global statistics.
16180 MINT(351)=MINT(351)+1
16181 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
16182 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
16184 C...Keep track of loose colour ends and information on scattering.
16185 MINT(31)=MINT(31)+1
16187 PT2MI(MINT(36))=PT2
16188 IMISEP(MINT(31))=N+4
16190 IMI(JS,MINT(31),1)=N+JS
16191 IMI(JS,MINT(31),2)=0
16192 XMI(JS,MINT(31))=VINT(40+JS)
16194 C...Update cumulative counters
16195 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
16196 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
16199 C...Add to list of final state partons
16202 PTPART(NPART+1)=SQRT(PT2)
16203 PTPART(NPART+2)=SQRT(PT2)
16207 NISGEN(1,MINT(31))=0
16208 NISGEN(2,MINT(31))=0
16212 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
16213 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
16218 C...Finally, assign colour tags to new partons
16220 I1=IMI(JS,MINT(31),1)
16221 I2=IMI(3-JS,MINT(31),1)
16223 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
16225 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
16227 CALL PYCTTR(I1,KCS,I2)
16228 IF(MINT(51).NE.0) RETURN
16232 C----------------------------------------------------------------------
16233 C...MODE=2: Decide whether quarks in last scattering were valence,
16234 C...companion, or sea.
16235 ELSEIF (MODE.EQ.2) THEN
16239 KFSBM=ISIGN(1,MINT(10+JS))
16240 IFL=K(IMI(JS,MI,1),2)
16242 IF (IABS(IFL).GE.6) THEN
16243 IF (IABS(IFL).EQ.6) THEN
16244 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
16248 C...Get PDFs at X(rescaled) and PT2 of the current initiator.
16249 C...(Do not include the parton itself in the X rescaling.)
16251 XRSC=X/(VINT(142+JS)+X)
16252 C...Note: XPSVC = x*pdf.
16255 C.... Store side in MINT(124)
16258 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
16261 C...Ensure that pdfs are positive definite
16262 IF (SEA.LT.0D0) THEN
16263 CALL PYERRM(9,'(PYPTMI:) Sea distribution negative.')
16265 ELSEIF (VAL.LT.0D0) THEN
16266 CALL PYERRM(9,'(PYPTMI:) Val distribution negative.')
16270 DO 310 IVC=1,NVC(JS,IFL)
16271 CMP=CMP+XPSVC(IFL,IVC)
16275 C...Decide (Extra factor x cancels in the dvision).
16276 320 RVCS=PYR(0)*(SEA+VAL+CMP)
16279 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
16280 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
16282 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
16283 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
16284 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
16285 IF(KFIVAL(JS,1).EQ.0) THEN
16286 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
16287 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
16288 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
16289 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
16291 C...Count down valence remaining. Do not count current scattering.
16292 DO 340 I1=1,NMI(JS)
16293 IF (I1.EQ.MINT(36)) GOTO 340
16294 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
16298 IF(IVNOW.EQ.0) GOTO 330
16301 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
16302 IF(KFIVAL(JS,1).EQ.0) THEN
16303 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
16306 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
16308 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
16309 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
16313 ELSEIF (RVCS.LE.VAL+SEA) THEN
16314 C...If sea, add opposite sign companion parton. Store X and I.
16315 NVC(JS,-IFL)=NVC(JS,-IFL)+1
16316 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
16317 C...Set pointer to companion
16318 IMI(JS,MI,2)=-NVC(JS,-IFL)
16321 C...If companion, check whether we've got any in the books
16322 IF (NVC(JS,IFL).EQ.0) THEN
16324 C...Only report error first time for this event
16326 & CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
16327 C...Try a few times
16328 IF (NTRY.LE.10) THEN
16330 C... But if it stil fails, abort this event
16336 C...If several possibilities, decide which one
16340 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
16341 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
16342 C...Find original sea (anti-)quark. Do not consider current scattering.
16344 DO 360 I1=1,NMI(JS)
16345 IF (I1.EQ.MINT(36)) GOTO 360
16346 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
16347 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
16348 IMI(JS,MI,2)=IMI(JS,I1,1)
16349 IMI(JS,I1,2)=IMI(JS,MI,1)
16352 C...Mark companion "out-kicked".
16353 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
16360 C*********************************************************************
16362 C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
16363 C...Giving the x*f pdf of a companion quark, with its partner at XS,
16364 C...using an approximate gluon density like (1-X)^NPOW/X. The value
16365 C...corresponds to an unrescaled range between 0 and 1-X.
16367 FUNCTION PYFCMP(XC,XS,NPOW)
16369 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
16373 C...Parent gluon momentum fraction
16375 IF (Y.GE.1D0) RETURN
16376 C...Common factor (includes factor XC, since PYFCMP=x*f)
16377 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
16378 C...Store normalized companion x*f distribution.
16379 IF (NPOW.LE.0) THEN
16380 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
16381 ELSEIF (NPOW.EQ.1) THEN
16382 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
16383 ELSEIF (NPOW.EQ.2) THEN
16384 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
16385 & +3D0*XS*(1D0+XS)*LOG(XS)))
16386 ELSEIF (NPOW.EQ.3) THEN
16387 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
16388 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16389 ELSEIF (NPOW.GE.4) THEN
16390 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
16391 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
16396 C*********************************************************************
16398 C...PYPCMP: Auxiliary to PYPDFU.
16399 C...Giving the momentum integral of a companion quark, with its
16400 C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
16401 C...The value corresponds to an unrescaled range between 0 and 1-XS.
16403 FUNCTION PYPCMP(XS,NPOW)
16405 DOUBLE PRECISION XS, PYPCMP
16407 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
16409 ELSEIF (NPOW.LE.0) THEN
16410 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
16411 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
16412 ELSEIF (NPOW.EQ.1) THEN
16413 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
16414 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
16415 ELSEIF (NPOW.EQ.2) THEN
16416 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
16417 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
16418 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
16419 & -3D0*XS*LOG(XS)*(1+XS)))
16420 ELSEIF (NPOW.EQ.3) THEN
16421 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
16422 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
16423 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
16424 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16426 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
16427 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
16428 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
16429 & -6D0*XS*LOG(XS)*(1D0+XS)))
16434 C*********************************************************************
16437 C...Rearranges contents of the HEPEUP commonblock so that
16438 C...mothers precede daughters and daughters of a decay are
16439 C...listed consecutively.
16443 C...Double precision and integer declarations.
16444 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16445 IMPLICIT INTEGER(I-N)
16447 C...User process event common block.
16449 PARAMETER (MAXNUP=500)
16450 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
16451 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
16452 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
16453 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
16454 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
16458 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
16459 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
16460 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
16462 C...Check whether a rearrangement is required.
16465 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
16468 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
16472 C...Find the new order that particles should have.
16478 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
16483 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
16484 IF(NNEW.NE.NUP) THEN
16486 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
16490 C...Copy old info into temporary storage.
16494 MOTUPT(1,I)=MOTHUP(1,I)
16495 MOTUPT(2,I)=MOTHUP(2,I)
16496 ICOUPT(1,I)=ICOLUP(1,I)
16497 ICOUPT(2,I)=ICOLUP(2,I)
16501 VTIUPT(I)=VTIMUP(I)
16502 SPIUPT(I)=SPINUP(I)
16505 C...Copy info back into HEPEUP in right order.
16508 IDUP(I)=IDUPT(IOLD)
16509 ISTUP(I)=ISTUPT(IOLD)
16513 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
16514 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
16516 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
16518 MOTHUP(1,I)=MOTHUP(2,I)
16521 ICOLUP(1,I)=ICOUPT(1,IOLD)
16522 ICOLUP(2,I)=ICOUPT(2,IOLD)
16524 PUP(J,I)=PUPT(J,IOLD)
16526 VTIMUP(I)=VTIUPT(IOLD)
16527 SPINUP(I)=SPIUPT(IOLD)
16531 c...If incoming particles are massive recalculate to put them massless.
16532 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
16533 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
16534 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
16535 PUP(4,1)=0.5D0*PPLUS
16538 PUP(4,2)=0.5D0*PMINUS
16546 C*********************************************************************
16549 C...Administers the generation of successive final-state showers
16550 C...in external processes.
16552 SUBROUTINE PYADSH(NFIN)
16554 C...Double precision and integer declarations.
16555 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16556 IMPLICIT INTEGER(I-N)
16557 INTEGER PYK,PYCHGE,PYCOMP
16558 C...Parameter statement for maximum size of showers.
16559 PARAMETER (MAXNUR=1000)
16561 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16562 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16563 COMMON/PYCTAG/NCT,MCT(4000,2)
16564 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16565 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16566 COMMON/PYINT1/MINT(400),VINT(400)
16567 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
16569 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
16571 C...Set primary vertex.
16573 V(MINT(83)+5,J)=0D0
16574 V(MINT(83)+6,J)=0D0
16575 V(MINT(84)+1,J)=0D0
16576 V(MINT(84)+2,J)=0D0
16579 C...Isolate systems of particles with the same mother.
16582 DO 140 I=MINT(84)+3,NFIN
16584 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
16591 C...Set production vertices.
16592 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
16599 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
16602 IF(MSTP(125).GE.1) THEN
16610 C...End loop over systems. Return if no showers to be performed.
16611 IBEG(NSYS+1)=NFIN+1
16612 IF(MSTP(71).LE.0) RETURN
16614 C...Loop through systems of particles; check that sensible size.
16616 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
16617 IF(MINT(35).LE.2) THEN
16618 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
16620 ELSEIF(NSIZ.LE.1) THEN
16621 CALL PYERRM(2,'(PYADSH:) only one particle in system')
16623 ELSEIF(NSIZ.GT.80) THEN
16624 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
16629 C...Save status codes and daughters of showering particles; reset them.
16636 IF(K(I,1).GT.10) THEN
16638 IF(KSAV(II,1).EQ.14) K(I,1)=3
16640 IF(KSAV(II,1).LE.10) THEN
16641 ELSEIF(K(I,1).EQ.1) THEN
16647 KSAV(II,4)=MOD(K(I,4),MSTU(5))
16648 KSAV(II,5)=MOD(K(I,5),MSTU(5))
16649 K(I,4)=K(I,4)-KSAV(II,4)
16650 K(I,5)=K(I,5)-KSAV(II,5)
16653 PSUM(J)=PSUM(J)+P(I,J)
16657 C...Perform shower.
16658 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16660 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16662 IF(MINT(35).LE.2) THEN
16664 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16666 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16669 C...For external processes, first call, also ISR partons radiate.
16670 C...Can use existing PYPART list, removing partons that radiate later.
16671 ELSEIF(ISYS.EQ.1) THEN
16674 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16676 IPART(NPARTN)=IPART(II)
16677 PTPART(NPARTN)=PTPART(II)
16681 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16683 C...For subsequent calls use the systems excluded above.
16689 PTPART(II)=0.5D0*QMAX
16691 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16694 C...Look up showered copies of original showering particles.
16698 C...Particles without daughters need not be studied.
16699 IF(KSAV(II,1).LE.10) GOTO 260
16700 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16701 ELSEIF(K(I,1).EQ.11) THEN
16702 190 IMV=MOD(K(IMV,4),MSTU(5))
16703 IF(K(IMV,1).EQ.11) GOTO 190
16705 KDA1=MOD(K(I,4),MSTU(5))
16707 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16709 KDA2=MOD(K(I,5),MSTU(5))
16711 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16714 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
16717 KDA1=MOD(K(I3,4),MSTU(5))
16719 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16721 KDA2=MOD(K(I3,5),MSTU(5))
16723 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16729 C...Restore daughter info of original partons to showered copies.
16730 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
16731 IF(KSAV(II,1).LE.10) THEN
16732 ELSEIF(K(I,1).EQ.1) THEN
16733 K(IMV,4)=KSAV(II,4)
16734 K(IMV,5)=KSAV(II,5)
16736 K(IMV,4)=K(IMV,4)+KSAV(II,4)
16737 K(IMV,5)=K(IMV,5)+KSAV(II,5)
16740 C...Reset mother info of existing daughters to showered copies.
16741 DO 210 I3=IBEG(ISYS+1),NFIN
16742 IF(K(I3,3).EQ.I) K(I3,3)=IMV
16743 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
16744 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
16745 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
16749 C...Boost all original daughters to new frame of showered copy.
16750 C...Also update their colour tags.
16753 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
16755 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
16757 BETA(J)=FAC*BETA(J)
16759 DO 250 I3=IBEG(ISYS+1),NFIN
16762 IF(MSTP(128).LE.0) THEN
16763 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
16764 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
16766 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16767 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16768 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16771 IF(IMO.EQ.IMV) THEN
16772 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16773 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16774 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16775 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
16783 C...End of loop over showering systems
16789 C*********************************************************************
16792 C...Interface to UPVETO, which allows user to veto event generation
16793 C...on the parton level, after parton showers but before multiple
16794 C...interactions, beam remnants and hadronization is added.
16796 SUBROUTINE PYVETO(IVETO)
16798 C...All real arithmetic in double precision.
16799 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16800 C...Three Pythia functions return integers, so need declaring.
16801 INTEGER PYK,PYCHGE,PYCOMP
16803 C...PYTHIA commonblocks.
16804 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16805 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16806 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16807 COMMON/PYINT1/MINT(400),VINT(400)
16808 SAVE /PYJETS/,/PYPARS/,/PYINT1/
16809 C...HEPEVT commonblock.
16810 PARAMETER (NMXHEP=4000)
16811 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16812 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
16813 DOUBLE PRECISION PHEP,VHEP
16816 DIMENSION IRESO(100)
16818 C...Define longitudinal boost from initiator rest frame to cm frame.
16819 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
16820 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
16822 C...Presentation is different if using pT-ordered shower
16823 IF(MINT(35).EQ.3) THEN
16828 C... Reset counters.
16833 C...Oth pass: identify beam and incoming partons
16834 DO 140 I=MINT(83)+1,MINT(83)+6
16836 IF(K(I,2).EQ.94) THEN
16845 C...First pass: identify final locations of resonances
16846 C...and of their daughters before showering.
16847 DO 150 I=MINT(84)+3,N
16851 C...Skip shower CM frame documentation lines.
16852 IF(K(I,2).EQ.94) THEN
16854 C... Store a new intermediate product, when mother in documentation.
16855 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
16856 & K(I,3).LE.MINT(84)) THEN
16862 IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
16864 C... Store a new intermediate product, when mother in main section.
16865 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
16866 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
16872 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
16875 IF(ISTORE.EQ.1) THEN
16876 C...Copy parton info, boosting momenta along z axis to cm frame.
16881 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16882 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16884 C...Store one mother. Rest of history and vertex info zeroed.
16896 C...Second pass: identify current set of "final" partons.
16897 DO 200 I=MINT(84)+3,N
16901 C...Store a final parton.
16902 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
16906 C..Trace it back through shower, to check if from documented particle.
16910 IF(IHIST.GT.MINT(84)) THEN
16911 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
16913 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
16917 IF(IMOTH.EQ.0) GOTO 160
16918 IMOTH=MAX(0,IMOTH-6)
16919 ELSEIF(IHIST.LE.4) THEN
16920 IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
16929 IF(ISTORE.EQ.1) THEN
16930 C...Copy parton info, boosting momenta along z axis to cm frame.
16935 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16936 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16938 C...Store one mother. Rest of history and vertex info zeroed.
16949 C...Call user-written routine to decide whether to keep events.
16953 C*********************************************************************
16956 C...Allows resonances to decay (including parton showers for hadronic
16959 SUBROUTINE PYRESD(IRES)
16961 C...Double precision and integer declarations.
16962 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16963 IMPLICIT INTEGER(I-N)
16964 INTEGER PYK,PYCHGE,PYCOMP
16965 C...Parameter statement to help give large particle numbers.
16966 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16967 &KEXCIT=4000000,KDIMEN=5000000)
16968 C...Parameter statement for maximum size of showers.
16969 PARAMETER (MAXNUR=1000)
16971 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16972 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16973 COMMON/PYCTAG/NCT,MCT(4000,2)
16974 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16975 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16976 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16977 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16978 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16979 COMMON/PYINT1/MINT(400),VINT(400)
16980 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16981 COMMON/PYINT4/MWID(500),WIDS(500,5)
16982 COMMON/PYPUED/IUED(0:99),RUED(0:99)
16983 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
16984 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/
16985 C...Local arrays and complex and character variables.
16986 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
16987 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
16988 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
16989 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
16990 &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(3),ITRI(3),IOCT(3)
16991 COMPLEX FGK,HA(6,6),HC(6,6)
16993 CHARACTER CODE*9,MASS*9
16995 C...The F, Xi and Xj functions of Gunion and Kunszt
16996 C...(Phys. Rev. D33, 665, plus errata from the authors).
16997 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
16998 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
16999 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
17000 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
17001 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
17002 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
17003 &2D0*(D34/D56+D56/D34))
17005 C...Some general constants.
17008 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
17012 GMMZ=PMAS(23,1)*PMAS(23,2)
17014 GMMW=PMAS(24,1)*PMAS(24,2)
17017 C...Boost and rotate to rest frame of incoming partons,
17018 C...to get proper amount of smearing of decay angles.
17024 C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons
17025 C...(101,102) are off shell and can have inconsistent momenta, resulting
17026 C...in boosts larger than unity. However, the corresponding docu partons
17027 C...(5,6) are kept on shell, and have consistent momenta that can be used
17028 C...to derive this boost instead. Ultimately, should change the way the new
17029 C...shower stores intermediate partons, but just using partons (5,6) for now
17030 C...does define the boost and furnishes a quick and much needed solution.
17031 IF (MINT(35).EQ.3) THEN
17035 ETOTIN=P(IIN1,4)+P(IIN2,4)
17036 BEXIN=(P(IIN1,1)+P(IIN2,1))/ETOTIN
17037 BEYIN=(P(IIN1,2)+P(IIN2,2))/ETOTIN
17038 BEZIN=(P(IIN1,3)+P(IIN2,3))/ETOTIN
17039 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
17040 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
17041 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
17042 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
17043 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
17046 C...Reset original resonance configuration.
17051 C...Define initial one, two or three objects for subprocess.
17055 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
17056 IREF(1,1)=MINT(84)+2+ISET(ISUB)
17057 IREF(1,4)=MINT(83)+6+ISET(ISUB)
17059 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
17060 IREF(1,1)=MINT(84)+1+ISET(ISUB)
17061 IREF(1,2)=MINT(84)+2+ISET(ISUB)
17062 IREF(1,4)=MINT(83)+5+ISET(ISUB)
17063 IREF(1,5)=MINT(83)+6+ISET(ISUB)
17065 ELSEIF(ISET(ISUB).EQ.5) THEN
17066 IREF(1,1)=MINT(84)+3
17067 IREF(1,2)=MINT(84)+4
17068 IREF(1,3)=MINT(84)+5
17069 IREF(1,4)=MINT(83)+7
17070 IREF(1,5)=MINT(83)+8
17071 IREF(1,6)=MINT(83)+9
17075 C...Define original resonance for odd cases.
17078 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
17080 IF(IHDEC.EQ.1) ISUB=3
17082 IREF(1,4)=K(IRES,3)
17084 IF(IREF(1,4).GT.MINT(84)) THEN
17085 110 ITMPMO=IREF(1,4)
17086 IF(K(ITMPMO,2).EQ.94) THEN
17087 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
17088 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
17089 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
17091 C...Explicitly check that reference particle exists, otherwise stop recursion
17092 IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
17093 IREF(1,4)=K(ITMPMO,3)
17098 IF(IREF(1,4).GT.MINT(84)) THEN
17101 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
17102 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
17105 EMATCH=ABS(P(II,4)-P(IREF14,4))
17112 C...Check if initial resonance has been moved (in resonance + jet).
17114 IF(IREF(1,JT).GT.0) THEN
17115 IF(K(IREF(1,JT),1).GT.10) THEN
17116 KFA=IABS(K(IREF(1,JT),2))
17117 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
17118 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17119 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17120 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17121 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17123 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17124 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17126 DO 130 I=IREF(1,JT)+1,N
17127 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
17130 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17131 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17132 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17133 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17135 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17136 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17141 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
17142 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
17148 C...Set decay vertex for initial resonances
17151 V(IREF(1,JT),I)=0D0
17155 C...Loop over decay history.
17161 IF(IREF(IP,2).EQ.0) JTMAX=1
17162 IF(IREF(IP,3).NE.0) JTMAX=3
17166 C...Check for Higgs which appears as decay product of user-process.
17169 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17171 IF(IHDEC.EQ.1) ISUB=3
17174 C...Start treatment of one, two or three resonances in parallel.
17186 C...Check whether particle can/is allowed to decay.
17187 IF(ID.EQ.0) GOTO 330
17190 IF(MWID(KCA).EQ.0) GOTO 330
17191 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
17192 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
17193 & KFA.EQ.18) IT4=IT4+1
17194 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
17195 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
17197 C...Choose lifetime and determine decay vertex.
17198 IF(K(ID,1).EQ.5) THEN
17200 ELSEIF(K(ID,1).NE.4) THEN
17201 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
17204 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
17207 C...Determine whether decay allowed or not.
17209 IF(MSTJ(22).EQ.2) THEN
17210 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
17211 ELSEIF(MSTJ(22).EQ.3) THEN
17212 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
17213 ELSEIF(MSTJ(22).EQ.4) THEN
17214 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
17215 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
17217 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
17222 C...Info for selection of decay channel: sign, pairings.
17223 IF(KCHG(KCA,3).EQ.0) THEN
17226 IPM=(5-ISIGN(1,K(ID,2)))/2
17229 IF(JTMAX.EQ.2) THEN
17230 KFB=IABS(K(IREF(IP,3-JT),2))
17231 ELSEIF(JTMAX.EQ.3) THEN
17233 KFB=IABS(K(IREF(IP,JT2),2))
17234 IF(KFB.NE.KFA) THEN
17235 JT2=JT+2-3*((JT+1)/3)
17236 KFB=IABS(K(IREF(IP,JT2),2))
17240 C...Select decay channel.
17241 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
17242 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
17243 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
17244 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
17245 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
17246 IF(WDTE0S.LE.0D0) GOTO 330
17250 IDC=IDL+MDCY(KCA,2)-1
17251 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
17252 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
17253 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
17255 C...Read out flavours and colour charges of decay channel chosen.
17256 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
17257 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
17258 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
17259 KFC1A=PYCOMP(IABS(KFL1(JT)))
17260 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
17261 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
17262 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
17263 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
17264 KFC2A=PYCOMP(IABS(KFL2(JT)))
17265 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
17266 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
17267 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
17268 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
17270 IF(KFL3(JT).NE.0) THEN
17271 KFC3A=PYCOMP(IABS(KFL3(JT)))
17272 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
17273 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
17274 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
17277 C...Set/save further info on channel.
17279 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
17281 HGZ(JT,1)=VINT(111)
17282 HGZ(JT,2)=VINT(112)
17283 HGZ(JT,3)=VINT(114)
17286 C...Select masses; to begin with assume resonances narrow.
17291 KFLW=IABS(KFL1(JT))
17293 ELSEIF(I.EQ.2) THEN
17294 KFLW=IABS(KFL2(JT))
17296 ELSEIF(I.EQ.3) THEN
17297 IF(KFL3(JT).EQ.0) GOTO 220
17298 KFLW=IABS(KFL3(JT))
17301 P(N+I,5)=PMAS(KCW,1)
17303 C...This prevents SUSY/t particles from becoming too light.
17304 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
17305 PMMN(I)=PMAS(KCW,1)
17306 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
17307 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
17308 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
17309 & PMAS(PYCOMP(KFDP(IDC,2)),1)
17310 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
17311 & PMAS(PYCOMP(KFDP(IDC,3)),1)
17312 PMMN(I)=MIN(PMMN(I),PMSUM)
17316 ELSEIF(KFLW.EQ.6) THEN
17317 PMMN(I)=PMAS(24,1)+PMAS(5,1)
17319 C...UED: select a graviton mass from continuous distribution
17320 C...(stored in PMAS(39,1) so no value returned)
17321 IF (IUED(1).EQ.1.AND.IUED(2).EQ.1.AND.KFLW.EQ.39)
17325 C...Check which two out of three are widest.
17328 PWID1=PMAS(KFC1A,2)
17329 PWID2=PMAS(KFC2A,2)
17330 KFLW1=IABS(KFL1(JT))
17331 KFLW2=IABS(KFL2(JT))
17332 IF(KFL3(JT).NE.0) THEN
17333 PWID3=PMAS(KFC3A,2)
17334 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
17337 KFLW1=IABS(KFL3(JT))
17338 ELSEIF(PWID3.GT.PWID2) THEN
17341 KFLW2=IABS(KFL3(JT))
17345 C...If all narrow then only check that masses consistent.
17346 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
17347 & PWID2.LT.PARP(41))) THEN
17349 C....Handle near degeneracy cases.
17350 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
17351 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17352 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
17353 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
17357 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17358 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
17361 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
17362 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
17367 C...For three wide resonances select narrower of three
17368 C...according to BW decoupled from rest.
17371 IF(KFL3(JT).NE.0) THEN
17372 IWID3=6-IWID1-IWID2
17373 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
17377 P(N+IWID3,5)=PYMASS(KFLW3)
17378 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
17379 PMTOT=PMTOT-P(N+IWID3,5)
17381 C...Select other two correlated within remaining phase space.
17385 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
17386 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
17387 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17392 CKIN(49)=PMMN(IWID1)
17393 CKIN(50)=PMMN(IWID2)
17394 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17399 IF(MINT(51).EQ.1) GOTO 720
17402 C...Begin fill decay products, with colour flow for coloured objects.
17407 C...Three-body decays
17408 IF(KFL3(JT).NE.0) THEN
17425 C...Generate kinematics (default is flat)
17428 C...Set generic colour flows whenever unambiguous,
17429 C...(independently of the order of the decay products)
17430 C...Sum up total colour content
17439 IF (KCQ(J).EQ.-1) THEN
17442 ELSEIF (KCQ(J).EQ.1) THEN
17445 ELSEIF (KCQ(J).EQ.2) THEN
17451 C...Set color flow for generic 1 -> N processes (N arbitrary)
17452 IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
17453 C...All singlets: do nothing
17455 ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
17456 C...Two octets, zero triplets, n singlets:
17457 IF (KCQ(0).EQ.2) THEN
17459 K(ID,4)=K(ID,4)+IOCT(2)
17460 K(ID,5)=K(ID,5)+IOCT(2)
17462 K(IOCT(2),4)=MSTU(5)*ID
17463 K(IOCT(2),5)=MSTU(5)*ID
17464 MCT(IOCT(2),1)=MCT(ID,1)
17465 MCT(IOCT(2),2)=MCT(ID,2)
17467 C...1 -> 8 + 8 + n(1)
17469 K(IOCT(1),4)=MSTU(5)*IOCT(2)
17470 K(IOCT(1),5)=MSTU(5)*IOCT(2)
17472 K(IOCT(2),4)=MSTU(5)*IOCT(1)
17473 K(IOCT(2),5)=MSTU(5)*IOCT(1)
17482 ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
17483 C...Two triplets, zero octets, n singlets.
17484 IF (KCQ(0).EQ.1) THEN
17486 K(ID,4)=K(ID,4)+ITRI(2)
17488 K(ITRI(2),4)=MSTU(5)*ID
17489 MCT(ITRI(2),1)=MCT(ID,1)
17490 ELSEIF (KCQ(0).EQ.-1) THEN
17491 C...3bar -> 3bar + n(1)
17492 K(ID,5)=K(ID,5)+IANT(2)
17494 K(IANT(2),5)=MSTU(5)*ID
17495 MCT(IANT(2),2)=MCT(ID,2)
17497 C...1 -> 3 + 3bar + n(1)
17499 K(ITRI(1),4)=MSTU(5)*IANT(1)
17501 K(IANT(1),5)=MSTU(5)*ITRI(1)
17507 ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
17508 C...Two triplets, one octet, n singlets.
17509 IF (KCQ(0).EQ.2) THEN
17510 C...8 -> 3 + 3bar + n(1)
17511 K(ID,4)=K(ID,4)+ITRI(1)
17512 K(ID,5)=K(ID,5)+IANT(1)
17514 K(ITRI(1),4)=MSTU(5)*ID
17516 K(IANT(1),5)=MSTU(5)*ID
17517 MCT(ITRI(1),1)=MCT(ID,1)
17518 MCT(IANT(1),2)=MCT(ID,2)
17519 ELSEIF (KCQ(0).EQ.1) THEN
17520 C...3 -> 8 + 3 + n(1)
17521 K(ID,4)=K(ID,4)+IOCT(1)
17523 K(IOCT(1),4)=MSTU(5)*ID
17524 K(IOCT(1),5)=MSTU(5)*ITRI(2)
17526 K(ITRI(2),4)=MSTU(5)*IOCT(1)
17527 MCT(IOCT(1),1)=MCT(ID,1)
17531 ELSEIF (KCQ(0).EQ.-1) THEN
17532 C...3bar -> 8 + 3bar + n(1)
17533 K(ID,5)=K(ID,5)+IOCT(1)
17535 K(IOCT(1),5)=MSTU(5)*ID
17536 K(IOCT(1),4)=MSTU(5)*IANT(2)
17538 K(IANT(2),5)=MSTU(5)*IOCT(1)
17539 MCT(IOCT(1),2)=MCT(ID,2)
17544 C...1 -> 3 + 3bar + 8 + n(1)
17546 K(ITRI(1),4)=MSTU(5)*IOCT(1)
17548 K(IOCT(1),5)=MSTU(5)*ITRI(1)
17549 K(IOCT(1),4)=MSTU(5)*IANT(1)
17551 K(IANT(1),5)=MSTU(5)*IOCT(1)
17559 CPS-- End of generic cases
17560 C...(could three octets also be handled?)
17561 C...(could (some of) the RPV cases be made generic as well?)
17563 C...Special cases (= old treatment)
17564 C...Set colour flow for t -> W + b + Z.
17565 ELSEIF(KFA.EQ.6) THEN
17568 IF(KCQM(JT).EQ.-1) ISID=5
17570 K(ID,ISID)=K(ID,ISID)+IDAU
17571 K(IDAU,ISID)=MSTU(5)*ID
17573 C...Set colour flow in three-body decays - programmed as special cases.
17575 ELSEIF(KFC2A.LE.6) THEN
17579 IF(KFL2(JT).LT.0) ISID=5
17580 K(N+2,ISID)=MSTU(5)*(N+3)
17581 K(N+3,9-ISID)=MSTU(5)*(N+2)
17582 C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
17583 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
17584 & .AND.KFL3(JT).NE.0) THEN
17585 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
17586 C...3-body decays of squarks to colour singlets plus one quark
17587 IF (KQSUMA.EQ.1) THEN
17590 IF (KCQ1(JT).NE.0) IQ=1
17591 IF (KCQ2(JT).NE.0) IQ=2
17592 IF (KCQ3(JT).NE.0) IQ=3
17594 IF (K(N+IQ,2).LT.0) ISID=5
17596 K(ID,ISID)=K(ID,ISID)+(N+IQ)
17597 K(N+IQ,ISID)=MSTU(5)*ID
17600 ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
17605 IF(KFL2(JT).LT.0) ISID=5
17606 K(N+1,ISID)=MSTU(5)*(N+2)
17607 K(N+1,9-ISID)=MSTU(5)*(N+3)
17608 K(N+2,ISID)=MSTU(5)*(N+1)
17609 K(N+3,9-ISID)=MSTU(5)*(N+1)
17610 ELSEIF(KFA.EQ.KSUSY1+21) THEN
17614 IF(KFL2(JT).LT.0) ISID=5
17615 K(ID,ISID)=K(ID,ISID)+(N+2)
17616 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
17617 K(N+2,ISID)=MSTU(5)*ID
17618 K(N+3,9-ISID)=MSTU(5)*ID
17621 ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
17622 & IABS(KCQ2(JT)).EQ.1) THEN
17626 IF(KFL2(JT).LT.0) ISID=5
17627 K(N+2,ISID)=MSTU(5)*(N+3)
17628 K(N+3,9-ISID)=MSTU(5)*(N+2)
17633 C...Set colour flow in three-body decays with baryon number violation.
17634 C...Neutralino and chargino decays first.
17635 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
17636 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
17637 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
17638 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17639 C...Insert junction to keep track of colours.
17640 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17641 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17642 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17643 C...Set special junction codes:
17647 C...Order decay products by invariant mass. (will be used in PYSTRF).
17648 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)-
17649 & P(N+1,3)*P(N+2,3)
17650 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)-
17651 & P(N+1,3)*P(N+3,3)
17652 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)-
17653 & P(N+2,3)*P(N+3,3)
17654 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
17655 K(N+4,4)=N+3+K(N+4,4)
17656 K(N+4,5)=N+1+MSTU(5)*(N+2)
17657 ELSEIF(PM13.LT.PM23) THEN
17658 K(N+4,4)=N+2+K(N+4,4)
17659 K(N+4,5)=N+1+MSTU(5)*(N+3)
17661 K(N+4,4)=N+1+K(N+4,4)
17662 K(N+4,5)=N+2+MSTU(5)*(N+3)
17668 C...Connect daughters to junction.
17672 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
17674 C...Particle counter should be stepped up one extra for junction.
17678 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
17679 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
17680 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17681 C...Insert junction to keep track of colours.
17682 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17683 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17684 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17695 C...Start by connecting all daughters to junction.
17696 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
17697 C...Only consider colour topologies with off shell resonances.
17698 RMQ1=PMAS(PYCOMP(K(II,2)),1)
17699 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
17700 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
17701 IF (RMGLU-RMQ1.LT.RMRES) THEN
17702 C...Calculate propagators for each colour topology.
17703 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
17704 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
17705 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
17709 CTMSUM=CTMSUM+CTM2(II-N)
17711 CTMSUM=PYR(0)*CTMSUM
17712 C...Select colour topology J, with most off shell least likely.
17715 CTMSUM=CTMSUM-CTM2(J)
17716 IF (CTMSUM.GT.0D0) GOTO 300
17717 C...The lucky winner gets its colour (anti-colour) directly from gluino.
17718 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
17719 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
17720 C...The other gluino colour is connected to junction
17721 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
17723 K(N+4,4)=K(N+4,4)+ID
17724 C...Lastly, connect junction to remaining daughters.
17725 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
17726 C...Particle counter should be stepped up one extra for junction.
17730 C...Update particle counter.
17733 C...2) Everything else two-body decay.
17735 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
17740 C...First set colour flow as if mother colour singlet.
17741 IF(KCQ1(JT).NE.0) THEN
17743 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
17744 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
17746 IF(KCQ2(JT).NE.0) THEN
17748 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
17749 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
17751 C...Then redirect colour flow if mother (anti)triplet.
17752 IF(KCQM(JT).EQ.0) THEN
17753 ELSEIF(KCQM(JT).NE.2) THEN
17755 IF(KCQM(JT).EQ.-1) ISID=5
17757 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
17758 K(ID,ISID)=K(ID,ISID)+IDAU
17759 K(IDAU,ISID)=MSTU(5)*ID
17760 C...Then redirect colour flow if mother octet.
17761 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
17763 IF(KCQ1(JT).EQ.0) IDAU=N
17764 K(ID,4)=K(ID,4)+IDAU
17765 K(ID,5)=K(ID,5)+IDAU
17766 K(IDAU,4)=MSTU(5)*ID
17767 K(IDAU,5)=MSTU(5)*ID
17770 IF(KCQ1(JT).EQ.-1) ISID=5
17771 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
17772 K(ID,ISID)=K(ID,ISID)+(N-1)
17773 K(ID,9-ISID)=K(ID,9-ISID)+N
17774 K(N-1,ISID)=MSTU(5)*ID
17775 K(N,9-ISID)=MSTU(5)*ID
17778 C...Insert junction
17779 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
17781 C...~q* mother: type 3 junction. ~q mother: type 4.
17782 ITJUNC(JT)=(7+KCQM(JT))/2
17783 C...Specify junction KF and set colour flow from junction
17787 C...Junction type encoded together with mother:
17788 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
17789 K(N,5)=N-1+MSTU(5)*(N-2)
17790 C...Zero P and V for junction (V filled later)
17795 C...Set colour flow from mother to junction
17796 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
17797 C...Set colour flow from daughters to junction
17801 C...(Anti-)colour mother is junction.
17802 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
17807 C...End loop over resonances for daughter flavour and mass selection.
17809 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
17811 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
17812 & KFL1(JT).EQ.0) THEN
17813 WRITE(CODE,'(I9)') K(ID,2)
17814 WRITE(MASS,'(F9.3)') P(ID,5)
17815 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
17816 & CODE//' with mass'//MASS)
17822 C...Check for allowed combinations. Skip if no decays.
17823 IF(JTMAX.EQ.1) THEN
17824 IF(KDCY(1).EQ.0) GOTO 710
17825 ELSEIF(JTMAX.EQ.2) THEN
17826 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
17827 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17828 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17829 ELSEIF(JTMAX.EQ.3) THEN
17830 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
17831 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17832 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17833 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17834 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17835 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17836 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17839 C...Special case: matrix element option for Z0 decay to quarks.
17840 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
17841 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
17843 C...Check consistency of MSTJ options set.
17844 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
17846 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
17849 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
17851 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
17856 C...Select alpha_strong behaviour.
17859 MSTU(111)=MSTJ(108)
17860 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
17862 PARU(112)=PARJ(121)
17863 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
17865 C...Find axial fraction in total cross section for scalar gluon model.
17867 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
17868 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
17869 POLL=1D0-PARJ(131)*PARJ(132)
17870 SFF=1D0/(16D0*XW*XW1)
17871 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
17872 & (PARJ(123)*PARJ(124))**2)
17873 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
17875 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
17876 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
17877 & (PARJ(132)-PARJ(131)))
17880 QF=KCHG(KFLC,1)/3D0
17882 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
17883 & 1D0-(2D0*PMQ/P(ID,5))**2))
17884 VF=SIGN(1D0,QF)-4D0*QF*XW
17885 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
17886 & VF**2*HF1W)+VQ**3*HF1W
17887 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
17890 C...Choice of jet configuration.
17891 CALL PYXJET(P(ID,5),NJET,CUT)
17895 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
17896 ELSEIF(NJET.EQ.3) THEN
17897 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
17902 C...Fill jet configuration; return if incorrect kinematics.
17904 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
17905 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
17906 ELSEIF(NJET.EQ.2) THEN
17907 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
17908 ELSEIF(NJET.EQ.3) THEN
17909 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
17910 ELSEIF(KFLN.EQ.21) THEN
17911 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17914 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17917 IF(MSTU(24).NE.0) THEN
17924 C...Angular orientation according to matrix element.
17925 IF(MSTJ(106).EQ.1) THEN
17926 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
17927 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
17929 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
17930 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
17933 C...Boost partons to Z0 rest frame.
17934 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
17935 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17937 C...Mark decayed resonance and add documentation lines,
17939 IDOC=MINT(83)+MINT(4)
17941 I1=MINT(83)+MINT(4)+1
17943 IF(MSTP(128).GE.1) K(I,3)=ID
17944 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
17955 C...Generate parton shower.
17956 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
17957 CALL PYSHOW(N-1,N,P(ID,5))
17958 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
17962 PTPART(1)=0.5D0*P(ID,5)
17963 PTPART(2)=PTPART(1)
17965 IF(K(N-1,2).GT.0) THEN
17972 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
17975 C... End special case for Z0: skip ahead.
17981 C...Order incoming partons and outgoing resonances.
17982 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
17985 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
17986 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
17987 & ILIN(1)=2*MINT(84)+3-ILIN(1)
17988 ILIN(2)=2*MINT(84)+3-ILIN(1)
17990 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17994 IF(K(IREF(IP,1),2).EQ.23) IORD=2
17995 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
17996 IAKIPD=IABS(K(IREF(IP,IORD),2))
17997 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
17998 IF(KDCY(IORD).EQ.0) IORD=3-IORD
18000 C...Order decay products of resonances.
18001 DO 370 JT=IORD,3-IORD,3-2*IORD
18002 IF(KDCY(JT).EQ.0) THEN
18003 ILIN(IMAX+1)=NSD(JT)
18005 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
18006 ILIN(IMAX+1)=N+2*JT-1
18007 ILIN(IMAX+2)=N+2*JT
18009 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18010 K(N+2*JT,2)=K(NSD(JT)+2,2)
18012 ILIN(IMAX+1)=N+2*JT
18014 ILIN(IMAX+2)=N+2*JT-1
18016 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18017 K(N+2*JT,2)=K(NSD(JT)+2,2)
18021 C...Find charge, isospin, left- and righthanded couplings.
18026 KFA=IABS(K(ILIN(I),2))
18027 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
18028 COUP(I,1)=KCHG(KFA,1)/3D0
18029 COUP(I,2)=(-1)**MOD(KFA,2)
18030 COUP(I,4)=-2D0*COUP(I,1)*XWV
18031 COUP(I,3)=COUP(I,2)+COUP(I,4)
18034 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
18035 IF(ISUB.EQ.22) THEN
18038 IF(I.EQ.5) I1=3-IORD
18041 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
18042 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
18043 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
18048 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18049 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
18050 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
18051 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
18053 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
18057 C...Select angular orientation type - Z'/W' only.
18059 IF(ISUB.EQ.141) THEN
18060 IF(PYR(0).LT.PARU(130)) MZPWP=1
18062 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
18063 IAKIR=IABS(K(IREF(2,2),2))
18064 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18065 IF(IAKIR.LE.20) MZPWP=2
18067 IF(IP.GE.3) MZPWP=2
18068 ELSEIF(ISUB.EQ.142) THEN
18069 IF(PYR(0).LT.PARU(136)) MZPWP=1
18071 IAKIR=IABS(K(IREF(2,2),2))
18072 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18073 IF(IAKIR.LE.20) MZPWP=2
18075 IF(IP.GE.3) MZPWP=2
18078 C...Select random angles (begin of weighting procedure).
18079 430 DO 440 JT=1,JTMAX
18080 IF(KDCY(JT).EQ.0) GOTO 440
18081 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
18082 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
18083 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
18086 CTHE(JT)=2D0*PYR(0)-1D0
18087 PHI(JT)=PARU(2)*PYR(0)
18091 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
18092 C...Construct massless four-vectors.
18101 IF(KDCY(JT).EQ.0) GOTO 470
18103 P(N+2*JT-1,3)=0.5D0*P(ID,5)
18104 P(N+2*JT-1,4)=0.5D0*P(ID,5)
18105 P(N+2*JT,3)=-0.5D0*P(ID,5)
18106 P(N+2*JT,4)=0.5D0*P(ID,5)
18107 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
18108 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
18111 C...Store incoming and outgoing momenta, with random rotation to
18112 C...avoid accidental zeroes in HA expressions.
18116 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
18117 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
18118 P(N+4+I,5)=P(ILIN(I),5)
18120 P(N+4+I,J)=P(ILIN(I),J)
18123 500 THERR=ACOS(2D0*PYR(0)-1D0)
18124 PHIRR=PARU(2)*PYR(0)
18125 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
18127 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
18128 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
18135 C...Calculate internal products.
18136 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
18137 & ISUB.EQ.142) THEN
18138 DO 540 I1=IMIN,IMAX-1
18139 DO 530 I2=I1+1,IMAX
18140 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
18141 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
18142 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
18143 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
18144 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
18145 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
18146 HC(I1,I2)=CONJG(HA(I1,I2))
18147 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
18148 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
18149 HA(I2,I1)=-HA(I1,I2)
18150 HC(I2,I1)=-HC(I1,I2)
18155 C...Calculate four-products.
18162 DO 580 I1=IMIN,IMAX-1
18163 DO 570 I2=I1+1,IMAX
18164 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
18165 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
18166 PKK(I2,I1)=PKK(I1,I2)
18172 KFAGM=IABS(IREF(IP,7))
18173 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
18174 C...Isotropic decay selected by user.
18178 ELSEIF(JTMAX.EQ.3) THEN
18179 C...Isotropic decay when three mother particles.
18183 ELSEIF(IT4.GE.1) THEN
18184 C... Isotropic decay t -> b + W etc for 4th generation q and l.
18188 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
18189 & IREF(IP,7).EQ.36) THEN
18190 C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
18191 C...CP-odd case added by Kari Ertresvag Myklevoll.
18192 C...Now also with mixed Higgs CP-states
18194 IF(IP.EQ.1) WTMAX=SH**2
18195 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
18196 KFA=IABS(K(IREF(IP,1),2))
18197 KFT=IABS(K(IREF(IP,2),2))
18199 IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
18200 & MSTP(25).GE.3) THEN
18201 C...For mixed CP states need epsilon product.
18218 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
18219 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
18220 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
18221 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
18222 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
18223 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
18224 & P22*P30*P41+P13*P22*P31*P40
18225 C...For mixed CP states need gauge boson masses.
18226 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
18227 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
18228 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
18229 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
18234 IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
18235 KFLF1A=IABS(KFL1(1))
18236 EF1=KCHG(KFLF1A,1)/3D0
18237 AF1=SIGN(1D0,EF1+0.1D0)
18238 VF1=AF1-4D0*EF1*XWV
18239 KFLF2A=IABS(KFL1(2))
18240 EF2=KCHG(KFLF2A,1)/3D0
18241 AF2=SIGN(1D0,EF2+0.1D0)
18242 VF2=AF2-4D0*EF2*XWV
18243 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
18244 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18247 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
18248 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
18249 ELSEIF(MSTP(25).LE.2) THEN
18251 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18252 & -2*PKK(3,4)*PKK(5,6)
18253 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18254 & (PKK(3,4)*PKK(5,6))
18255 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18256 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
18258 C...Mixed CP states.
18259 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
18260 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
18261 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
18262 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
18263 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18264 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18265 & +PKK(3,4)*PKK(5,6)
18266 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18267 & +VA12AS*PKK(3,4)*PKK(5,6)
18268 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18269 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18270 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18271 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
18275 ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
18276 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18279 WT=16D0*PKK(3,5)*PKK(4,6)
18280 ELSEIF(MSTP(25).LE.2) THEN
18282 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18283 & -2*PKK(3,4)*PKK(5,6)
18284 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18285 & (PKK(3,4)*PKK(5,6))
18286 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18287 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
18289 C...Mixed CP states.
18290 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
18291 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
18292 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18293 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18294 & +PKK(3,4)*PKK(5,6)
18295 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18296 & +PKK(3,4)*PKK(5,6)
18297 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18298 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18299 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18300 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
18303 C...No angular correlations in other Higgs decays.
18308 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
18309 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
18311 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
18313 IF(MOD(KFAGM,2).EQ.0) THEN
18321 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
18322 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
18323 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
18324 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
18326 ELSEIF(ISUB.EQ.1) THEN
18327 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
18328 EI=KCHG(IABS(MINT(15)),1)/3D0
18329 AI=SIGN(1D0,EI+0.1D0)
18331 EF=KCHG(IABS(KFL1(1)),1)/3D0
18332 AF=SIGN(1D0,EF+0.1D0)
18335 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
18336 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18337 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
18338 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18339 & (VI**2+AI**2)*VINT(114)*VF**2)
18340 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
18341 & 4D0*VI*AI*VINT(114)*VF*AF)
18342 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18343 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18344 WTMAX=2D0*(WT1+ABS(WT3))
18346 ELSEIF(ISUB.EQ.2) THEN
18347 C...Angular weight for W+/- -> 2 quarks/leptons.
18348 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
18349 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
18350 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18351 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18354 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
18355 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
18356 C...-> gluon/gamma + 2 quarks/leptons.
18357 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18358 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18359 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18360 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18361 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18362 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18363 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18364 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18365 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18366 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18367 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18368 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18369 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
18370 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
18371 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18372 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
18374 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
18375 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
18376 C...-> gluon/gamma + 2 quarks/leptons.
18377 WT=PKK(1,3)**2+PKK(2,4)**2
18378 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
18380 ELSEIF(ISUB.EQ.22) THEN
18381 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
18382 S34=P(IREF(IP,IORD),5)**2
18383 S56=P(IREF(IP,3-IORD),5)**2
18384 TI=PKK(1,3)+PKK(1,4)+S34
18385 UI=PKK(1,5)+PKK(1,6)+S56
18388 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
18389 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
18390 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
18391 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
18392 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
18393 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
18394 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
18395 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
18398 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
18399 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
18400 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
18401 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
18402 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18403 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
18404 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
18407 ELSEIF(ISUB.EQ.23) THEN
18408 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
18409 D34=P(IREF(IP,IORD),5)**2
18410 D56=P(IREF(IP,3-IORD),5)**2
18411 DT=PKK(1,3)+PKK(1,4)+D34
18412 DU=PKK(1,5)+PKK(1,6)+D56
18413 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
18414 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18415 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18416 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
18418 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
18419 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
18420 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
18421 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18422 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
18423 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
18425 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
18426 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
18427 C...(or H0, or A0).
18428 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
18429 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
18430 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
18431 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
18432 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18434 ELSEIF(ISUB.EQ.25) THEN
18435 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
18436 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
18437 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
18438 D34=P(IREF(IP,IORD),5)**2
18439 D56=P(IREF(IP,3-IORD),5)**2
18440 DT=PKK(1,3)+PKK(1,4)+D34
18441 DU=PKK(1,5)+PKK(1,6)+D56
18442 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
18443 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
18444 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
18445 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
18446 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
18447 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
18448 & REAL(CBWW)*FGK(1,2,5,6,3,4))
18449 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18450 IF(MSTP(50).LE.0) THEN
18451 WT=FGK135**2+(CCWW*FGK253)**2
18452 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
18453 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
18456 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
18457 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
18458 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
18459 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
18462 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
18463 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
18464 C...(or H0, or A0).
18465 WT=PKK(1,3)*PKK(2,4)
18466 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18468 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
18469 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
18470 C...-> f + 2 quarks/leptons.
18471 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18472 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18473 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18474 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18475 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18476 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18477 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18478 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18479 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18480 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18481 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18482 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18483 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
18484 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
18485 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
18486 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
18487 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18488 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
18490 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
18491 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
18492 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
18493 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
18494 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
18496 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
18498 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
18499 WT=16D0*PKK(3,5)*PKK(4,6)
18502 ELSEIF(ISUB.EQ.110) THEN
18503 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
18507 ELSEIF(ISUB.EQ.141) THEN
18508 C...Special case: if only branching ratios known then isotropic decay.
18509 IF(MWID(32).EQ.2) THEN
18512 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18513 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
18514 C...Couplings of incoming flavour.
18515 KFAI=IABS(MINT(15))
18516 EI=KCHG(KFAI,1)/3D0
18517 AI=SIGN(1D0,EI+0.1D0)
18520 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
18521 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
18522 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
18523 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
18524 VPI=PARU(119+2*KFAIC)
18525 API=PARU(120+2*KFAIC)
18526 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
18527 VPI=PARJ(178+2*KFAIC)
18528 API=PARJ(179+2*KFAIC)
18530 VPI=PARJ(186+2*KFAIC)
18531 API=PARJ(187+2*KFAIC)
18533 C...Couplings of final flavour.
18535 EF=KCHG(KFAF,1)/3D0
18536 AF=SIGN(1D0,EF+0.1D0)
18539 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
18540 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
18541 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
18542 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
18543 VPF=PARU(119+2*KFAFC)
18544 APF=PARU(120+2*KFAFC)
18545 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
18546 VPF=PARJ(178+2*KFAFC)
18547 APF=PARJ(179+2*KFAFC)
18549 VPF=PARJ(186+2*KFAFC)
18550 APF=PARJ(187+2*KFAFC)
18552 C...Asymmetry and weight.
18553 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
18554 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
18555 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
18556 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18557 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
18558 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
18559 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
18560 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18561 WTMAX=2D0+ABS(ASYM)
18562 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
18563 C...Angular weight for f + fbar -> Z' -> W+ + W-.
18564 RM1=P(NSD(1)+1,5)**2/SH
18565 RM2=P(NSD(1)+2,5)**2/SH
18566 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18567 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18568 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18570 WT=CFLAT+CCOS2*CTHE(1)**2
18571 WTMAX=CFLAT+MAX(0D0,CCOS2)
18572 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
18573 & IABS(KFL1(1)).EQ.37)) THEN
18574 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
18577 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18578 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
18579 RM1=P(NSD(1)+1,5)**2/SH
18580 RM2=P(NSD(1)+2,5)**2/SH
18581 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18582 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18583 WTMAX=1D0+FLAM2/(8D0*RM1)
18584 ELSEIF(MZPWP.EQ.0) THEN
18585 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18586 C...(W:s like if intermediate Z).
18587 D34=P(IREF(IP,IORD),5)**2
18588 D56=P(IREF(IP,3-IORD),5)**2
18589 DT=PKK(1,3)+PKK(1,4)+D34
18590 DU=PKK(1,5)+PKK(1,6)+D56
18591 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18592 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18593 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
18594 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
18595 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18596 ELSEIF(MZPWP.EQ.1) THEN
18597 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18598 C...(W:s approximately longitudinal, like if intermediate H).
18599 WT=16D0*PKK(3,5)*PKK(4,6)
18602 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
18603 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
18608 ELSEIF(ISUB.EQ.142) THEN
18609 C...Special case: if only branching ratios known then isotropic decay.
18610 IF(MWID(34).EQ.2) THEN
18613 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18614 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
18615 KFAI=IABS(MINT(15))
18617 IF(KFAI.GT.10) KFAIC=2
18618 VI=PARU(129+2*KFAIC)
18619 AI=PARU(130+2*KFAIC)
18622 IF(KFAF.GT.10) KFAFC=2
18623 VF=PARU(129+2*KFAFC)
18624 AF=PARU(130+2*KFAFC)
18625 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
18626 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18627 WTMAX=2D0+ABS(ASYM)
18628 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
18629 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
18630 RM1=P(NSD(1)+1,5)**2/SH
18631 RM2=P(NSD(1)+2,5)**2/SH
18632 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18633 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18634 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18636 WT=CFLAT+CCOS2*CTHE(1)**2
18637 WTMAX=CFLAT+MAX(0D0,CCOS2)
18638 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18639 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
18640 RM1=P(NSD(1)+1,5)**2/SH
18641 RM2=P(NSD(1)+2,5)**2/SH
18642 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18643 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18644 WTMAX=1D0+FLAM2/(8D0*RM1)
18645 ELSEIF(MZPWP.EQ.0) THEN
18646 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18647 C...(W/Z like if intermediate W).
18648 D34=P(IREF(IP,IORD),5)**2
18649 D56=P(IREF(IP,3-IORD),5)**2
18650 DT=PKK(1,3)+PKK(1,4)+D34
18651 DU=PKK(1,5)+PKK(1,6)+D56
18652 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18653 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
18654 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18655 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
18656 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18657 ELSEIF(MZPWP.EQ.1) THEN
18658 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18659 C...(W/Z approximately longitudinal, like if intermediate H).
18660 WT=16D0*PKK(3,5)*PKK(4,6)
18663 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
18664 C...t + bbar -> t + W + bbar.
18669 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
18671 C...Isotropic decay of leptoquarks (assumed spin 0).
18675 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
18676 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
18678 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
18679 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
18680 WT=1D0+SIDE*CTHE(1)
18682 ELSEIF(IP.EQ.1) THEN
18684 RM1=P(NSD(1)+1,5)**2/SH
18685 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18686 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18688 C...W/Z decay assumed isotropic, since not known.
18693 ELSEIF(ISUB.EQ.149) THEN
18694 C...Isotropic decay of techni-eta.
18698 ELSEIF(ISUB.EQ.191) THEN
18699 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18700 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
18701 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
18704 ELSEIF(IP.EQ.1) THEN
18705 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
18706 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18707 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
18708 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18709 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18710 KFAI=IABS(MINT(15))
18711 EI=KCHG(KFAI,1)/3D0
18712 AI=SIGN(1D0,EI+0.1D0)
18716 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
18717 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
18719 EF=KCHG(KFAF,1)/3D0
18720 AF=SIGN(1D0,EF+0.1D0)
18724 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
18725 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
18726 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
18727 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
18728 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
18729 WTMAX=4D0*MAX(ASAME,AFLIP)
18731 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
18736 ELSEIF(ISUB.EQ.192) THEN
18737 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18738 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
18739 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
18742 ELSEIF(IP.EQ.1) THEN
18743 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
18744 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18748 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
18753 ELSEIF(ISUB.EQ.193) THEN
18754 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18755 C...Angular weight for f + fbar -> omega_tc0 ->
18756 C...gamma pi_tc0 or Z0 pi_tc0.
18759 ELSEIF(IP.EQ.1) THEN
18760 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
18761 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18762 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18763 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18764 KFAI=IABS(MINT(15))
18765 EI=KCHG(KFAI,1)/3D0
18766 AI=SIGN(1D0,EI+0.1D0)
18770 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
18771 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
18773 EF=KCHG(KFAF,1)/3D0
18774 AF=SIGN(1D0,EF+0.1D0)
18778 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
18779 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
18780 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
18781 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
18782 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
18783 WTMAX=4D0*MAX(BSAME,BFLIP)
18785 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
18790 ELSEIF(ISUB.EQ.353) THEN
18791 C...Angular weight for Z_R0 -> 2 quarks/leptons.
18792 EI=KCHG(IABS(MINT(15)),1)/3D0
18793 AI=SIGN(1D0,EI+0.1D0)
18795 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
18796 AF=SIGN(1D0,EF+0.1D0)
18798 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
18799 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
18800 WT2=RMF*(VI**2+AI**2)*VF**2
18801 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
18802 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18803 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18804 WTMAX=2D0*(WT1+ABS(WT3))
18806 ELSEIF(ISUB.EQ.354) THEN
18807 C...Angular weight for W_R+/- -> 2 quarks/leptons.
18808 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
18809 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
18810 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18811 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18814 ELSEIF(ISUB.EQ.391) THEN
18815 C...Angular weight for f + fbar -> G* -> f + fbar
18816 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18817 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
18819 C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
18820 C...implemented by M.-C. Lemaire
18821 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18822 & IABS(KFL1(1)).EQ.22)) THEN
18825 C...Other G* decays not yet implemented angular distributions.
18831 ELSEIF(ISUB.EQ.392) THEN
18832 C...Angular weight for g + g -> G* -> f + fbar
18833 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18836 C...Angular weight for g + g -> G* -> gamma +gamma or g + g
18837 C...implemented by M.-C. Lemaire
18838 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18839 & IABS(KFL1(1)).EQ.22)) THEN
18840 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
18842 C...Other G* decays not yet implemented angular distributions.
18848 C...Obtain correct angular distribution by rejection techniques.
18853 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
18855 C...Construct massive four-vectors using angles chosen.
18856 590 DO 690 JT=1,JTMAX
18857 IF(KDCY(JT).EQ.0) GOTO 690
18862 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
18864 IF(KFL3(JT).EQ.0) THEN
18865 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
18866 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18869 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
18870 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18875 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
18877 C...Fill in position of decay vertex.
18878 DO 630 I=NSD(JT)+1,N0
18887 C...Mark decayed resonances; trace history.
18891 IF(KCQM(JT).NE.0) THEN
18892 C...Do not kill colour flow through coloured resonance!
18896 C...If 3-body or 2-body with junction:
18897 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
18898 C...If 3-body with junction:
18899 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
18902 C...Add documentation lines.
18903 ISUBRG=MAX(1,MIN(500,MINT(1)))
18904 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
18905 IDOC=MINT(83)+MINT(4)
18908 IF(KFL3(JT).NE.0) IHI=IHI+1
18909 DO 650 I=NSD(JT)+1,IHI
18911 I1=MINT(83)+MINT(4)+1
18913 IF(MSTP(128).GE.1) K(I,3)=ID
18914 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18918 K(I1,3)=IREF(IP,JT+3)
18927 C...If 3-body or 2-body with junction:
18928 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
18929 C...If 3-body with junction:
18930 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
18933 C...Do showering of two or three objects.
18935 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
18936 IF(KFL3(JT).EQ.0) THEN
18937 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
18939 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
18942 c...For pT-ordered shower need set up first, especially colour tags.
18943 C...(Need to set up colour tags even if MSTP(71) = 0)
18944 ELSEIF(MINT(35).GE.2) THEN
18946 IF(KFL3(JT).NE.0) NPART=3
18950 PTPART(1)=0.5D0*P(ID,5)
18951 PTPART(2)=PTPART(1)
18952 PTPART(3)=PTPART(1)
18953 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
18954 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
18955 IF(MOTHER.LE.NSD(JT)) THEN
18956 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
18959 MCT(NSD(JT)+1,1)=NCT
18963 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
18964 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
18965 IF(MOTHER.LE.NSD(JT)) THEN
18966 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
18969 MCT(NSD(JT)+1,2)=NCT
18973 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
18974 & KCQ2(JT).EQ.2)) THEN
18975 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
18976 IF(MOTHER.LE.NSD(JT)) THEN
18977 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
18980 MCT(NSD(JT)+2,1)=NCT
18984 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
18985 & KCQ2(JT).EQ.2)) THEN
18986 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
18987 IF(MOTHER.LE.NSD(JT)) THEN
18988 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18991 MCT(NSD(JT)+2,2)=NCT
18995 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
18996 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
18997 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
18998 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
19000 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
19001 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
19002 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
19003 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
19005 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
19008 IF(JT.EQ.1) NAFT1=N
19010 C...Check if decay products moved by shower.
19014 IF(NSHAFT.GT.NSHBEF) THEN
19015 IF(K(NSD1,1).GT.10) THEN
19016 DO 660 I=NSHBEF+1,NSHAFT
19017 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
19020 IF(K(NSD2,1).GT.10) THEN
19021 DO 670 I=NSHBEF+1,NSHAFT
19022 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
19023 & I.NE.NSD1) NSD2=I
19026 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
19027 DO 680 I=NSHBEF+1,NSHAFT
19028 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
19029 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
19034 C...Store decay products for further treatment.
19039 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
19043 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
19044 IREF(NP,7)=K(IREF(IP,JT),2)
19045 IREF(NP,8)=IREF(IP,JT)
19049 C...Fill information for 2 -> 1 -> 2.
19050 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
19051 MINT(7)=MINT(83)+6+2*ISET(ISUB)
19052 MINT(8)=MINT(83)+7+2*ISET(ISUB)
19058 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19059 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
19060 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
19061 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
19062 VINT(47)=SQRT(VINT(48))
19065 C...Possibility of colour rearrangement in W+W- events.
19066 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
19067 IAKF1=IABS(KFL1(1))
19068 IAKF2=IABS(KFL1(2))
19069 IAKF3=IABS(KFL2(1))
19070 IAKF4=IABS(KFL2(2))
19071 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
19072 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
19073 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
19074 IF(MINT(51).NE.0) RETURN
19077 C...Loop back if needed.
19078 710 IF(IP.LT.NP) GOTO 170
19080 C...Boost back to standard frame.
19081 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
19087 C*********************************************************************
19090 C...Initializes treatment of multiple interactions, selects kinematics
19091 C...of hardest interaction if low-pT physics included in run, and
19092 C...generates all non-hardest interactions.
19094 SUBROUTINE PYMULT(MMUL)
19096 C...Double precision and integer declarations.
19097 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19098 IMPLICIT INTEGER(I-N)
19099 INTEGER PYK,PYCHGE,PYCOMP
19101 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19102 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19103 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19104 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19105 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19106 COMMON/PYINT1/MINT(400),VINT(400)
19107 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19108 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19109 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19110 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19111 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
19112 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
19113 C...Local arrays and saved variables.
19114 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
19115 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19116 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19117 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19119 C...Initialization of multiple interaction treatment.
19121 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19129 C...Loop over phase space points: xT2 choice in 20 bins.
19132 NMUL(IXT2)=MSTP(83)
19134 DO 110 ITRY=1,MSTP(83)
19135 RSCA=0.05D0*((21-IXT2)-PYR(0))
19136 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19137 XT2=MAX(0.01D0*VINT(149),XT2)
19140 C...Choose tau and y*. Calculate cos(theta-hat).
19141 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19142 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19143 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19145 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19151 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19152 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19153 CALL PYKMAP(2,MYST,PYR(0))
19154 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19156 C...Calculate differential cross-section.
19157 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19158 CALL PYSIGH(NCHN,SIGS)
19159 SIGM(IXT2)=SIGM(IXT2)+SIGS
19161 SIGSUM=SIGSUM+SIGM(IXT2)
19163 SIGSUM=SIGSUM/(20D0*MSTP(83))
19165 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19166 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19167 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19168 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19169 PARP(82)=0.9D0*PARP(82)
19170 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19174 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19175 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19177 C...Start iteration to find k factor.
19178 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19179 P83A=(1D0-PARP(83))**2
19180 P83B=2D0*PARP(83)*(1D0-PARP(83))
19182 CQ2I=1D0/PARP(84)**2
19183 CQ2R=2D0/(1D0+PARP(84)**2)
19191 130 IF(IIT.EQ.0) THEN
19193 ELSEIF(IIT.EQ.1) THEN
19196 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19199 C...Evaluate overlap integrals. Find where to divide the b range.
19200 IF(MSTP(82).EQ.2) THEN
19201 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19204 IF(MSTP(82).EQ.3) THEN
19206 ELSEIF(MSTP(82).EQ.4) THEN
19207 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19209 POWIP=MAX(0.4D0,PARP(83))
19210 RPWIP=2D0/POWIP-1D0
19211 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19221 IF(MSTP(82).EQ.3) THEN
19222 OV=EXP(-B**2)/PARU(2)
19223 ELSEIF(MSTP(82).EQ.4) THEN
19224 OV=(P83A*EXP(-MIN(50D0,B**2))+
19225 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19226 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19228 OV=EXP(-B**POWIP)/PARU(2)
19229 SO=SO+PARU(2)*B*DELTAB*OV
19231 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19232 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19233 SP=SP+PARU(2)*B*DELTAB*PACC
19234 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19235 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19236 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19238 BDIV=B+0.5D0*DELTAB
19240 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19242 YK=PARU(1)*XK*SO/SP
19244 C...Continue iteration until convergence.
19254 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19256 C...Store some results for subsequent use.
19264 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19265 PIK=(VNT146/VNT147)*YKE
19267 C...Find relative weight for low and high impact parameter.
19268 PLOWB=PARU(1)*BDIV**2
19269 IF(MSTP(82).EQ.3) THEN
19270 PHIGHB=PIK*0.5*EXP(-BDIV**2)
19271 ELSEIF(MSTP(82).EQ.4) THEN
19272 S4A=P83A*EXP(-BDIV**2)
19273 S4B=P83B*EXP(-BDIV**2*CQ2R)
19274 S4C=P83C*EXP(-BDIV**2*CQ2I)
19275 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19276 ELSEIF(PARP(83).GE.1.999D0) THEN
19282 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
19286 C...Initialize iteration in xT2 for hardest interaction.
19287 ELSEIF(MMUL.EQ.2) THEN
19291 IF(MSTP(82).LE.0) THEN
19292 ELSEIF(MSTP(82).EQ.1) THEN
19294 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19295 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19296 & VINT(317)/(VINT(318)*VINT(320))
19297 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19298 ELSEIF(MSTP(82).EQ.2) THEN
19300 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19301 & VINT(149)*(1D0+VINT(149))
19303 XC2=4D0*CKIN(3)**2/VINT(2)
19304 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
19307 C...Select impact parameter for hardest interaction.
19308 IF(MSTP(82).LE.2) RETURN
19309 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
19310 C...Treatment in low b region.
19312 B=BDIV*SQRT(PYR(0))
19313 IF(MSTP(82).EQ.3) THEN
19314 OV=EXP(-B**2)/PARU(2)
19315 ELSEIF(MSTP(82).EQ.4) THEN
19316 OV=(P83A*EXP(-MIN(50D0,B**2))+
19317 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19318 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19320 OV=EXP(-B**POWIP)/PARU(2)
19322 VINT(148)=OV/VNT147
19323 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
19325 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19326 & VINT(149)*(1D0+VINT(149))
19328 C...Treatment in high b region.
19330 IF(MSTP(82).EQ.3) THEN
19331 B=SQRT(BDIV**2-LOG(PYR(0)))
19332 OV=EXP(-B**2)/PARU(2)
19333 ELSEIF(MSTP(82).EQ.4) THEN
19334 S4RNDM=PYR(0)*(S4A+S4B+S4C)
19335 IF(S4RNDM.LT.S4A) THEN
19336 B=SQRT(BDIV**2-LOG(PYR(0)))
19337 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
19338 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
19340 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
19342 OV=(P83A*EXP(-MIN(50D0,B**2))+
19343 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19344 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19345 ELSEIF(PARP(83).GE.1.999D0) THEN
19346 144 B2RPW=B2RPDV-LOG(PYR(0))
19347 ACCIP=(B2RPW/B2RPDV)**RPWIP
19348 IF(ACCIP.LT.PYR(0)) GOTO 144
19349 OV=EXP(-B2RPW)/PARU(2)
19350 B=B2RPW**(1D0/POWIP)
19352 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
19353 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
19354 IF(ACCIP.LT.PYR(0)) GOTO 146
19355 OV=EXP(-B2RPW)/PARU(2)
19356 B=B2RPW**(1D0/POWIP)
19358 VINT(148)=OV/VNT147
19359 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
19361 IF(PACC.LT.PYR(0)) GOTO 142
19364 ELSEIF(MMUL.EQ.3) THEN
19365 C...Low-pT or multiple interactions (first semihard interaction):
19366 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19367 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19372 IF(MSTP(82).LE.0) THEN
19374 ELSEIF(MSTP(82).EQ.1) THEN
19375 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19376 C...Use with "Sudakov" for low b values when impact parameter dependence.
19377 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
19378 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
19379 & VINT(149)))).GT.PYR(0)) XT2=1D0
19380 IF(XT2.GE.1D0) THEN
19381 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
19382 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
19385 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
19386 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
19389 XT2=MAX(0.01D0*VINT(149),XT2)
19390 C...Use without "Sudakov" for high b values when impact parameter dep.
19392 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
19393 & PYR(0)*(1D0-XC2))-VINT(149)
19394 XT2=MAX(0.01D0*VINT(149),XT2)
19398 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19399 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
19400 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
19401 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
19404 VINT(21)=0.01D0*VINT(149)
19407 VINT(25)=0.01D0*VINT(149)
19410 C...Multiple interactions (first semihard interaction).
19411 C...Choose tau and y*. Calculate cos(theta-hat).
19412 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19413 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19414 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19416 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19422 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19423 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19424 CALL PYKMAP(2,MYST,PYR(0))
19425 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19427 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
19429 C...Store results of cross-section calculation.
19430 ELSEIF(MMUL.EQ.4) THEN
19436 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
19437 IF(ISET(ISUB).EQ.2)
19438 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
19439 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
19440 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
19441 & (XTS+VINT(149))))
19442 IRBIN=INT(1D0+20D0*RBIN)
19443 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
19444 NMUL(IRBIN)=NMUL(IRBIN)+1
19445 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
19448 C...Choose impact parameter if not already done.
19449 ELSEIF(MMUL.EQ.5) THEN
19454 150 IF(MINT(39).GT.0) THEN
19455 ELSEIF(MSTP(82).EQ.3) THEN
19458 VINT(148)=EXPB2/(PARU(2)*VNT147)
19459 VINT(139)=SQRT(B2)/BAVG
19460 ELSEIF(MSTP(82).EQ.4) THEN
19462 IF(RTYPE.LT.P83A) THEN
19464 ELSEIF(RTYPE.LT.P83A+P83B) THEN
19465 B2=-LOG(PYR(0))/CQ2R
19467 B2=-LOG(PYR(0))/CQ2I
19469 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
19470 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
19471 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
19472 VINT(139)=SQRT(B2)/BAVG
19473 ELSEIF(PARP(83).GE.1.999D0) THEN
19474 POWIP=MAX(2D0,PARP(83))
19475 RPWIP=2D0/POWIP-1D0
19476 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
19477 160 IF(PYR(0).LT.PROB1) THEN
19478 B2RPW=PYR(0)**(0.5D0*POWIP)
19481 B2RPW=1D0-LOG(PYR(0))
19484 IF(ACCIP.LT.PYR(0)) GOTO 160
19485 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19486 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19488 POWIP=MAX(0.4D0,PARP(83))
19489 RPWIP=2D0/POWIP-1D0
19490 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
19491 170 IF(PYR(0).LT.PROB1) THEN
19492 B2RPW=2D0*RPWIP*PYR(0)
19493 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
19495 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
19496 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
19498 IF(ACCIP.LT .PYR(0)) GOTO 170
19499 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19500 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19503 C...Multiple interactions (variable impact parameter) : reject with
19504 C...probability exp(-overlap*cross-section above pT/normalization).
19505 C...Does not apply to low-b region, where "Sudakov" already included.
19507 IF(MINT(39).NE.1) THEN
19508 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
19509 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
19510 DO 180 IBIN=IRBIN+1,20
19511 RNCOR=RNCOR+NMUL(IBIN)
19512 SIGCOR=SIGCOR+SIGM(IBIN)
19514 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
19515 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
19516 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
19517 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
19519 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
19520 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
19521 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
19522 IF(VINT(150).LT.PYR(0)) GOTO 150
19526 C...Generate additional multiple semihard interactions.
19527 ELSEIF(MMUL.EQ.6) THEN
19540 C...Reconstruct strings in hard scattering.
19542 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
19543 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
19545 DO 210 I=MINT(84)+1,NMAX
19546 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
19547 IF(KCS.EQ.0) GOTO 210
19549 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
19550 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
19552 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
19554 IST=MOD(K(I,J+1),MSTU(5))
19556 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
19557 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
19559 IF(J.EQ.1.OR.J.EQ.4) THEN
19569 C...Set up starting values for iteration in xT2.
19570 XT2=4D0*VINT(62)/VINT(2)
19571 IF(MSTP(82).LE.1) THEN
19572 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19573 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19574 & VINT(317)/(VINT(318)*VINT(320))
19575 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19577 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
19578 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
19582 VINT(143)=1D0-VINT(141)
19583 VINT(144)=1D0-VINT(142)
19585 C...Iterate downwards in xT2.
19586 220 IF(MSTP(82).LE.1) THEN
19587 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19588 IF(XT2.LT.VINT(149)) GOTO 270
19590 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
19591 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
19592 & LOG(PYR(0)))-VINT(149)
19593 IF(XT2.LE.0D0) GOTO 270
19594 XT2=MAX(0.01D0*VINT(149),XT2)
19598 C...Choose tau and y*. Calculate cos(theta-hat).
19599 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19600 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19601 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19603 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19609 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19610 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19611 CALL PYKMAP(2,MYST,PYR(0))
19612 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19614 C...Check that x not used up. Accept or reject kinematical variables.
19615 X1M=SQRT(TAU)*EXP(VINT(22))
19616 X2M=SQRT(TAU)*EXP(-VINT(22))
19617 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
19618 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19619 CALL PYSIGH(NCHN,SIGS)
19620 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
19621 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
19623 C...Reset K, P and V vectors. Select some variables.
19632 PT=0.5D0*VINT(1)*SQRT(XT2)
19636 C...Add first parton to event record.
19639 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
19640 & 1+INT((2D0+PARJ(2))*PYR(0))
19641 P(N+1,1)=PT*COS(PHI)
19642 P(N+1,2)=PT*SIN(PHI)
19643 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
19644 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
19647 C...Add second parton to event record.
19650 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
19653 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
19654 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
19657 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
19658 C....Choose relevant string pieces to place gluons on.
19664 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
19665 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
19666 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
19667 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
19668 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
19676 C....Colour flow adjustments, new string pieces.
19677 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
19678 & MOD(K(IST1,4),MSTU(5))
19679 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
19680 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
19681 K(I,5)=MSTU(5)*IST1
19682 K(I,4)=MSTU(5)*IST2
19683 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
19684 & MOD(K(IST2,5),MSTU(5))
19685 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
19686 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
19689 KSTR(NSTR+1,2)=IST2
19693 C...String drawing and colour flow for gluon loop.
19694 ELSEIF(K(N+1,2).EQ.21) THEN
19695 K(N+1,4)=MSTU(5)*(N+2)
19696 K(N+1,5)=MSTU(5)*(N+2)
19697 K(N+2,4)=MSTU(5)*(N+1)
19698 K(N+2,5)=MSTU(5)*(N+1)
19705 C...String drawing and colour flow for qqbar pair.
19707 K(N+1,4)=MSTU(5)*(N+2)
19708 K(N+2,5)=MSTU(5)*(N+1)
19714 C...Global statistics.
19715 MINT(351)=MINT(351)+1
19716 VINT(351)=VINT(351)+PT
19717 IF (MINT(351).EQ.1) VINT(356)=PT
19719 C...Update remaining energy; iterate.
19721 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
19722 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
19726 MINT(31)=MINT(31)+1
19727 VINT(151)=VINT(151)+VINT(41)
19728 VINT(152)=VINT(152)+VINT(42)
19729 VINT(143)=VINT(143)-VINT(41)
19730 VINT(144)=VINT(144)-VINT(42)
19731 C...Allow FSR for UE (always handle with old showers)
19732 IF(MSTP(152).EQ.1) THEN
19734 IF (MSTJ(41).EQ.10) MSTJ(41)=2
19735 MSTJ(41)=MOD(MSTJ(41),10)
19736 CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
19739 IF(MINT(31).LT.240) GOTO 220
19747 C...Format statements for printout.
19748 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
19749 &'actions for MSTP(82) =',I2,' ******')
19750 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19751 &D9.2,' mb: rejected')
19752 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19753 &D9.2,' mb: accepted')
19758 C*********************************************************************
19761 C...Adds on target remnants (one or two from each side) and
19762 C...includes primordial kT for hadron beams.
19764 SUBROUTINE PYREMN(IPU1,IPU2)
19766 C...Double precision and integer declarations.
19767 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19768 IMPLICIT INTEGER(I-N)
19769 INTEGER PYK,PYCHGE,PYCOMP
19771 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19772 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19774 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19775 COMMON/PYINT1/MINT(400),VINT(400)
19776 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19778 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
19779 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
19781 C...Find event type and remaining energy.
19784 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
19785 VINT(143)=1D0-VINT(141)
19786 VINT(144)=1D0-VINT(142)
19789 C...Define initial partons.
19794 IF(JT.EQ.1) IPU=IPU1
19795 IF(JT.EQ.2) IPU=IPU2
19802 IF(MINT(47).EQ.1) THEN
19806 ELSEIF(ISUB.EQ.95) THEN
19811 C...No primordial kT, or chosen according to truncated Gaussian or
19812 C...exponential, or (for photon) predetermined or power law.
19813 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
19814 IF(MSTP(91).LE.0) THEN
19816 ELSEIF(MSTP(91).EQ.1) THEN
19817 PT=PARP(91)*SQRT(-LOG(PYR(0)))
19821 PT=-PARP(92)*LOG(RPT1*RPT2)
19823 IF(PT.GT.PARP(93)) GOTO 120
19824 ELSEIF(MINT(106+JT).EQ.3) THEN
19825 PTA=SQRT(VINT(282+JT))
19827 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
19828 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
19829 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
19832 PTB=-PARP(99)*LOG(RPT1*RPT2)
19834 IF(PTB.GT.PARP(100)) GOTO 120
19835 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
19836 PT=PT*0.8D0**MINT(57)
19837 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
19838 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
19839 IF(MSTP(93).LE.0) THEN
19841 ELSEIF(MSTP(93).EQ.1) THEN
19842 PT=PARP(99)*SQRT(-LOG(PYR(0)))
19843 ELSEIF(MSTP(93).EQ.2) THEN
19846 PT=-PARP(99)*LOG(RPT1*RPT2)
19847 ELSEIF(MSTP(93).EQ.3) THEN
19850 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
19854 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
19855 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
19857 IF(PT.GT.PARP(100)) GOTO 120
19865 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19868 IF(MINT(47).EQ.1) RETURN
19870 C...Kinematics construction for initial partons.
19873 IF(ISUB.EQ.95) THEN
19877 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
19878 & (P(I1,2)+P(I2,2))**2
19879 SHR=SQRT(MAX(0D0,SHS))
19880 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
19881 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
19882 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
19883 P(I2,4)=SHR-P(I1,4)
19886 C...Transform partons to overall CM-frame.
19887 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
19888 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
19889 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
19890 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
19891 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
19892 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
19893 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
19894 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
19895 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
19896 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
19897 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
19900 C...Optionally fix up x and Q2 definitions for leptoproduction.
19902 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
19903 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
19904 IF(IDISXQ.EQ.1) THEN
19906 C...Find where incoming and outgoing leptons/partons are sitting.
19908 IF(MINT(42).EQ.1) LESD=2
19909 LPIN=MINT(83)+3-LESD
19911 LQIN=MINT(84)+3-LESD
19912 LEOUT=MINT(84)+2+LESD
19913 LQOUT=MINT(84)+5-LESD
19914 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
19915 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
19917 DO 140 I=MINT(84)+5,N
19918 IF(K(I,2).EQ.94) THEN
19925 IF(LESD.EQ.1) LQBG=IPU2
19927 C...Calculate actual and wanted momentum transfer.
19930 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
19931 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
19932 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
19933 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
19934 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
19935 P(N+1,1)=FAC*P(LEOUT,1)
19936 P(N+1,2)=FAC*P(LEOUT,2)
19937 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
19938 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
19939 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
19942 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
19943 QNEW(J)=P(LEIN,J)-P(N+1,J)
19946 C...Boost outgoing electron and daughters.
19947 IF(LSCMS.EQ.0) THEN
19949 P(LEOUT,J)=P(N+1,J)
19953 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
19955 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
19957 DBE(J)=PINV*P(N+2,J)
19961 190 IORIG=K(IORIG,3)
19962 IF(IORIG.GT.LEOUT) GOTO 190
19963 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
19964 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
19968 C...Copy shower initiator and all outgoing partons.
19972 P(NCOP,J)=P(LQBG,J)
19974 DO 240 I=MINT(84)+1,N
19976 IF(K(I,1).GT.10) GOTO 240
19977 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
19981 220 IORIG=K(IORIG,3)
19982 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
19984 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
19997 C...Calculate relative rescaling factors.
20001 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
20004 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
20007 C...Transfer extra three-momentum of current.
20010 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
20012 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20015 C...Iterate change of initiator momentum to get energy right.
20018 PEEX=-P(N+1,4)-QNEW(4)
20019 PEMV=-P(N+1,3)/P(N+1,4)
20022 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
20024 IF(ABS(PEMV).LT.1D-10) THEN
20026 MINT(57)=MINT(57)+1
20030 P(N+1,3)=P(N+1,3)+PZCH
20031 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)
20033 P(I,3)=P(I,3)+V(I,1)*PZCH
20034 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20036 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
20038 C...Modify momenta in event record.
20039 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
20040 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
20041 IF(ABS(HBE).GE.1D0) THEN
20043 MINT(57)=MINT(57)+1
20047 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
20056 C...Check minimum invariant mass of remnant system(s).
20057 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
20058 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
20059 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20060 PMIN(0)=SQRT(PMS(0))
20062 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
20063 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
20065 IF(MINT(44+JT).EQ.1) GOTO 340
20066 MINT(105)=MINT(102+JT)
20067 MINT(109)=MINT(106+JT)
20068 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
20069 IF(MINT(51).NE.0) THEN
20070 MINT(57)=MINT(57)+1
20073 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
20074 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
20075 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
20076 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
20077 & P(MINT(83)+JT+2,2)**2)
20079 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
20080 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
20083 MINT(57)=MINT(57)+1
20087 C...Loop over two remnants; skip if none there.
20091 IF(MINT(44+JT).EQ.1) GOTO 410
20092 IF(JT.EQ.1) IPU=IPU1
20093 IF(JT.EQ.2) IPU=IPU2
20095 C...Store first remnant parton.
20107 P(I,5)=PYMASS(K(I,2))
20109 C...First parton colour connections and kinematics.
20110 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
20113 K(I,4)=MSTU(5)*IPU+IPU
20114 K(I,5)=MSTU(5)*IPU+IPU
20115 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20116 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20117 ELSEIF(KCOL.NE.0) THEN
20119 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
20121 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20123 IF(KFLCH(JT).EQ.0) THEN
20124 P(I,1)=-P(MINT(83)+JT+2,1)
20125 P(I,2)=-P(MINT(83)+JT+2,2)
20126 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20127 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20131 C...When extra remnant parton or hadron: store extra remnant.
20143 P(I,5)=PYMASS(K(I,2))
20145 C...Find parton colour connections of extra remnant.
20146 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
20149 K(I,4)=MSTU(5)*IPU+IPU
20150 K(I,5)=MSTU(5)*IPU+IPU
20151 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20152 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20153 ELSEIF(KCOL.NE.0) THEN
20155 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
20157 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20160 C...Relative transverse momentum when two remnants.
20163 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
20164 IF(IABS(MINT(10+JT)).LT.20) THEN
20168 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
20169 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
20171 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
20172 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
20173 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
20174 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20176 C...Meson or baryon; photon as meson. For splitup below.
20178 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
20180 C***Relative distribution for electron into two electrons. Temporary!
20181 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
20185 C...Relative distribution of electron energy into electron plus parton.
20186 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
20189 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
20191 C...Relative distribution of energy for particle into two jets.
20192 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
20193 CHIK=PARP(92+2*IMB)
20194 IF(MSTP(92).LE.1) THEN
20195 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20196 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20197 ELSEIF(MSTP(92).EQ.2) THEN
20198 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
20199 ELSEIF(MSTP(92).EQ.3) THEN
20200 CUT=2D0*0.3D0/VINT(1)
20201 380 CHI(JT)=PYR(0)**2
20202 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
20203 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
20204 ELSEIF(MSTP(92).EQ.4) THEN
20205 CUT=2D0*0.3D0/VINT(1)
20206 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
20207 390 CHIR=CUT*CUTR**PYR(0)
20208 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
20209 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
20211 CUT=2D0*0.3D0/VINT(1)
20212 CUTA=CUT**(1D0-PARP(98))
20213 CUTB=(1D0+CUT)**(1D0-PARP(98))
20214 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
20215 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
20216 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
20219 C...Relative distribution of energy for particle into jet plus particle.
20221 IF(MSTP(94).LE.1) THEN
20222 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20223 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20224 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20225 ELSEIF(MSTP(94).EQ.2) THEN
20226 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
20227 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20228 ELSEIF(MSTP(94).EQ.3) THEN
20229 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
20232 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
20237 C...Construct total transverse mass; reject if too large.
20238 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
20239 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
20240 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
20241 IF(LOOP.LT.100) THEN
20245 MINT(57)=MINT(57)+1
20249 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20250 VINT(158+JT)=CHI(JT)
20252 C...Subdivide longitudinal momentum according to value selected above.
20253 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
20254 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
20255 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
20256 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
20257 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
20262 C...Check if longitudinal boosts needed - if so pick two systems.
20263 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
20264 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
20265 IF(PDEV.LE.1D-6*VINT(1)) RETURN
20266 IF(ISN(1).EQ.0) THEN
20269 ELSEIF(ISN(2).EQ.0) THEN
20272 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
20275 ELSEIF(VINT(143).GT.0.2D0) THEN
20278 ELSEIF(VINT(144).GT.0.2D0) THEN
20281 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
20290 C...E+-pL wanted for system to be modified.
20291 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
20295 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
20296 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
20299 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
20300 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
20301 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
20302 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
20306 DO 450 I=MINT(84)+1,NS
20307 IF(K(I,1).GT.10) GOTO 450
20310 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20312 IF(IORIG.GT.LPIN) GOTO 430
20313 IF(INCL.EQ.0) GOTO 450
20315 PSYS(0,J)=PSYS(0,J)+P(I,J)
20318 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20319 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
20320 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
20323 C...Construct longitudinal boosts.
20327 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
20328 IF(DSQLAM.LE.1D-6*DPMTB) THEN
20330 MINT(57)=MINT(57)+1
20333 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
20334 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
20335 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
20336 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
20337 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
20338 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
20339 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
20341 C...Perform longitudinal boosts.
20342 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
20344 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
20345 ELSEIF(IR.EQ.1) THEN
20346 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
20347 ELSEIF(IDISXQ.EQ.1) THEN
20351 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20353 IF(IORIG.GT.LPIN) GOTO 460
20354 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
20357 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
20359 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
20361 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
20362 ELSEIF(IL.EQ.2) THEN
20363 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
20364 ELSEIF(IDISXQ.EQ.1) THEN
20368 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20370 IF(IORIG.GT.LPIN) GOTO 480
20371 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
20374 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
20377 C...Final check that energy-momentum conservation worked.
20380 DO 500 I=MINT(84)+1,N
20381 IF(K(I,1).GT.10) GOTO 500
20385 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
20386 IF(PDEV.GT.1D-4*VINT(1)) THEN
20388 MINT(57)=MINT(57)+1
20392 C...Calculate rotation and boost from overall CM frame to
20393 C...hadronic CM frame in leptoproduction.
20395 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20398 IF(MINT(42).EQ.1) LESD=2
20399 LPIN=MINT(83)+3-LESD
20401 C...Sum upp momenta of everything not lepton or photon to define boost.
20406 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
20407 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
20408 IF(K(I,2).EQ.22) GOTO 530
20410 PSUM(J)=PSUM(J)+P(I,J)
20413 VINT(223)=-PSUM(1)/PSUM(4)
20414 VINT(224)=-PSUM(2)/PSUM(4)
20415 VINT(225)=-PSUM(3)/PSUM(4)
20417 C...Boost incoming hadron to hadronic CM frame to determine rotations.
20423 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
20424 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
20425 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
20427 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
20429 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
20436 C*********************************************************************
20439 C...Initializes treatment of new multiple interactions scenario,
20440 C...selects kinematics of hardest interaction if low-pT physics
20441 C...included in run, and generates all non-hardest interactions.
20443 SUBROUTINE PYMIGN(MMUL)
20445 C...Double precision and integer declarations.
20446 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20447 IMPLICIT INTEGER(I-N)
20448 INTEGER PYK,PYCHGE,PYCOMP
20450 DOUBLE PRECISION PYALPS
20452 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20453 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20454 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20455 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20456 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20457 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20458 COMMON/PYINT1/MINT(400),VINT(400)
20459 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20460 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20461 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20462 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20463 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20464 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20465 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20466 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20467 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
20468 C...Local arrays and saved variables.
20469 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
20470 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
20471 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
20472 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
20473 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
20475 C...Initialization of multiple interaction treatment.
20477 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
20485 C...Loop over phase space points: xT2 choice in 20 bins.
20488 NMUL(IXT2)=MSTP(83)
20490 DO 110 ITRY=1,MSTP(83)
20491 RSCA=0.05D0*((21-IXT2)-PYR(0))
20492 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
20493 XT2=MAX(0.01D0*VINT(149),XT2)
20496 C...Choose tau and y*. Calculate cos(theta-hat).
20497 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20498 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20499 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20501 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20507 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20508 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20509 CALL PYKMAP(2,MYST,PYR(0))
20510 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20512 C...Calculate differential cross-section.
20513 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20514 CALL PYSIGH(NCHN,SIGS)
20515 SIGM(IXT2)=SIGM(IXT2)+SIGS
20517 SIGSUM=SIGSUM+SIGM(IXT2)
20519 SIGSUM=SIGSUM/(20D0*MSTP(83))
20521 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
20522 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
20523 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
20524 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
20525 PARP(82)=0.9D0*PARP(82)
20526 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
20530 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
20531 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
20533 C...Start iteration to find k factor.
20534 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
20535 P83A=(1D0-PARP(83))**2
20536 P83B=2D0*PARP(83)*(1D0-PARP(83))
20538 CQ2I=1D0/PARP(84)**2
20539 CQ2R=2D0/(1D0+PARP(84)**2)
20547 130 IF(IIT.EQ.0) THEN
20549 ELSEIF(IIT.EQ.1) THEN
20552 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
20555 C...Evaluate overlap integrals. Find where to divide the b range.
20556 IF(MSTP(82).EQ.2) THEN
20557 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
20560 IF(MSTP(82).EQ.3) THEN
20562 ELSEIF(MSTP(82).EQ.4) THEN
20563 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
20565 POWIP=MAX(0.4D0,PARP(83))
20566 RPWIP=2D0/POWIP-1D0
20567 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
20577 IF(MSTP(82).EQ.3) THEN
20578 OV=EXP(-B**2)/PARU(2)
20579 ELSEIF(MSTP(82).EQ.4) THEN
20580 OV=(P83A*EXP(-MIN(50D0,B**2))+
20581 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20582 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20584 OV=EXP(-B**POWIP)/PARU(2)
20585 SO=SO+PARU(2)*B*DELTAB*OV
20587 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
20588 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
20589 SP=SP+PARU(2)*B*DELTAB*PACC
20590 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
20591 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
20592 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
20594 BDIV=B+0.5D0*DELTAB
20596 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
20598 YK=PARU(1)*XK*SO/SP
20600 C...Continue iteration until convergence.
20610 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
20612 C...Store some results for subsequent use.
20620 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
20621 PIK=(VNT146/VNT147)*YKE
20623 C...Find relative weight for low and high impact parameter..
20624 PLOWB=PARU(1)*BDIV**2
20625 IF(MSTP(82).EQ.3) THEN
20626 PHIGHB=PIK*0.5*EXP(-BDIV**2)
20627 ELSEIF(MSTP(82).EQ.4) THEN
20628 S4A=P83A*EXP(-BDIV**2)
20629 S4B=P83B*EXP(-BDIV**2*CQ2R)
20630 S4C=P83C*EXP(-BDIV**2*CQ2I)
20631 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
20632 ELSEIF(PARP(83).GE.1.999D0) THEN
20638 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
20642 C...Initialize iteration in xT2 for hardest interaction.
20643 ELSEIF(MMUL.EQ.2) THEN
20647 IF(MSTP(82).LE.0) THEN
20648 ELSEIF(MSTP(82).EQ.1) THEN
20650 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20651 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20652 & VINT(317)/(VINT(318)*VINT(320))
20653 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20654 ELSEIF(MSTP(82).EQ.2) THEN
20656 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20657 & VINT(149)*(1D0+VINT(149))
20659 XC2=4D0*CKIN(3)**2/VINT(2)
20660 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
20663 C...Select impact parameter for hardest interaction.
20664 IF(MSTP(82).LE.2) RETURN
20665 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
20666 C...Treatment in low b region.
20668 B=BDIV*SQRT(PYR(0))
20669 IF(MSTP(82).EQ.3) THEN
20670 OV=EXP(-B**2)/PARU(2)
20671 ELSEIF(MSTP(82).EQ.4) THEN
20672 OV=(P83A*EXP(-MIN(50D0,B**2))+
20673 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20674 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20676 OV=EXP(-B**POWIP)/PARU(2)
20678 VINT(148)=OV/VNT147
20679 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
20681 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20682 & VINT(149)*(1D0+VINT(149))
20684 C...Treatment in high b region.
20686 IF(MSTP(82).EQ.3) THEN
20687 B=SQRT(BDIV**2-LOG(PYR(0)))
20688 OV=EXP(-B**2)/PARU(2)
20689 ELSEIF(MSTP(82).EQ.4) THEN
20690 S4RNDM=PYR(0)*(S4A+S4B+S4C)
20691 IF(S4RNDM.LT.S4A) THEN
20692 B=SQRT(BDIV**2-LOG(PYR(0)))
20693 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
20694 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
20696 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
20698 OV=(P83A*EXP(-MIN(50D0,B**2))+
20699 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20700 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20701 ELSEIF(PARP(83).GE.1.999D0) THEN
20702 144 B2RPW=B2RPDV-LOG(PYR(0))
20703 ACCIP=(B2RPW/B2RPDV)**RPWIP
20704 IF(ACCIP.LT.PYR(0)) GOTO 144
20705 OV=EXP(-B2RPW)/PARU(2)
20706 B=B2RPW**(1D0/POWIP)
20708 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
20709 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
20710 IF(ACCIP.LT.PYR(0)) GOTO 146
20711 OV=EXP(-B2RPW)/PARU(2)
20712 B=B2RPW**(1D0/POWIP)
20714 VINT(148)=OV/VNT147
20715 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
20717 IF(PACC.LT.PYR(0)) GOTO 142
20720 ELSEIF(MMUL.EQ.3) THEN
20721 C...Low-pT or multiple interactions (first semihard interaction):
20722 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
20723 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
20728 IF(MSTP(82).LE.0) THEN
20730 ELSEIF(MSTP(82).EQ.1) THEN
20731 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20732 C...Use with "Sudakov" for low b values when impact parameter dependence.
20733 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
20734 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
20735 & VINT(149)))).GT.PYR(0)) XT2=1D0
20736 IF(XT2.GE.1D0) THEN
20737 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
20738 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
20741 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
20742 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
20745 XT2=MAX(0.01D0*VINT(149),XT2)
20746 C...Use without "Sudakov" for high b values when impact parameter dep.
20748 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
20749 & PYR(0)*(1D0-XC2))-VINT(149)
20750 XT2=MAX(0.01D0*VINT(149),XT2)
20754 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
20755 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
20756 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
20757 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
20760 VINT(21)=1D-12*VINT(149)
20763 VINT(25)=1D-12*VINT(149)
20766 C...Multiple interactions (first semihard interaction).
20767 C...Choose tau and y*. Calculate cos(theta-hat).
20768 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20769 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20770 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20772 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20778 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20779 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20780 CALL PYKMAP(2,MYST,PYR(0))
20781 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20783 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
20785 C...Store results of cross-section calculation.
20786 ELSEIF(MMUL.EQ.4) THEN
20792 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
20793 IF(ISET(ISUB).EQ.2)
20794 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20795 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
20796 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
20797 & (XTS+VINT(149))))
20798 IRBIN=INT(1D0+20D0*RBIN)
20799 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
20800 NMUL(IRBIN)=NMUL(IRBIN)+1
20801 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
20804 C...Choose impact parameter if not already done.
20805 ELSEIF(MMUL.EQ.5) THEN
20810 150 IF(MINT(39).GT.0) THEN
20811 ELSEIF(MSTP(82).EQ.3) THEN
20814 VINT(148)=EXPB2/(PARU(2)*VNT147)
20815 VINT(139)=SQRT(B2)/BAVG
20816 ELSEIF(MSTP(82).EQ.4) THEN
20818 IF(RTYPE.LT.P83A) THEN
20820 ELSEIF(RTYPE.LT.P83A+P83B) THEN
20821 B2=-LOG(PYR(0))/CQ2R
20823 B2=-LOG(PYR(0))/CQ2I
20825 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
20826 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
20827 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
20828 VINT(139)=SQRT(B2)/BAVG
20829 ELSEIF(PARP(83).GE.1.999D0) THEN
20830 POWIP=MAX(2D0,PARP(83))
20831 RPWIP=2D0/POWIP-1D0
20832 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
20833 160 IF(PYR(0).LT.PROB1) THEN
20834 B2RPW=PYR(0)**(0.5D0*POWIP)
20837 B2RPW=1D0-LOG(PYR(0))
20840 IF(ACCIP.LT.PYR(0)) GOTO 160
20841 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20842 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20844 POWIP=MAX(0.4D0,PARP(83))
20845 RPWIP=2D0/POWIP-1D0
20846 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
20847 170 IF(PYR(0).LT.PROB1) THEN
20848 B2RPW=2D0*RPWIP*PYR(0)
20849 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
20851 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
20852 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
20854 IF(ACCIP.LT .PYR(0)) GOTO 170
20855 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20856 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20859 C...Multiple interactions (variable impact parameter) : reject with
20860 C...probability exp(-overlap*cross-section above pT/normalization).
20861 C...Does not apply to low-b region, where "Sudakov" already included.
20863 IF(MINT(39).NE.1) THEN
20864 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
20865 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
20866 DO 180 IBIN=IRBIN+1,20
20867 RNCOR=RNCOR+NMUL(IBIN)
20868 SIGCOR=SIGCOR+SIGM(IBIN)
20870 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
20871 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
20872 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
20873 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
20875 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
20876 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
20877 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20878 IF(VINT(150).LT.PYR(0)) GOTO 150
20882 C...Generate additional multiple semihard interactions.
20883 ELSEIF(MMUL.EQ.6) THEN
20885 C...Save data for hardest initeraction, to be restored.
20902 C...Store data on hardest interaction.
20909 C...Change process to generate; sum of x values so far.
20912 VINT(143)=1D0-VINT(141)
20913 VINT(144)=1D0-VINT(142)
20917 C...Initialize factors for PDF reshaping.
20921 KFSBM=ISIGN(1,KFBEAM)
20923 C...Zero flavour content of incoming beam particle.
20927 C...Flavour content of baryon.
20928 IF(KFABM.GT.1000) THEN
20929 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
20930 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
20931 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
20932 C...Flavour content of pi+-, K+-.
20933 ELSEIF(KFABM.EQ.211) THEN
20934 KFIVAL(JS,1)=KFSBM*2
20935 KFIVAL(JS,2)=-KFSBM
20936 ELSEIF(KFABM.EQ.321) THEN
20937 KFIVAL(JS,1)=-KFSBM*3
20938 KFIVAL(JS,2)=KFSBM*2
20939 C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
20942 C...Zero initial valence and companion content.
20947 C...Initiate listing of all incoming partons from two sides.
20949 DO 210 I=MINT(84)+1,N
20950 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
20956 C...Decide whether quarks in hard scattering were valence or sea.
20957 IFL=K(IMI(JS,1,1),2)
20958 IF (IABS(IFL).GT.6) GOTO 230
20960 C...Get PDFs at X and Q2 of the parton shower initiator for the
20961 C...hard scattering.
20963 IF(MSTP(61).GE.1) THEN
20968 C...Note: XPSVC = x*pdf.
20971 C.... Store side in MINT(124)
20974 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20978 C...Decide (Extra factor x cancels in the division).
20979 RVCS=PYR(0)*(SEA+VAL)
20981 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20982 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20984 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20985 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20986 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20987 IF(KFIVAL(JS,1).EQ.0) THEN
20988 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20989 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20990 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20991 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20993 IF(IVNOW.EQ.0) GOTO 220
20996 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20997 IF(KFIVAL(JS,1).EQ.0) THEN
20998 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21001 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21003 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21004 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21008 C...If sea, add opposite sign companion parton. Store X and I.
21010 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21011 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21012 C...Set pointer to companion
21013 IMI(JS,1,2)=-NVC(JS,-IFL)
21017 C...Update counter number of multiple interactions.
21021 C...Set up starting values for iteration in xT2.
21022 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
21023 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
21024 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
21025 & ISUBSV.NE.96)) THEN
21026 XT2=(1D0-VINT(141))*(1D0-VINT(142))
21029 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
21030 IF(ISET(ISUBSV).EQ.2)
21031 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
21032 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
21034 IF(MSTP(82).LE.1) THEN
21035 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
21036 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
21037 & VINT(317)/(VINT(318)*VINT(320))
21038 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
21040 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
21041 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
21046 C...Iterate downwards in xT2.
21047 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
21050 ELSEIF(MSTP(82).LE.1) THEN
21051 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
21052 IF(XT2.LT.VINT(149)) GOTO 440
21054 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
21055 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
21056 & LOG(PYR(0)))-VINT(149)
21057 IF(XT2.LE.0D0) GOTO 440
21058 XT2=MAX(0.01D0*VINT(149),XT2)
21062 C...Choose tau and y*. Calculate cos(theta-hat).
21063 IF(PYR(0).LE.COEF(ISUB,1)) THEN
21064 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
21065 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
21067 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
21070 C...New: require shat > 1.
21071 IF(TAU*VINT(2).LT.1D0) GOTO 240
21075 IF(RYST.GT.COEF(ISUB,8)) MYST=2
21076 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21077 CALL PYKMAP(2,MYST,PYR(0))
21078 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21080 C...Check that x not used up. Accept or reject kinematical variables.
21081 X1M=SQRT(TAU)*EXP(VINT(22))
21082 X2M=SQRT(TAU)*EXP(-VINT(22))
21083 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
21084 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
21085 CALL PYSIGH(NCHN,SIGS)
21086 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
21087 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
21088 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
21090 C...Reset K, P and V vectors.
21098 PT=0.5D0*VINT(1)*SQRT(XT2)
21100 C...Choose flavour of reacting partons (and subprocess).
21105 ICONMI=ISIG(ICHN,3)
21106 RSIGS=RSIGS-SIGH(ICHN)
21107 IF(RSIGS.LE.0D0) GOTO 280
21110 C...Reassign to appropriate process codes.
21111 280 ISUBMI=ICONMI/10
21112 ICONMI=MOD(ICONMI,10)
21114 C...Choose new quark flavour for annihilation graphs
21115 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
21117 CALL PYWIDT(21,SH,WDTP,WDTE)
21118 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
21119 DO 300 I=1,MDCY(21,3)
21120 KFLF=KFDP(I+MDCY(21,2)-1,1)
21121 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
21122 IF(RKFL.LE.0D0) GOTO 310
21124 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
21125 IF(KFLF.GE.4) GOTO 290
21126 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
21129 ELSEIF(ISUBMI.EQ.53) THEN
21135 C...Final state flavours and colour flow: default values
21142 IF(ISUBMI.EQ.11) THEN
21143 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
21145 IF(KFL1*KFL2.LT.0) KCC=KCC+2
21147 ELSEIF(ISUBMI.EQ.12) THEN
21148 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
21149 KFL3=ISIGN(KFLF,KFL1)
21153 ELSEIF(ISUBMI.EQ.13) THEN
21154 C...f + fbar -> g + g; th arbitrary
21159 ELSEIF(ISUBMI.EQ.28) THEN
21160 C...f + g -> f + g; th = (p(f)-p(f))**2
21161 IF(KFL1.EQ.21) JS=2
21163 IF(KFL1.EQ.21) KCC=KCC+2
21164 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
21165 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
21167 ELSEIF(ISUBMI.EQ.53) THEN
21168 C...g + g -> f + fbar; th arbitrary
21169 KCS=(-1)**INT(1.5D0+PYR(0))
21170 KFL3=ISIGN(KFLF,KCS)
21174 ELSEIF(ISUBMI.EQ.68) THEN
21175 C...g + g -> g + g; th arbitrary
21177 KCS=(-1)**INT(1.5D0+PYR(0))
21180 C...Store flavours of scattering.
21188 C...Set flavours and mothers of scattering partons.
21197 K(N+1,3)=MINT(83)+1
21198 K(N+2,3)=MINT(83)+2
21202 C...Store colour connection indices.
21205 IF(KCS.EQ.-1) JC=3-J
21206 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
21207 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
21208 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
21209 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
21212 C...Store incoming and outgoing partons in their CM-frame.
21213 SHR=SQRT(TAU)*VINT(1)
21216 P(N+2,3)=-0.5D0*SHR
21218 P(N+3,5)=PYMASS(K(N+3,2))
21219 P(N+4,5)=PYMASS(K(N+4,2))
21220 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
21221 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
21222 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
21223 P(N+4,4)=SHR-P(N+3,4)
21226 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
21228 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
21230 C...Set up default values before showers.
21231 MINT(31)=MINT(31)+1
21240 C...Showering of initial state partons (optional).
21241 C...Note: no showering of final state partons here; it comes later.
21242 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21249 KSAV(I,J)=K(N-4+I,J)
21250 PSAV(I,J)=P(N-4+I,J)
21253 CALL PYSSPA(IPU1,IPU2)
21255 C...If shower failed then restore to situation before shower.
21256 IF(MINT(51).GE.1) THEN
21260 K(N-4+I,J)=KSAV(I,J)
21261 P(N-4+I,J)=PSAV(I,J)
21271 C...Keep track of loose colour ends and information on scattering.
21272 370 IMI(1,MINT(31),1)=IPU1
21273 IMI(2,MINT(31),1)=IPU2
21274 IMI(1,MINT(31),2)=0
21275 IMI(2,MINT(31),2)=0
21276 XMI(1,MINT(31))=VINT(141)
21277 XMI(2,MINT(31))=VINT(142)
21278 PT2MI(MINT(31))=VINT(54)
21281 C...Decide whether quarks in last scattering were valence, companion or
21285 KFSBM=ISIGN(1,MINT(10+JS))
21286 IFL=K(IMI(JS,MINT(31),1),2)
21287 IMI(JS,MINT(31),2)=0
21288 IF (IABS(IFL).GT.6) GOTO 430
21290 C...Get PDFs at X and Q2 of the parton shower initiator for the
21291 C...last scattering. At this point VINT(143:144) do not yet
21292 C...include the scattered x values VINT(141:142).
21293 X=VINT(140+JS)/VINT(142+JS)
21294 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21299 C...Note: XPSVC = x*pdf.
21302 C.... Store side in MINT(124)
21305 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
21309 DO 380 IVC=1,NVC(JS,IFL)
21310 CMP=CMP+XPSVC(IFL,IVC)
21313 C...Decide (Extra factor x cancels in the dvision).
21314 RVCS=PYR(0)*(SEA+VAL+CMP)
21316 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
21317 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21319 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
21320 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
21321 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
21322 IF(KFIVAL(JS,1).EQ.0) THEN
21323 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
21324 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
21325 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
21326 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
21328 DO 400 I1=1,NMI(JS)
21329 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
21333 IF(IVNOW.EQ.0) GOTO 390
21335 IMI(JS,MINT(31),2)=0
21336 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21337 IF(KFIVAL(JS,1).EQ.0) THEN
21338 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21341 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21343 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21344 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21348 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
21349 C...If sea, add opposite sign companion parton. Store X and I.
21350 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21351 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21352 C...Set pointer to companion
21353 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
21355 C...If companion, decide which one.
21359 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
21360 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
21361 C...Find original sea (anti-)quark:
21363 DO 420 I1=1,NMI(JS)
21364 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
21365 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
21366 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
21367 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
21370 C...Change X to what associated companion had, so that the correct
21371 C...amount of momentum can be subtracted from the companion sum below.
21372 X=XASSOC(JS,IFL,ISEL)
21373 C...Mark companion read.
21374 XASSOC(JS,IFL,ISEL)=0D0
21378 C...Global statistics.
21379 MINT(351)=MINT(351)+1
21380 VINT(351)=VINT(351)+PT
21381 IF (MINT(351).EQ.1) VINT(356)=PT
21383 C...Update remaining energy and other counters.
21384 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
21385 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
21391 VINT(151)=VINT(151)+VINT(41)
21392 VINT(152)=VINT(152)+VINT(42)
21393 VINT(143)=VINT(143)-VINT(141)
21394 VINT(144)=VINT(144)-VINT(142)
21396 C...Iterate, with more interactions allowed.
21397 IF(MINT(31).LT.240) GOTO 240
21400 C...Restore saved quantities for hardest interaction.
21416 C...Format statements for printout.
21417 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
21418 &'actions for MSTP(82) =',I2,' ******')
21419 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21420 &D9.2,' mb: rejected')
21421 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21422 &D9.2,' mb: accepted')
21427 C*********************************************************************
21430 C...Finds left-behind remnant flavour content and hooks up
21431 C...the colour flow between the hard scattering and remnants
21435 C...Double precision and integer declarations.
21436 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21437 IMPLICIT INTEGER(I-N)
21438 INTEGER PYK,PYCHGE,PYCOMP
21439 C...The event record
21440 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21442 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21443 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21444 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21445 COMMON/PYINT1/MINT(400),VINT(400)
21446 C...The common block of dangling ends
21447 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
21448 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
21449 & XMI(2,240),PT2MI(240),IMISEP(0:240)
21450 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
21451 C...Local variables
21452 PARAMETER (NERSIZ=4000)
21453 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
21455 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
21456 SAVE /PYCBLS/,/PYCTAG/
21457 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
21458 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
21461 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)
21463 C...Set up error checkers
21466 C...Initialize colour arrays: MCO (Original) and MCT (New)
21467 DO 110 I=MINT(84)+1,NERSIZ
21472 C...Also zero colour tracing information, if existed.
21474 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21475 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21479 C...Initialize colour tag collapse arrays:
21480 C...JCCO (Original) and JCCN (New).
21481 DO 130 MG=MINT(84)+1,NERSIZ
21488 C...Zero gluon insertion array
21495 C...Compute hard scattering system rapidities
21496 IF (MSTP(89).EQ.1) THEN
21498 IF (IM.LE.MINT(31)) THEN
21499 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
21501 C...Set (unsigned) rapidity = 100 for beam remnant systems.
21507 C...Treat each side separately
21510 C...Initialize side.
21513 KFS=ISIGN(1,MINT(10+JS))
21515 C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
21516 IF(KFIVAL(JS,1).EQ.0) THEN
21517 IF(MINT(10+JS).EQ.111) THEN
21518 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
21519 KFIVAL(JS,2)=-KFIVAL(JS,1)
21520 ELSEIF(MINT(10+JS).EQ.22) THEN
21523 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
21524 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
21525 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
21526 KFIVAL(JS,2)=-KFIVAL(JS,1)
21527 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
21528 IF(PYR(0).GT.0.5D0) THEN
21538 C...Initialize beam remnant sea and valence content flavour by flavour.
21542 C...Count up original number of JFA valence quarks and antiquarks.
21547 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
21548 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
21550 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
21551 C...Subtract kicked out valence and determine sea from flavour cons.
21552 DO 180 IM=1,NMI(JS)
21553 IFL = K(IMI(JS,IM,1),2)
21556 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
21557 C...Subtract K.O. valence quark from remainder.
21559 JV=NVSUM(JS)-NVALQ-NVALQB
21560 IV(JS,JV)=IMI(JS,IM,1)
21561 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
21562 C...Subtract K.O. valence antiquark from remainder.
21564 JV=NVSUM(JS)-NVALQ-NVALQB
21565 IV(JS,JV)=IMI(JS,IM,1)
21566 ELSEIF (IFA.EQ.JFA) THEN
21567 C...Outside sea without companion: add opposite sea flavour inside.
21568 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
21571 C...Check if space left in PYJETS for additional BR flavours
21572 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
21573 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
21574 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
21575 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
21579 C...Add required val+sea content to beam remnant.
21580 IF (NFLSUM.GT.0) THEN
21582 C...Insert beam remnant quark as p.t. symbolic parton in ER.
21590 K(N,2)=ISIGN(JFA,NSEA)
21591 IF (IA.LE.NVALQ) K(N,2)=JFA
21592 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
21594 C...Also update NMI, IMI, and IV arrays.
21596 IMI(JS,NMI(JS),1)=N
21597 IMI(JS,NMI(JS),2)=-1
21598 IF (IA.LE.NVALQ+NVALQB) THEN
21599 IMI(JS,NMI(JS),2)=0
21601 IV(JS,JV)=IMI(JS,NMI(JS),1)
21609 IF (IM.LE.NMI(JS)) THEN
21610 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
21612 C...Add fictitious parent gluons for companion pairs.
21613 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
21614 C...Randomly assign companions to sea quarks which have none.
21615 IF (IMI(JS,IM,2).LT.0) THEN
21617 230 IMC=MOD(IMC,NMI(JS))+1
21618 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
21619 IF (IMI(JS,IMC,2).GE.0) GOTO 230
21620 IMI(JS, IM,2) = IMI(JS,IMC,1)
21621 IMI(JS,IMC,2) = IMI(JS, IM,1)
21623 C...Add fictitious parent gluon
21633 C...Set gluon (anti-)colour daughter pointers
21634 K(N,4)=IMI(JS, IM,1)
21635 K(N,5)=IMI(JS, IM,2)
21636 C...Set quark (anti-)colour parent pointers
21637 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
21638 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
21639 C...Add gluon to IMI
21641 IMI(JS,NMI(JS),1)=N
21642 IMI(JS,NMI(JS),2)=0
21647 C...If incoming (anti-)baryon, insert inside (anti-)junction.
21648 C...Set up initial v-v-j-v configuration. Otherwise set up
21649 C...mesonic v-vbar configuration
21650 IF (IABS(MINT(10+JS)).GT.1000) THEN
21651 C...Determine junction type (1: B=1 2: B=-1)
21652 ITJUNC(JS) = (3-KFS)/2
21653 C...Insert junction.
21660 C...Set special junction codes:
21663 C...Set parent to side.
21665 K(N,4)=ITJUNC(JS)*MSTU(5)
21667 C...Connect valence quarks to junction.
21670 C...Set (anti)colour mother = junction.
21672 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21674 C...Keep track of partons adjacent to junction:
21675 JST(JS,JV)=IV(JS,JV)
21678 C...Mesons: set up initial q-qbar topology
21680 IF (K(IV(JS,1),2).GT.0) THEN
21691 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21692 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21693 C...Special for mesons. Insert gluon if BR empty.
21694 IF (NBRTOT(JS).EQ.0) THEN
21708 C...Add gluon to IMI
21710 IMI(JS,NMI(JS),1)=N
21711 IMI(JS,NMI(JS),2)=0
21716 C...Count up number of valence quarks outside BR.
21718 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
21719 & MOUT(JS)=MOUT(JS)+1
21724 C...Now both sides have been prepared in an initial vvjv (baryonic) or
21725 C...v(g)vbar (mesonic) configuration.
21727 C...Create colour line tags starting from initiators.
21729 DO 320 IM=1,MINT(31)
21730 C...Consider each side in turn.
21735 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
21737 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
21740 CALL PYCTTR(I1,KCS,I2)
21741 IF(MINT(51).NE.0) RETURN
21748 C...Create colour tags for beam remnant partons.
21749 DO 330 IM=MINT(31)+1,NMI(JS)
21751 IF (K(IP,2).NE.21) THEN
21752 JC=(3-ISIGN(1,K(IP,2)))/2
21753 IF (MCT(IP,JC).EQ.0) THEN
21762 C...Fictituous gluons just inherit from their quark daughters.
21766 C...Real beam remnant gluons get their own colours
21777 C...Create colour tags for colour lines which are detached from the
21781 DO 350 I=MINT(84)+1,N
21783 C...Look for coloured string endpoint, or (later) leftover gluon.
21784 IF (K(I,1).NE.3) GOTO 350
21786 IF(KC.EQ.0) GOTO 350
21788 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
21790 C...Pick up loose string end with no previous tag.
21792 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
21793 IF(MCT(I,KCS-3).NE.0) GOTO 350
21795 CALL PYCTTR(I,KCS,I)
21796 IF(MINT(51).NE.0) RETURN
21801 C...Store original colour tags
21802 DO 370 I=MINT(84)+1,N
21807 C...Iteratively add gluons to already existing string pieces, enforcing
21808 C...various possible orderings, and rejecting insertions that would give
21809 C...rise to singlet gluons.
21810 C...<kappa tau> normalization.
21815 C...Set up simplified kinematics.
21816 C...Boost hard interaction systems.
21818 DO 380 IM=1,MINT(31)
21819 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21820 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21822 C...Assign preliminary beam remnant momenta.
21823 DO 390 I=MINT(53)+1,N
21827 IF (K(I,2).NE.88) THEN
21828 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
21830 IF (JS.EQ.2) P(I,3)=-P(I,3)
21832 C...Junctions are wildcards for the present.
21838 C...Reset colour processing information.
21839 400 DO 410 I=MINT(84)+1,N
21840 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21841 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21846 C...If meson, without gluon in BR, collapse q-qbar colour tags:
21847 IF (ITJUNC(JS).EQ.0) THEN
21848 JC1=MCT(JST(JS,1),1)
21849 JC2=MCT(JST(JS,2),2)
21851 JCCO(NCC,1)=MAX(JC1,JC2)
21852 JCCO(NCC,2)=MIN(JC1,JC2)
21853 C...Collapse colour tags in event record
21854 DO 420 I=MINT(84)+1,N
21855 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
21856 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
21862 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
21863 IF (NG(JS).GT.0) THEN
21866 C...Start at random gluon (optimizes speed for random attachments)
21868 IMGL=PYR(0)*NMI(JS)+1
21869 450 IMGL=MOD(IMGL,NMI(JS))+1
21871 C...Only loop through NMI once (with upper limit to save time)
21872 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
21873 IGL = IMI(JS,IMGL,1)
21874 C...If not gluon or if already connected, try next.
21875 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
21876 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
21877 C...Now loop through all possible insertions of this gluon.
21879 IMP1=PYR(0)*NMI(JS)+1
21880 460 IMP1=MOD(IMP1,NMI(JS))+1
21882 IF (IMP1.EQ.IMGL) GOTO 460
21883 C...Only loop through NMI once (with upper limit to save time).
21884 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
21885 IP1 = IMI(JS,IMP1,1)
21886 C...Try both colour mother and colour anti-mother.
21887 C...Randomly select which one to try first.
21890 470 MANTI=MOD(MANTI+1,2)
21892 IF (NANTI.LE.2) THEN
21893 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
21894 C...Reject if no appropriate mother (or if mother is fictitious
21896 IF (IP2.LE.0) GOTO 470
21897 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
21898 C...Also reject if this link has already been tried.
21899 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21900 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21901 C...Set flag to indicate that this link has now been tried for this
21902 C...gluon. IP2 may be junction, which has several mothers.
21903 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
21904 IF (K(IP2,2).NE.88) THEN
21905 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
21908 C...JCG1: Original colour tag of gluon on IP1 side
21909 C...JCG2: Original colour tag of gluon on IP2 side
21910 C...JCP1: Original colour tag of IP1 on gluon side
21911 C...JCP2: Original colour tag of IP2 on gluon side.
21912 JCG1=MCO(IGL,2-MANTI)
21913 JCG2=MCO(IGL,1+MANTI)
21914 JCP1=MCO(IP1,1+MANTI)
21915 JCP2=MCO(IP2,2-MANTI)
21917 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
21918 C...Reject gluon attachments that give rise to singlet gluons.
21919 IF (MACCPT.EQ.0) GOTO 470
21922 JCG1=MCT(IGL,2-MANTI)
21923 JCG2=MCT(IGL,1+MANTI)
21924 JCP1=MCT(IP1,1+MANTI)
21925 JCP2=MCT(IP2,2-MANTI)
21927 C...Select whether to accept this insertion
21928 IF (MSTP(89).EQ.0) THEN
21929 C...Random insertions: no measure.
21931 C...For random ordering, we want to suppress beam remnant breakups
21932 C...already at this point.
21933 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
21934 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
21939 ELSEIF (MSTP(89).EQ.1) THEN
21940 C...Rapidity ordering:
21941 C...YGL = Rapidity of gluon.
21943 C...If fictitious gluon
21944 IF (YGL.EQ.100D0) THEN
21946 IDA1=MOD(K(IGL,4),MSTU(5))
21947 IDA2=MOD(K(IGL,5),MSTU(5))
21948 DO 480 IMT=1,NMI(JS)
21949 C...Select (arbitrarily) the most central daughter.
21950 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21952 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
21956 C...YP1 = Rapidity IP1
21958 C...If fictitious gluon
21959 IF (YP1.EQ.100D0) THEN
21961 IDA1=MOD(K(IP1,4),MSTU(5))
21962 IDA2=MOD(K(IP1,5),MSTU(5))
21963 DO 490 IMT=1,NMI(JS)
21964 C...Select (arbitrarily) the most central daughter.
21965 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21967 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
21971 C...YP2 = Rapidity of mother system
21972 IF (K(IP2,2).NE.88) THEN
21973 DO 500 IMT=1,NMI(JS)
21974 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
21976 C...If fictitious gluon
21977 IF (YP2.EQ.100D0) THEN
21979 IDA1=MOD(K(IP2,4),MSTU(5))
21980 IDA2=MOD(K(IP2,5),MSTU(5))
21981 DO 510 IMT=1,NMI(JS)
21982 C...Select (arbitrarily) the most central daughter.
21983 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
21985 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
21989 C...Assign (arbitrarily) 100D0 to junction also
21993 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
21994 ELSEIF (MSTP(89).EQ.2) THEN
21995 C...Lambda ordering:
21996 C...Compute lambda measure for this insertion.
22001 C...If IP2 is junction, not caught below.
22002 IF (JCP2.EQ.0) THEN
22003 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
22004 C...Anti-junction is colour endpoint et vv., always on JCG2.
22007 DO 530 I=MINT(84)+1,N
22008 IF (K(I,1).LT.10) THEN
22009 C...The new string pieces
22010 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
22011 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
22012 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
22013 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
22016 C...Also identify junctions as string endpoints.
22017 DO 540 I=MINT(84)+1,N
22018 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
22019 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
22020 C...Find partons adjacent to junctions.
22021 IF (ICMO.GT.0.AND.ICMO.LE.N) THEN
22022 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
22023 & .EQ.0) ISTR(2) = ICMO
22024 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
22025 & .EQ.0) ISTR(4) = ICMO
22027 IF (IAMO.GT.0.AND.IAMO.LE.N) THEN
22028 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
22029 & .EQ.0) ISTR(1) = IAMO
22030 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
22031 & .EQ.0) ISTR(3) = IAMO
22034 C...The old string piece
22035 ISTR(5)=ISTR(1+2*MANTI)
22036 ISTR(6)=ISTR(4-2*MANTI)
22037 IF (ISTR(1).EQ.0.OR.ISTR(2).EQ.0.OR.ISTR(3).EQ.0.OR.
22038 & ISTR(4).EQ.0.OR.ISTR(5).EQ.0.OR.ISTR(6).EQ.0) THEN
22039 C...If one or more of the colour tags for this connection is/are still
22040 C...dangling, skip this attempt for the time being.
22043 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
22044 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
22048 C...Allow some breadth to speed things up.
22049 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
22051 ELSEIF (RL.GT.RLOPT) THEN
22057 C...INSR(NOPT,1)=Gluon colour mother
22058 C...INSR(NOPT,2)=Gluon
22059 C...INSR(NOPT,3)=Gluon anticolour mother
22060 IF (NOPT.GT.1000) GOTO 470
22061 INSR(NOPT,1+2*MANTI)=IP2
22063 INSR(NOPT,3-2*MANTI)=IP1
22064 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
22066 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
22068 C...Reset link test information.
22069 DO 550 I=MINT(84)+1,N
22070 K(I,4)=MOD(K(I,4),MSTU(5)**2)
22071 K(I,5)=MOD(K(I,5),MSTU(5)**2)
22073 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
22075 C...Now we have a list of best gluon insertions, none of which cause
22076 C...singlets to arise. If list is empty, try again a few times. Note:
22077 C...this should never happen if we have a meson with a gluon inserted
22078 C...in the beam remnant, since that breaks up the colour line.
22079 IF (NOPT.EQ.0) THEN
22080 C...Abandon BR-g-BR suppression for retries. This is not serious, it
22081 C...just means we happened to start with trying a bad sequence.
22083 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
22084 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
22087 IF (ITJUNC(JS).NE.0) THEN
22091 C...Reset valence quark parent pointers
22092 DO 560 I=MINT(53)+1,N
22093 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
22096 C...Set (anti)colour mother = junction.
22098 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
22102 C...Same for mesons. JST unchanged, so needn't be restored.
22105 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
22106 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
22108 C...Also reset gluon parent pointers.
22110 DO 580 IM=1,NMI(JS)
22112 IF (K(I,2).EQ.21) THEN
22113 K(I,4)=MOD(K(I,4),MSTU(5))
22114 K(I,5)=MOD(K(I,5),MSTU(5))
22119 C...Reset colour tags
22120 DO 600 I=MINT(84)+1,N
22126 IF(NERRPR.LT.5) THEN
22129 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
22130 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
22132 C...Kill event and start another.
22137 C...Select between insertions, suppressing insertions wholly in the BR.
22139 610 IIN=MOD(IIN,NOPT)+1
22140 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
22141 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
22144 C...Now we know which gluon to insert where. Colour tags in JCCO and
22145 C...colour connection information should be updated, NG(JS) should be
22146 C...counted down, and a new loop performed if there are still gluons
22147 C...left on any side.
22151 C...JCG : Original gluon colour tag
22152 C...JCAG: Original gluon anticolour tag.
22153 C...JCM : Original anticolour tag of gluon colour mother
22154 C...JACM: Original colour tag of gluon anticolour mother
22160 CALL PYMIHG(JACM,JACG,JCM,JCG)
22161 IF (MACCPT.EQ.0) THEN
22162 IF(NERRPR.LT.5) THEN
22165 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
22166 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
22168 C...Kill event and start another.
22172 C...If everything went fine, store new JCCN in JCCO.
22175 JCCO(ICC,1)=JCCN(ICC,1)
22176 JCCO(ICC,2)=JCCN(ICC,2)
22180 C...One gluon attached is counted as equivalent to one end outside.
22182 C...Set IGL colour mother = ICM.
22183 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
22184 C...Set ICM anticolour mother = IGL colour.
22185 IF (K(ICM,2).NE.88) THEN
22186 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
22188 C...If ICM is junction, just update JST array for now.
22190 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
22193 C...Set IGL anticolour mother = IACM.
22194 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
22195 C...Set IACM anticolour mother = IGL anticolour.
22196 IF (K(IACM,2).NE.88) THEN
22197 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
22199 C...If IACM is junction, just update JST array for now.
22201 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
22204 C...Count down # unconnected gluons.
22207 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
22210 C...Collapse fictitious gluons.
22211 DO 670 IGL=MINT(53)+1,N
22212 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
22213 & K(IGL,1).EQ.14) THEN
22214 ICM=K(IGL,4)/MSTU(5)
22215 IAM=K(IGL,5)/MSTU(5)
22216 ICD=MOD(K(IGL,4),MSTU(5))
22217 IAD=MOD(K(IGL,5),MSTU(5))
22218 C...Set gluon daughters pointing to gluon mothers
22219 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
22220 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
22221 C...Set gluon mothers pointing to gluon daughters.
22222 IF (K(ICM,2).NE.88) THEN
22223 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
22225 C...Special case: mother=junction. Just update JST array for now.
22227 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
22230 IF (K(IAM,2).NE.88) THEN
22231 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
22234 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
22240 C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
22243 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
22244 IF (IM.GT.MINT(31)) THEN
22246 DO 690 IMR=IM,NMI(JS)
22247 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
22248 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
22253 C...Finally, connect junction.
22254 IF (ITJUNC(JS).NE.0) THEN
22255 DO 700 I=MINT(53)+1,N
22256 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
22258 C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
22263 C...Find jq with no glue inbetween inside beam remnant.
22264 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
22267 C...Set IDQ = -I if q non-valence and = +I if q valence.
22268 IDQ(NBRJQ)=-JST(JS,MSJ)
22270 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
22271 IDQ(NBRJQ)=JST(JS,MSJ)
22278 IF (MSJ.EQ.3) I45=4
22279 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
22282 C...Check if diquark can be formed.
22283 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
22285 C...If there is less than 2 valence quarks connected to junction
22286 C...and MSTP(88)>1, use random non-valence quarks to fill up.
22287 IF (NBRVQ.LE.1) THEN
22289 730 JFLIP=NBRJQ*PYR(0)+1
22290 IF (IDQ(JFLIP).LT.0) THEN
22291 IDQ(JFLIP)=-IDQ(JFLIP)
22294 IF (NDIQ.LE.1) GOTO 730
22296 C...Place selected quarks first in IDQ, ordered in flavour.
22298 IF (IDQ(JDQ).LE.0) THEN
22302 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
22309 C...Choose diquark spin.
22310 IF (NBRVQ.EQ.2) THEN
22311 C...If the selected quarks are both valence, we may use SU(6) rules
22312 C...to figure out which spin the diquark has, by a subdivision of the
22313 C...original beam hadron into the selected diquark system plus a kicked
22314 C...out quark, IKO.
22318 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
22322 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
22324 C...If one or more of the selected quarks are not valence, we cannot use
22325 C...SU(6) subdivisions of the original beam hadron. Instead, with the
22326 C...flavours of the diquark already selected, we assume for now
22327 C...50:50 spin-1:spin-0 (where spin-0 possible).
22328 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
22330 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
22331 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
22332 KFDQ=KFDQ+ISIGN(IS,KFDQ)
22335 C...Collapse diquark-j-quark system to baryon, if allowed and possible.
22336 C...Note: third quark can per definition not also be valence,
22337 C...therefore we can only do this if we are allowed to use sea quarks.
22338 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
22341 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
22342 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
22344 ELSEIF(NTRY.GT.100) THEN
22345 C...If no baryon can be found, give up and form diquark.
22349 C...Replace junction by baryon.
22352 K(IJU,3)=MINT(83)+JS
22355 P(IJU,5)=PYMASS(KFBAR)
22357 C...Prepare removal of participating quarks from ER.
22358 K(JST(JS,MSJ),1)=-1
22362 C...If collapse to baryon not possible or not allowed, replace junction
22363 C...by diquark. This way, collapsed gluons that were pointing at the
22364 C...junction will now point (correctly) at diquark.
22368 K(IJU,3)=MINT(83)+JS
22373 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
22375 K(IJU,5-MANTI)=IP*MSTU(5)
22376 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
22378 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
22380 C...Prepare removal of participating quarks from ER.
22386 C...Update so ER pointers to collapsed quarks
22387 C...now go to collapsed object.
22388 DO 820 I=MINT(84)+1,N
22389 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
22390 & .K(I,1).GT.0) THEN
22392 IMO=K(I,ISID)/MSTU(5)
22393 IDA=MOD(K(I,ISID),MSTU(5))
22395 IF (K(IMO,1).EQ.-1) IMO=IJU
22398 IF (K(IDA,1).EQ.-1) IDA=IJU
22400 K(I,ISID)=IDA+MSTU(5)*IMO
22407 C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
22408 C...(this only happens for baryons, where we want to force the gluon
22409 C...to sit next to the junction. Mesons handled above.)
22410 IF (NBRTOT(JS).EQ.0) THEN
22420 K(IGL,3)=MINT(83)+JS
22421 IF (ITJUNC(JS).NE.0) THEN
22422 C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
22423 JLEG=PYR(0)*NVSUM(JS)+1
22426 JCT=MCT(I1,ITJUNC(JS))
22427 MCT(IGL,3-ITJUNC(JS))=JCT
22429 MCT(IGL,ITJUNC(JS))=NCT
22432 C...Meson. Should not happen.
22433 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
22434 IF(NERRPR.LT.5) THEN
22435 WRITE(MSTU(11),*) 'This should not have been possible!'
22442 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
22443 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
22444 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
22445 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
22446 IF (K(I2,2).NE.88) THEN
22447 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
22449 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
22450 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
22451 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
22452 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
22454 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
22460 C...Remove collapsed quarks and junctions from ER and update IMI.
22463 C...Also update beam remnant part of IMI.
22466 DO 850 I=MINT(53)+1,N
22467 IF (K(I,1).LE.0) GOTO 850
22468 C...Restore BR quark/diquark/baryon pointers in IMI.
22469 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
22472 IMI(JS,NMI(JS),1)=I
22473 IMI(JS,NMI(JS),2)=0
22477 C...Restore companion information from collapsed gluons.
22478 DO 870 I=MINT(53)+1,N
22479 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
22481 JCD=MOD(K(I,4),MSTU(5))
22482 JAD=MOD(K(I,5),MSTU(5))
22483 DO 860 IM=1,NMI(JS)
22484 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
22485 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
22487 IMI(JS,IMC,2)=IMI(JS,IMA,1)
22488 IMI(JS,IMA,2)=IMI(JS,IMC,1)
22492 C...Renumber colour lines (since some have disappeared)
22500 IF (MFOUND.EQ.0) JCD=JCD+1
22501 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
22504 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
22508 IF (I.LE.N) GOTO 890
22509 IF (JCT.LT.NCT) GOTO 880
22512 C...Reset hard interaction subsystems to their CM frames.
22513 IF (IBOOST.EQ.1) THEN
22514 DO 900 IM=1,MINT(31)
22515 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22516 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
22518 C...Zero beam remnant longitudinal momenta and energies
22519 DO 910 I=MINT(53)+1,N
22525 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
22526 C...Kill event and start another.
22533 C*********************************************************************
22536 C...Adapted from PYPREP.
22537 C...Assigns LHA1 colour tags to coloured partons based on
22538 C...K(I,4) and K(I,5) colour connection record.
22539 C...KCS negative signifies that a previous tracing should be continued.
22540 C...(in case the tag to be continued is empty, the routine exits)
22541 C...Starts at I and ends at I or IEND.
22542 C...Special considerations for systems with junctions.
22543 C...Special: if IEND=-1, means trace this parton to its color partner,
22544 C... then exit. If no partner found, exit with 0.
22546 SUBROUTINE PYCTTR(I,KCS,IEND)
22547 C...Double precision and integer declarations.
22548 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22549 INTEGER PYK,PYCHGE,PYCOMP
22551 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22552 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22553 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22554 COMMON/PYINT1/MINT(400),VINT(400)
22555 C...The common block of colour tags.
22556 COMMON/PYCTAG/NCT,MCT(4000,2)
22557 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
22561 C...Skip if parton not existing or does not have KCS
22562 IF (K(I,1).LE.0) GOTO 120
22564 IF (KC.EQ.0) GOTO 120
22566 IF (KQ.EQ.0) GOTO 120
22567 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
22572 C...Set colour tag of first parton.
22578 IF (NCS.EQ.0) GOTO 120
22584 IF(NSTP.GT.4*N) THEN
22585 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
22589 C...Finished if reached final-state triplet.
22590 IF(K(IA,1).EQ.3) THEN
22591 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
22594 C...Also finished if reached junction.
22595 IF(K(IA,1).EQ.42) THEN
22599 C...GOTO next parton in colour space.
22601 C...If IB's KCS daughter not traced and exists, goto KCS daughter.
22602 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
22604 IA=MOD(K(IB,KCS),MSTU(5))
22605 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
22608 C...If KCS mother traced or KCS mother nonexistent, switch colour.
22609 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
22610 & MSTU(5)).EQ.0) THEN
22614 C...Assign new colour tag on other side of old parton.
22617 C...Goto (new) KCS mother, set mother traced tag
22618 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
22619 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
22622 IF(IA.LE.0.OR.IA.GT.N) THEN
22623 IF (IEND.EQ.-1) THEN
22627 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
22628 IF(NERRPR.LT.5) THEN
22629 write(*,*) 'began at ',I
22630 write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
22631 & ' NCS=',NCS,' MREV=',MREV
22638 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
22639 & MSTU(5)).EQ.IB) THEN
22640 IF(MREV.EQ.1) KCS=9-KCS
22641 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
22642 C...Set KSC mother traced tag for IA
22643 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
22645 IF(MREV.EQ.0) KCS=9-KCS
22646 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
22647 C...Set KCS daughter traced tag for IA
22648 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
22650 C...Assign new colour tag
22652 C...Finish if IEND=-1 and found final-state color partner
22653 IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN
22657 IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100
22662 *********************************************************************
22665 C...Collapse JCP1 and connecting tags to JCG1.
22666 C...Collapse JCP2 and connecting tags to JCG2.
22668 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
22669 C...Double precision and integer declarations.
22670 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22671 IMPLICIT INTEGER(I-N)
22672 INTEGER PYK,PYCHGE,PYCOMP
22673 C...The event record
22674 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22676 COMMON/PYINT1/MINT(400),VINT(400)
22677 SAVE /PYJETS/,/PYINT1/
22678 C...Local variables
22679 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
22680 COMMON /PYCTAG/NCT,MCT(4000,2)
22681 SAVE /PYCBLS/,/PYCTAG/
22683 C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
22684 C...in temporary tag collapse array JCCN. Only break up one connection.
22688 JCCN(ICC,1)=JCCO(ICC,1)
22689 JCCN(ICC,2)=JCCO(ICC,2)
22690 C...If there was a mother, it was previously connected to JCP1.
22691 C...Should be changed to JCP2.
22692 IF (MCLPS.EQ.0) THEN
22693 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
22695 JCCN(ICC,1)=MAX(JCG2,JCP2)
22696 JCCN(ICC,2)=MIN(JCG2,JCP2)
22701 C...Also collapse colours on JCP1 side of JCG1
22702 IF (JCP1.NE.0) THEN
22703 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
22704 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
22706 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
22707 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
22710 C...Initialize event record colour tag array MCT array to MCO.
22711 DO 110 I=MINT(84)+1,N
22717 C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
22718 C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
22719 C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
22720 C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
22722 C...Skip if junction.
22723 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
22724 C...Define starting point in tag space.
22725 C...JCA = previous tag
22726 C...JCO = present tag
22728 IF (MOD(IS,2).EQ.1) THEN
22732 ELSEIF (MOD(IS,2).EQ.0) THEN
22738 120 ITRACE=ITRACE+1
22739 IF (ITRACE.GT.1000) THEN
22740 C...NB: Proper error message should be defined here.
22742 & ,'(PYMIHG:) Inf loop when collapsing colours.')
22743 MINT(57)=MINT(57)+1
22747 C...Collapse all JCN tags to JCALL
22748 DO 130 I=MINT(84)+1,N
22749 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22750 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22752 C...IS = 1,2: first step forward. IS = 3,4: first step backward.
22753 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
22760 C...If possible, step from JCO to new tag JCN not equal to JCA.
22762 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
22764 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
22767 C...Iterate if new colour was arrived at, but don't go in circles.
22768 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
22769 C...Change all JCN tags in MCO to JCALL in MCT.
22770 DO 150 I=MINT(84)+1,N
22771 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22772 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22773 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22774 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22779 DO 200 JCL=NCT,1,-1
22784 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
22786 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
22789 C...Overpaint all JCN with JCL
22790 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
22791 DO 190 I=MINT(84)+1,N
22792 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
22793 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
22794 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22795 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22806 C*********************************************************************
22809 C...Picks primordial kT and shares longitudinal momentum among
22814 C...Double precision and integer declarations.
22815 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22816 IMPLICIT INTEGER(I-N)
22817 INTEGER PYK,PYCHGE,PYCOMP
22818 C...The event record
22819 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22821 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22822 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22823 COMMON/PYINT1/MINT(400),VINT(400)
22824 C...The common block of colour tags.
22825 COMMON/PYCTAG/NCT,MCT(4000,2)
22826 C...The common block of dangling ends
22827 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
22828 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
22829 & XMI(2,240),PT2MI(240),IMISEP(0:240)
22830 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
22831 C...Local variables
22832 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
22833 C...W(I,J)| J=0 | 1 | 2 |
22834 C... I=0 | Wrem**2 | W+ | W- |
22835 C... 1 | W1**2 | W1+ | W1- |
22836 C... 2 | W2**2 | W2+ | W2- |
22838 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)
22839 C...Tentative parametrization of <kT> as a function of Q.
22840 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
22841 C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
22842 C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
22843 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
22844 C...Lambda kinematic function.
22845 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
22847 C...Beginning and end of beam remnant partons
22851 C...Loopback point if kinematic choices gives impossible configuration.
22855 C...Assign kT values on each side separately.
22858 C...First zero all kT on this side. Skip if no kT to generate.
22859 DO 110 IM=1,NMI(JS)
22860 P(IMI(JS,IM,1),1)=0D0
22861 P(IMI(JS,IM,1),2)=0D0
22863 IF(MSTP(91).LE.0) GOTO 180
22865 C...Now assign kT to each (non-collapsed) parton in IMI.
22866 DO 170 IM=1,NMI(JS)
22868 C...Select kT according to truncated gaussian or 1/kt6 tails.
22869 C...For first interaction, either use rms width = PARP(91) or fitted.
22872 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
22877 C...For subsequent interactions and BR partons use fragmentation width.
22882 IF(NTRY.LE.100) THEN
22883 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
22887 ELSEIF (MSTP(91).EQ.2) THEN
22888 CALL PYERRM(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
22889 & 'available, using MSTP(91)=1.')
22890 CALL PYGIVE('MSTP(91)=1')
22892 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
22893 C...Use distribution with kt**6 tails, rms width = PARP(91).
22894 EPS=SQRT(3D0/2D0)*SIGMA
22895 C...Generate PTX and PTY separately, each propto 1/KT**6
22897 C...Decide which interval to try
22898 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
22899 IF (PYR(0).LT.P12) THEN
22900 C...Use flat approx with accept/reject up to EPS.
22902 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
22903 IF (PYR(0).GT.WT) GOTO 112
22905 C...Above EPS, use 1/kt**6 approx with accept/reject.
22906 PT=EPS/(PYR(0)**(1D0/5D0))
22907 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
22908 IF (PYR(0).GT.WT) GOTO 112
22911 IF (PYR(0).GT.0.5D0) MSIGN=-1
22912 IF (IXY.EQ.1) PTX=MSIGN*PT
22913 IF (IXY.EQ.2) PTY=MSIGN*PT
22915 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
22916 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22917 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22919 C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
22920 PT=SQRT(PTX**2+PTY**2)
22922 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
22923 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
22926 PT=SQRT(PTX**2+PTY**2)
22932 C...Compensation kicks, with varying degree of local anticorrelations.
22934 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
22935 PTCX=-PTX/(NMI(JS)-1)
22936 PTCY=-PTY/(NMI(JS)-1)
22937 IF(ISUB.EQ.95) THEN
22938 PTCX=-PTX/(NMI(JS)-2)
22939 PTCY=-PTY/(NMI(JS)-2)
22941 DO 120 IMC=1,NMI(JS)
22942 IF (IMC.EQ.IM) GOTO 120
22943 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
22944 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
22945 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
22947 ELSEIF (MCORR.GE.1) THEN
22950 C...Count up # of neighbours on either side
22952 130 IMO=K(IMO,MSID)/MSTU(5)
22953 IF (IMO.EQ.0) GOTO 140
22954 NNXT(MSID-3)=NNXT(MSID-3)+1
22955 C...Stop at quarks and junctions
22956 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
22958 C...How should compensation be shared when unequal numbers on the
22959 C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
22960 NSUM=NNXT(1)+NNXT(2)
22963 C...Total momentum to be compensated on this side
22964 IF (NNXT(MSID-3).EQ.0) GOTO 160
22965 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
22966 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
22967 C...RS: compensation supression factor as we go out from parton I.
22968 C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
22969 C...since (for now) MSTP(90) provides enough variability.
22971 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
22974 IMO=K(IMO,MSID)/MSTU(5)
22975 IF (IMO.EQ.0) GOTO 160
22977 IF (K(IMO,2).NE.88) THEN
22978 P(IMO,1)=P(IMO,1)+FAC*PTCX
22979 P(IMO,2)=P(IMO,2)+FAC*PTCY
22980 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
22981 C...If we reach junction, divide out the kT that would have been
22982 C...assigned to the junction on each of its other legs.
22984 L1=MOD(K(IMO,4),MSTU(5))
22985 L2=K(IMO,5)/MSTU(5)
22986 L3=MOD(K(IMO,5),MSTU(5))
22987 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
22988 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
22989 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
22990 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
22991 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
22992 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
22993 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
22994 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
23000 C...End assignment of kT values to initiators and remnants.
23003 C...Check kinematics constraints for non-BR partons.
23004 DO 190 IM=1,MINT(31)
23005 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
23006 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
23007 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
23008 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
23009 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
23010 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
23011 IF(NTRY.GE.100) THEN
23012 C...Kill this event and start another.
23014 & '(PYMIRM:) No consistent (x,kT) sets found')
23022 C...Calculate W+ and W- available for combined remnant system.
23025 DO 200 IM=1,MINT(31)
23026 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
23027 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
23028 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
23029 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
23030 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
23032 C...Also store Wrem**2 = W+ * W-
23033 W(0,0)=W(0,1)*W(0,2)
23035 IF ((W(0,0).LT.0D0.OR.W(0,1)+W(0,2).LT.0D0).AND.NTRY.LE.100) THEN
23036 IF(NTRY.GE.100) THEN
23037 C...Kill this event and start another.
23039 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
23046 C...Assign unscaled x values to partons/hadrons in each of the
23047 C...beam remnants and calculate unscaled W+ and W- from them.
23053 DO 270 IM=MINT(31)+1,NMI(JS)
23059 C...Skip collapsed gluons and junctions. Reset.
23060 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
23061 IF (KFA.EQ.88) GOTO 270
23068 C...If gluon then only beam remnant, so takes all.
23071 C...If valence quark then use parametrized valence distribution.
23072 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
23074 C...If companion quark then derive from companion x.
23075 ELSEIF(KFA.LE.6) THEN
23077 C...If valence diquark then use two parametrized valence distributions.
23078 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23080 IVALQ(1)=ISIGN(KFA/1000,KF)
23081 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
23082 C...If valence+sea diquark then combine valence + companion choices.
23083 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23084 & ICOMP.LT.MSTU(5)) THEN
23085 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
23086 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
23088 IVALQ(1)=ISIGN(KFA/1000,KF)
23091 C...Extra code: workaround for diquark made out of two sea
23092 C...quarks, but where not (yet) ICOMP > MSTU(5).
23093 DO 220 IM1=1,MINT(31)
23094 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
23095 ICOMQ(2)=IMI(JS,IM1,1)
23099 C...If sea diquark then sum of two derived from companion x.
23100 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
23101 ICOMQ(1)=MOD(ICOMP,MSTU(5))
23102 ICOMQ(2)=ICOMP/MSTU(5)
23103 C...If meson or baryon then use fragmentation function.
23104 C...Somewhat arbitrary split into old and new flavour, but OK normally.
23106 KFL3=MOD(KFA/10,10)
23107 IF(MOD(KFA/1000,10).EQ.0) THEN
23108 KFL1=MOD(KFA/100,10)
23110 KFL1=MOD(KFA,10000)-10*KFL3-1
23111 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
23112 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
23114 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
23115 CALL PYZDIS(KFL1,KFL3,PR,X)
23119 C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
23120 C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
23121 C...In other baryons combine u and d from proton appropriately.
23122 IF(IVALQ(IQ).NE.0) THEN
23124 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
23125 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
23126 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
23128 IF(KFIVAL(JS,3).EQ.0) THEN
23130 C...Baryon with three identical quarks: mix u and d forms.
23131 ELSEIF(NVAL.EQ.3) THEN
23132 MDU=INT(PYR(0)+5D0/3D0)
23133 C...Baryon, one of two identical quarks: u form.
23134 ELSEIF(NVAL.EQ.2) THEN
23136 C...Baryon with two identical quarks, but not the one picked: d form.
23137 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
23138 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
23140 C...Baryon with three nonidentical quarks: mix u and d forms.
23142 MDU=INT(PYR(0)+5D0/3D0)
23145 IF(MDU.EQ.1) XPOW=3.5D0
23146 IF(MDU.EQ.2) XPOW=2D0
23148 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
23152 C...Calculation of x of companion quark.
23153 IF(ICOMQ(IQ).NE.0) THEN
23155 DO 240 IM1=1,MINT(31)
23156 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
23158 NPOW=MAX(0,MIN(4,MSTP(87)))
23159 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
23160 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
23161 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
23162 IF(CORR.LT.PYR(0)) GOTO 250
23167 C...Optionally enchance x of composite systems (e.g. diquarks)
23168 IF (KFA.GT.100) X=PARP(79)*X
23170 C...Store x. Also calculate light cone energies of each system.
23172 W(JS,JS)=W(JS,JS)+X
23173 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
23175 W(JS,JS)=W(JS,JS)*W(0,JS)
23176 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
23177 W(JS,0)=W(JS,1)*W(JS,2)
23180 C...Check W1 W2 < Wrem (can be done before rescaling, since W
23181 C...insensitive to global rescalings of the BR x values).
23182 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
23185 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
23187 ELSEIF (NTRYX.GT.100) THEN
23188 CALL PYERRM(1,'(PYMIRM:) No consistent (x,kT) sets found')
23189 MINT(57)=MINT(57)+1
23194 C...Compute x rescaling factors
23195 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
23196 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
23197 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
23199 IF (R1.LT.0.OR.R2.LT.0) THEN
23200 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
23201 MINT(57)=MINT(57)+1
23205 C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
23211 C...Rescale BR x values.
23212 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
23213 XMI(1,IM)=XMI(1,IM)*R1
23214 XMI(2,IM)=XMI(2,IM)*R2
23217 C...Now we have a consistent set of x and kT values.
23218 C...First set up the initiators and their daughters correctly.
23219 DO 300 IM=1,MINT(31)
23222 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
23223 & (P(I1,2)+P(I2,2))**2
23224 PT12=P(I1,1)**2+P(I1,2)**2
23225 PT22=P(I2,1)**2+P(I2,2)**2
23227 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
23229 C...Energies (masses should be zero at this stage)
23230 P(I1,4)=SQRT(PT12+P(I1,3)**2)
23231 P(I2,4)=SQRT(PT22+P(I2,3)**2)
23233 C...Transverse 12 system initiator velocity:
23234 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
23235 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
23236 C...Boost to overall initiator system rest frame
23237 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
23238 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
23240 C...Compute phi,theta coordinates of I1 and rotate z axis.
23241 PHI=PYANGL(P(I1,1),P(I1,2))
23242 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
23243 IMIN=IMISEP(IM-1)+1
23244 C...(include documentation lines if MI = 1)
23245 IF (IM.EQ.1) IMIN=MINT(83)+5
23247 C...Rotate entire system in phi
23248 CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
23249 C...Only rotate 12 system in theta
23250 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
23251 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
23253 C...Now boost entire system back to LAB
23254 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
23255 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
23256 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
23261 C...For the beam remnant partons/hadrons, we only need to set pz and E.
23263 DO 310 IM=MINT(31)+1,NMI(JS)
23265 C...Skip collapsed gluons and junctions.
23266 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
23267 IF (KFA.EQ.88) GOTO 310
23268 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
23269 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
23270 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
23271 IF (JS.EQ.2) P(I,3)=-P(I,3)
23276 C...Documentation lines
23282 K(IN,3)=MINT(83)+JS
23289 MCT(IN,1)=MCT(IO,1)
23290 MCT(IN,2)=MCT(IO,2)
23293 C...Final state colour reconnections.
23294 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
23296 C...Number of colour tags for which a recoupling will be tried.
23298 C...Number of recouplings to try
23306 IF (IITER.LE.PARP(78)*NTOT) THEN
23307 C...Select two colour tags at random
23308 C...NB: jj strings do not have colour tags assigned to them,
23309 C...thus they are as yet not affected by anything done here.
23311 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
23316 C...Find final state partons with this (anti)colour
23317 DO 370 I=MINT(84)+1,N
23318 IF (K(I,1).EQ.3) THEN
23319 IF (MCT(I,1).EQ.JCT) IJ1=I
23320 IF (MCT(I,2).EQ.JCT) IJ2=I
23321 IF (MCT(I,1).EQ.KCT) IK1=I
23322 IF (MCT(I,2).EQ.KCT) IK2=I
23325 C...Only consider recouplings not involving junctions for now.
23326 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
23328 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
23329 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
23330 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
23333 C...Count up number of reconnections
23334 MINT(34)=MINT(34)+1
23336 IF (MINT(34).LE.1000) THEN
23339 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
23343 IF (NRECP.LT.MINT(34)) GOTO 350
23345 C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
23351 C*********************************************************************
23354 C...Performs colour annealing.
23355 C...MSTP(95) : CR Type
23356 C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
23357 C... = 2 : Type I(no gg loops); hadron-hadron only
23358 C... = 3 : Type I(no gg loops); all beams
23359 C... = 4 : Type II(gg loops) ; hadron-hadron only
23360 C... = 5 : Type II(gg loops) ; all beams
23361 C... = 6 : Type S ; hadron-hadron only
23362 C... = 7 : Type S ; all beams
23363 C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
23364 C...Type S is driven by starting only from free triplets, not octets.
23365 C...A string piece remains unchanged with probability
23366 C... PKEEP = (1-PARP(78))**N
23367 C...This scaling corresponds to each string piece having to go through
23368 C...N other ones, each with probability PARP(78) for reconnection, where
23369 C...N is here chosen simply as the number of multiple interactions,
23370 C...for a rough scaling with the general level of activity.
23372 SUBROUTINE PYFSCR(IP)
23373 C...Double precision and integer declarations.
23374 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23375 INTEGER PYK,PYCHGE,PYCOMP
23377 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23378 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23379 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23380 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23381 COMMON/PYINT1/MINT(400),VINT(400)
23382 C...The common block of colour tags.
23383 COMMON/PYCTAG/NCT,MCT(4000,2)
23384 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
23386 C...MCN: Temporary storage of new colour tags
23387 INTEGER MCN(4000,2)
23388 C...Arrays for storing color string lengths
23389 INTEGER ICR(4000),MSCR(4000)
23391 DOUBLE PRECISION RLOPTC(4000)
23393 C...Function to give four-product.
23394 FOUR(I,J)=P(I,4)*P(J,4)
23395 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
23397 C...Check valid range of MSTP(95), local copy
23398 IF (MSTP(95).LE.1.OR.MSTP(95).GE.10) RETURN
23399 MSTP95=MOD(MSTP(95),10)
23400 C...Set whether CR allowed inside resonance systems or not
23401 C...(not implemented yet)
23403 C IF (MSTP(95).GE.10) MRESCR=0
23405 C...Check whether colour tags already defined
23406 IF (MINT(33).EQ.0) THEN
23407 C...Erase any existing colour tags for this event
23412 C...Create colour tags for this event
23414 IF (K(I,1).EQ.3) THEN
23417 IF (MCT(I,KCSIN-3).EQ.0) THEN
23418 CALL PYCTTR(I,KCSIN,I)
23423 C...Instruct PYPREP to use colour tags
23427 C...For MSTP(95) even, only apply to hadron-hadron
23430 IF (MOD(MSTP(95),2).EQ.0.AND.(KA1.LT.100.OR.KA2.LT.100)) GOTO 9999
23432 C...Initialize new tag array (but do not delete old yet)
23434 DO 130 I=MAX(1,IP),N
23439 C...For each final-state dipole, check whether string should be
23448 DO 140 I=MAX(1,IP),N
23449 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
23450 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
23452 IF (IC.NE.0.AND.IA.NE.0) THEN
23454 C...Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
23455 C...(so far ignores the possibility that the whole "muck" may be moving.)
23456 IF (PARP(77).GT.0D0) THEN
23457 PT2STR=(P(IA,1)+P(IC,1))**2+(P(IA,2)+P(IC,2))**2
23458 C...For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
23459 IF (KA1.LT.100.AND.KA2.LT.100) THEN
23460 P2STR = PT2STR + (P(IA,3)+P(IC,3))**2
23462 P2STR = 3D0/2D0 * PT2STR
23464 RM2STR=(P(IA,4)+P(IC,4))**2-(P(IA,3)+P(IC,3))**2-PT2STR
23465 RM2STR=MAX(RM2STR,PMAS(PYCOMP(111),1)**2)
23466 C...Estimate number of particles ~ log(M2), cut off at 1.
23467 RLOGM2=MAX(1D0,LOG(RM2STR))
23469 C...Supress reconnection probability by 1/(1+P77*P2AVG)
23470 CRMODF=1D0/(1D0+PARP(77)**2*P2AVG)
23472 PKEEP=(1D0-PARP(78)*CRMODF)**MINT(31)
23473 IF (PYR(0).LE.PKEEP) THEN
23478 C...Add coloured parton
23484 C...Add anti-coloured parton
23494 C...Skip if there is only one possibility
23499 C...Reorder, so ordered in I (in order to correspond to old algorithm)
23510 MSCR(IC1)=MSCR(IC1+1)
23516 C...Max do 1000 reordering loops
23517 IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 151
23519 C...Loop over CR partons
23520 C...(Ignore junctions for now.)
23525 C...Loop over coloured partons
23527 C...Retrieve parton Event Record index and Colour Side
23530 C...Skip already connected partons
23531 IF (MCN(I,MSI).NE.0) GOTO 230
23532 C...Shorthand for colour charge
23533 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
23534 C...For Seattle algorithm, only start from partons with one dangling
23536 IF (MSTP(95).GE.6.AND.MSTP(95).LE.9) THEN
23537 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
23539 C...Retrieve saved optimal partner
23542 C...Reject saved optimal partner if latter is now connected
23543 C...(Also reject if using model S1, since saved partner may
23544 C...now give rise to gg loop.)
23545 IF (MCN(IO,3-MSI).NE.0.OR.MSTP(95).LE.3) THEN
23551 C...Search for new optimal partner if necessary
23552 IF (IOPT(IC1).EQ.0) THEN
23556 C...Loop over partons you can connect to
23560 C...Skip if already connected
23561 IF (MCN(J,MSJ).NE.0) GOTO 210
23562 C...Skip if this not colour-anticolour pair
23563 IF (MSI.EQ.MSJ) GOTO 210
23564 C...And do not let gluons connect to themselves
23565 IF (I.EQ.J) GOTO 210
23566 C...Suppress direct connections between partons in same Beam Remnant
23568 IF (K(I,3).LE.2.AND.K(I,3).GE.1.AND.K(I,3).EQ.K(J,3))
23570 C...Shorthand for colour charge
23571 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
23572 C...Check for gluon loops
23574 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
23575 IF (MCN(I,2).EQ.MCN(J,1).AND.MSTP(95).LE.3.AND.
23576 & MCN(I,2).NE.0) MGGSTR=1
23578 C...Save connection with smallest lambda measure
23580 C...Optional: Seattle v2: multiply gluons by 1/2 since two strings connected
23581 IF (MSTP(95).GE.7.AND.MSTP(95).LE.8) THEN
23582 IF (K(I,2).EQ.21) RL=0.5D0*RL
23583 IF (K(J,2).EQ.21) RL=0.5D0*RL
23585 C...If best so far was a BR string and this is not, also save.
23586 C...If best so far was a gg string and this is not, also save.
23587 C...NB: this is not fool-proof. If the algorithm finds a BR or gg
23588 C...string with a small Lambda measure as the last step, this connection
23589 C...will be saved regardless of whether other possibilities existed.
23590 C...I.e., there should really be a check whether another possibility has
23591 C...already been found, but since these models are now actively in use
23592 C...and uncertainties are anyway large, the algorithm is left as it is.
23593 C...(correction --> Pythia 8 ?)
23594 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
23595 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
23596 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
23605 IF (IOPT(IC1).NE.0) THEN
23606 C...Save pair with largest RLOPT so far
23607 IF (RLOPT.GE.RLMAX) THEN
23613 C...Save and iterate
23614 IF (ICRMAX.GT.0) THEN
23620 MCN(ILMAX,ICMAX)=LCT
23621 MCN(JLMAX,JCMAX)=LCT
23622 IF (NLOOP.LE.2*(N-IP)) THEN
23625 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
23629 C...Save and exit. First check for leftover gluon(s)
23630 DO 260 I=MAX(1,IP),N
23631 C...Check colour charge
23632 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
23633 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
23634 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
23635 C...Decide where to put left-over gluon (minimal insertion)
23638 DO 250 KCT=NCT+1,LCT
23639 DO 240 IT=MAX(1,IP),N
23640 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
23641 IF (MCN(IT,1).EQ.KCT) IC=IT
23642 IF (MCN(IT,2).EQ.KCT) IA=IT
23644 RL=FOUR(IC,I)*FOUR(IA,I)
23645 IF (RL.LT.RLMAX) THEN
23652 MCN(I,1)=MCN(ICMAX,1)
23657 C...Here we need to loop over entire event.
23658 DO 270 IZ=MAX(1,IP),N
23659 C...Do not erase parton shower colour history
23660 IF (K(IZ,1).NE.3) GOTO 270
23661 C...Check colour charge
23662 MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2))
23663 IF (MCI.EQ.0) GOTO 270
23664 IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1)
23665 IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2)
23672 C*********************************************************************
23675 C...Handles diffractive and elastic scattering.
23679 C...Double precision and integer declarations.
23680 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23681 IMPLICIT INTEGER(I-N)
23682 INTEGER PYK,PYCHGE,PYCOMP
23684 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23685 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23686 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23687 COMMON/PYINT1/MINT(400),VINT(400)
23688 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
23690 C...Reset K, P and V vectors. Store incoming particles.
23691 DO 110 JT=1,MSTP(126)+10
23711 P(I,J)=VINT(285+5*JT+J)
23716 C...Subprocess; kinematics.
23717 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
23718 PZ=SQRT(SQLAM)/(2D0*VINT(1))
23721 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
23724 C...Elastically scattered particle. (Except elastic GVMD states.)
23725 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
23726 & MINT(106+JT).NE.3)) THEN
23731 P(N,3)=PZ*(-1)**(JT+1)
23733 P(N,5)=SQRT(VINT(62+JT))
23735 C...Decay rho from elastic scattering of gamma with sin**2(theta)
23736 C...distribution of decay products (in rho rest frame).
23737 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
23739 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
23743 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
23744 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
23745 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
23746 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
23747 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
23748 140 CTHE=2D0*PYR(0)-1D0
23749 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
23750 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
23752 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
23755 C...Diffracted particle: low-mass system to two particles.
23756 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
23762 PMMAS=SQRT(VINT(62+JT))
23765 IF(NTRY.LT.20) THEN
23766 MINT(105)=MINT(102+JT)
23767 MINT(109)=MINT(106+JT)
23768 CALL PYSPLI(KFH,21,KFL1,KFL2)
23769 CALL PYKFDI(KFL1,0,KFL3,KF1)
23770 IF(KF1.EQ.0) GOTO 150
23771 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
23772 IF(KF2.EQ.0) GOTO 150
23779 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
23784 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
23785 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
23788 P(N-1,4)=SQRT(PM1**2+PZP**2)
23789 P(N,4)=SQRT(PM2**2+PZP**2)
23790 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
23792 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
23793 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
23795 C...Diffracted particle: valence quark kicked out.
23796 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
23803 MINT(105)=MINT(102+JT)
23804 MINT(109)=MINT(106+JT)
23805 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
23806 P(N-1,5)=PYMASS(K(N-1,2))
23807 P(N,5)=PYMASS(K(N,2))
23808 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
23809 & 4D0*P(N-1,5)**2*P(N,5)**2
23810 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
23811 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
23812 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
23813 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
23814 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23816 C...Diffracted particle: gluon kicked out.
23825 MINT(105)=MINT(102+JT)
23826 MINT(109)=MINT(106+JT)
23827 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
23829 P(N-2,5)=PYMASS(K(N-2,2))
23831 P(N,5)=PYMASS(K(N,2))
23832 C...Energy distribution for particle into two jets.
23834 IF(MOD(KFH/1000,10).NE.0) IMB=2
23835 CHIK=PARP(92+2*IMB)
23836 IF(MSTP(92).LE.1) THEN
23837 IF(IMB.EQ.1) CHI=PYR(0)
23838 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23839 ELSEIF(MSTP(92).EQ.2) THEN
23840 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
23841 ELSEIF(MSTP(92).EQ.3) THEN
23842 CUT=2D0*0.3D0/VINT(1)
23844 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
23846 ELSEIF(MSTP(92).EQ.4) THEN
23847 CUT=2D0*0.3D0/VINT(1)
23848 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
23849 180 CHIR=CUT*CUTR**PYR(0)
23850 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
23851 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
23853 CUT=2D0*0.3D0/VINT(1)
23854 CUTA=CUT**(1D0-PARP(98))
23855 CUTB=(1D0+CUT)**(1D0-PARP(98))
23856 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
23857 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
23858 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
23860 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
23861 & VINT(62+JT)) GOTO 160
23862 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
23863 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
23864 & (2D0*VINT(62+JT))
23865 PEI=SQRT(PZI**2+SQM)
23866 PQQP=(1D0-CHI)*(PEI+PZI)
23867 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
23868 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
23869 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
23870 P(N-1,3)=P(N-1,4)*(-1)**JT
23871 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
23872 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23875 C...Documentation lines.
23877 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
23878 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
23879 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
23881 P(I+2,3)=PZ*(-1)**(JT+1)
23883 P(I+2,5)=SQRT(VINT(62+JT))
23886 C...Rotate outgoing partons/particles using cos(theta).
23887 IF(VINT(23).LT.0.9D0) THEN
23888 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
23890 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
23896 C*********************************************************************
23899 C...Set up a DIS process as gamma* + f -> f, with beam remnant
23900 C...and showering added consecutively. Photon flux by the PYGAGA
23901 C...routine (if at all).
23905 C...Double precision and integer declarations.
23906 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23907 IMPLICIT INTEGER(I-N)
23908 INTEGER PYK,PYCHGE,PYCOMP
23909 C...Parameter statement to help give large particle numbers.
23910 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23911 &KEXCIT=4000000,KDIMEN=5000000)
23913 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23914 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23915 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23916 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23917 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23918 COMMON/PYINT1/MINT(400),VINT(400)
23919 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
23923 C...Choice of subprocess, number of documentation lines
23931 IF(MINT(107).EQ.4) ISIDE=2
23933 C...Reset K, P and V vectors. Store incoming particles
23934 DO 110 JT=1,MSTP(126)+20
23947 P(I,J)=VINT(285+5*JT+J)
23952 C...Store incoming partons in hadronic CM-frame
23957 K(I,3)=MINT(83)+2+JT
23959 IF(MINT(15).EQ.22) THEN
23960 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
23961 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
23962 P(MINT(84)+1,5)=-SQRT(VINT(307))
23963 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
23964 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
23968 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
23969 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
23970 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
23971 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
23972 P(MINT(84)+1,5)=-SQRT(VINT(308))
23976 SIDESG=(-1D0)**(ISIDE-1)
23978 C...Copy incoming partons to documentation lines.
23989 C...Second copy for partons before ISR shower, since no such.
23999 C...Define initial partons.
24002 IF(NTRY.GT.100) THEN
24007 C...Scattered quark in hadronic CM frame.
24012 P(IPU3,5)=PYMASS(KFRES)
24013 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
24014 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
24018 K(I,3)=MINT(83)+4+ISIDE
24026 C...No primordial kT, or chosen according to truncated Gaussian or
24027 C...exponential, or (for photon) predetermined or power law.
24028 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
24029 IF(MSTP(91).LE.0) THEN
24031 ELSEIF(MSTP(91).EQ.1) THEN
24032 PT=PARP(91)*SQRT(-LOG(PYR(0)))
24036 PT=-PARP(92)*LOG(RPT1*RPT2)
24038 IF(PT.GT.PARP(93)) GOTO 190
24039 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
24040 PTA=SQRT(VINT(282+ISIDE))
24042 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
24043 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
24044 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
24047 PTB=-PARP(99)*LOG(RPT1*RPT2)
24049 IF(PTB.GT.PARP(100)) GOTO 190
24050 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
24051 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
24052 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
24053 IF(MSTP(93).LE.0) THEN
24055 ELSEIF(MSTP(93).EQ.1) THEN
24056 PT=PARP(99)*SQRT(-LOG(PYR(0)))
24057 ELSEIF(MSTP(93).EQ.2) THEN
24060 PT=-PARP(99)*LOG(RPT1*RPT2)
24061 ELSEIF(MSTP(93).EQ.3) THEN
24064 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
24068 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
24069 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
24071 IF(PT.GT.PARP(100)) GOTO 190
24077 P(IPU3,1)=PT*COS(PHI)
24078 P(IPU3,2)=PT*SIN(PHI)
24079 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
24080 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
24081 PCP=P(IPU3,4)+ABS(P(IPU3,3))
24083 C...Find one or two beam remnants.
24084 MINT(105)=MINT(102+ISIDE)
24085 MINT(109)=MINT(106+ISIDE)
24086 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
24087 IF(MINT(51).NE.0) THEN
24092 C...Store first remnant parton, with colour info and kinematics.
24096 K(I,3)=MINT(83)+ISIDE
24097 P(I,5)=PYMASS(K(I,2))
24098 KCOL=KCHG(PYCOMP(KFLSP),2)
24101 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
24102 K(I,KFLS+3)=MSTU(5)*IPU3
24103 K(IPU3,6-KFLS)=MSTU(5)*I
24106 IF(KFLCH.EQ.0) THEN
24109 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24111 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
24112 PRP=P(I,4)+ABS(P(I,3))
24114 C...When extra remnant parton or hadron: store extra remnant.
24119 K(I,3)=MINT(83)+ISIDE
24120 P(I,5)=PYMASS(K(I,2))
24121 KCOL=KCHG(PYCOMP(KFLCH),2)
24124 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
24125 K(I,KFLS+3)=MSTU(5)*IPU3
24126 K(IPU3,6-KFLS)=MSTU(5)*I
24130 C...Relative transverse momentum when two remnants.
24133 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
24134 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
24135 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
24136 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
24137 P(I,1)=-P(IPU3,1)-P(I-1,1)
24138 P(I,2)=-P(IPU3,2)-P(I-1,2)
24139 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24141 C...Relative distribution of energy for particle into jet plus particle.
24143 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
24144 IF(MSTP(94).LE.1) THEN
24145 IF(IMB.EQ.1) CHI=PYR(0)
24146 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
24147 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24148 ELSEIF(MSTP(94).EQ.2) THEN
24149 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
24150 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24151 ELSEIF(MSTP(94).EQ.3) THEN
24152 CALL PYZDIS(1,0,PMS(4),ZZ)
24155 CALL PYZDIS(1000,0,PMS(4),ZZ)
24159 C...Construct total transverse mass; reject if too large.
24160 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
24161 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
24162 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
24163 IF(LOOP.LT.10) GOTO 200
24166 VINT(158+ISIDE)=CHI
24168 C...Subdivide longitudinal momentum according to value selected above.
24169 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
24171 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
24172 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
24174 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
24175 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
24179 C...Boost current and remnant systems to correct frame.
24180 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
24181 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
24182 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
24184 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
24186 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
24187 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
24188 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
24189 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
24191 C...Let current quark shower; recoil but no showering by colour partner.
24192 QMAX=2D0*SQRT(VINT(309-ISIDE))
24197 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
24204 C*********************************************************************
24207 C...Handles the documentation of the process in MSTI and PARI,
24208 C...and also computes cross-sections based on accumulated statistics.
24212 C...Double precision and integer declarations.
24213 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24214 IMPLICIT INTEGER(I-N)
24215 INTEGER PYK,PYCHGE,PYCOMP
24217 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24218 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24219 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24220 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24221 COMMON/PYINT1/MINT(400),VINT(400)
24222 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24223 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
24224 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
24227 C...Calculate Monte Carlo estimates of cross-sections.
24229 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
24230 NGEN(0,3)=NGEN(0,3)+1
24233 IF(I.EQ.96.OR.I.EQ.97) THEN
24235 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
24236 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
24237 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24238 & DBLE(NGEN(96,2)))
24239 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
24240 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24241 & DBLE(NGEN(96,2)))
24242 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
24244 ELSEIF(NGEN(I,2).EQ.0) THEN
24245 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
24248 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
24251 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
24254 C...Rescale to known low-pT cross-section for standard QCD processes.
24255 IF(MSUB(95).EQ.1) THEN
24256 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
24257 & XSEC(68,3)+XSEC(95,3)
24258 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
24259 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
24261 XSEC(11,3)=FAC*XSEC(11,3)
24262 XSEC(12,3)=FAC*XSEC(12,3)
24263 XSEC(13,3)=FAC*XSEC(13,3)
24264 XSEC(28,3)=FAC*XSEC(28,3)
24265 XSEC(53,3)=FAC*XSEC(53,3)
24266 XSEC(68,3)=FAC*XSEC(68,3)
24267 XSEC(95,3)=FAC*XSEC(95,3)
24268 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
24272 C...Save information for gamma-p and gamma-gamma.
24273 IF(MINT(121).GT.1) THEN
24279 C...Reset information on hard interaction.
24285 C...Copy integer valued information from MINT into MSTI.
24289 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
24291 C...Store cross-section variables in PARI.
24293 PARI(2)=XSEC(0,3)/MINT(5)
24297 VINT(98)=VINT(98)+VINT(100)
24298 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
24300 C...Store kinematics variables in PARI.
24303 IF(ISUB.NE.95) THEN
24313 PARI(35)=PARI(33)-PARI(34)
24320 PARI(42)=2D0*VINT(47)/VINT(1)
24323 C...Store information on scattered partons in PARI.
24324 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
24327 PARI(36+IS)=P(I,3)/VINT(1)
24328 PARI(38+IS)=P(I,4)/VINT(1)
24329 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
24330 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24331 & SQRT(PR),1D20)),P(I,3))
24332 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
24333 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24334 & SQRT(PR),1D20)),P(I,3))
24335 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
24336 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
24337 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
24341 C...Store sum up transverse and longitudinal momenta.
24342 PARI(65)=2D0*PARI(17)
24343 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
24344 DO 150 I=MSTP(126)+1,N
24345 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
24346 PT=SQRT(P(I,1)**2+P(I,2)**2)
24347 PARI(69)=PARI(69)+PT
24348 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
24349 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
24361 C...Store various other pieces of information into PARI.
24369 C...Store information on lepton -> lepton + gamma in PYGAGA.
24372 PARI(101)=VINT(301)
24373 PARI(102)=VINT(302)
24375 PARI(I)=VINT(I+202)
24378 C...Set information for PYTABU.
24379 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
24382 ELSEIF(ISET(ISUB).EQ.5) THEN
24393 C*********************************************************************
24396 C...Performs transformations between different coordinate frames.
24398 SUBROUTINE PYFRAM(IFRAME)
24400 C...Double precision and integer declarations.
24401 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24402 IMPLICIT INTEGER(I-N)
24403 INTEGER PYK,PYCHGE,PYCOMP
24405 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24406 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24407 COMMON/PYINT1/MINT(400),VINT(400)
24408 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
24410 C...Check that transformation can and should be done.
24411 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
24412 &MINT(91).EQ.1)) THEN
24413 IF(IFRAME.EQ.MINT(6)) RETURN
24415 WRITE(MSTU(11),5000) IFRAME,MINT(6)
24419 IF(MINT(6).EQ.1) THEN
24420 C...Transform from fixed target or user specified frame to
24421 C...overall CM frame.
24422 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
24423 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
24424 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
24425 ELSEIF(MINT(6).EQ.3) THEN
24426 C...Transform from hadronic CM frame in DIS to overall CM frame.
24427 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
24431 IF(IFRAME.EQ.1) THEN
24432 C...Transform from overall CM frame to fixed target or user specified
24434 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
24435 ELSEIF(IFRAME.EQ.3) THEN
24436 C...Transform from overall CM frame to hadronic CM frame in DIS.
24437 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
24438 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
24439 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
24442 C...Set information about new frame.
24446 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
24447 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
24453 C*********************************************************************
24456 C...Calculates full and partial widths of resonances.
24458 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
24460 C...Double precision and integer declarations.
24461 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24462 IMPLICIT INTEGER(I-N)
24463 INTEGER PYK,PYCHGE,PYCOMP
24464 C...Parameter statement to help give large particle numbers.
24465 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24466 &KEXCIT=4000000,KDIMEN=5000000)
24468 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24469 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24470 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
24471 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24472 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24473 COMMON/PYINT1/MINT(400),VINT(400)
24474 COMMON/PYINT4/MWID(500),WIDS(500,5)
24475 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24476 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24477 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
24478 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
24479 COMMON/PYPUED/IUED(0:99),RUED(0:99)
24480 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
24481 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/
24482 C...Local arrays and saved variables.
24483 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
24484 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
24485 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
24486 C...UED: equivalences between ordered particles (451->475)
24487 C...and UED particle code (5 000 000 + id)
24488 PARAMETER(KKFLMI=451,KKFLMA=475)
24489 DIMENSION CHIDEL(3), IUEDPR(25)
24490 DIMENSION IUEDEQ(KKFLMA),MUED(2)
24491 COMMON/SW1/SW21,CW21
24492 DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/
24493 & 6100001,6100002,6100003,6100004,6100005,6100006,
24494 & 5100001,5100002,5100003,5100004,5100005,5100006,
24495 & 6100011,6100013,6100015,
24496 & 5100012,5100011,5100014,5100013,5100016,5100015,
24497 & 5100021,5100022,5100023,5100024/
24498 C...Save local variables
24499 SAVE MOFSV,WIDWSV,WID2SV
24501 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
24502 DATA CHIDEL/1.1D-03,1.D0,7.4D+2/
24504 C...UED: inline functions used in kk width calculus
24505 FKAC1(X,Y)=1.-X**2/Y**2
24506 FKAC2(X,Y)=2.+X**2/Y**2
24508 C...Compressed code and sign; mass.
24515 C...Reset width information.
24516 DO 110 I=0,MDCY(KC,3)
24523 C...Allow for fudge factor to rescale resonance width.
24525 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
24526 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
24527 IF(MSTP(110).EQ.KFLA) THEN
24529 ELSEIF(MSTP(110).EQ.-1) THEN
24530 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
24531 ELSEIF(MSTP(110).EQ.-2) THEN
24536 C...Not to be treated as a resonance: return.
24537 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
24546 C...Treatment as a resonance based on tabulated branching ratios.
24547 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
24548 C...Loop over possible decay channels; skip irrelevant ones.
24549 DO 120 I=1,MDCY(KC,3)
24551 IF(MDME(IDC,1).LT.0) GOTO 120
24553 C...Read out decay products and nominal masses.
24556 C...Skip dummy modes or unrecognized particles
24557 IF (KFD1.EQ.0.OR.KFC1.EQ.0) GOTO 120
24558 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
24562 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
24568 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
24572 C...Naive partial width and alternative threshold factors.
24573 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
24574 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
24575 & PM1+PM2+PM3.GE.SHR) THEN
24577 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
24578 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
24579 & 4D0*PM1**2*PM2**2))/SH
24580 ELSEIF(MDME(IDC,2).EQ.52) THEN
24581 PMA=MAX(PM1,PM2,PM3)
24582 PMC=MIN(PM1,PM2,PM3)
24583 PMB=PM1+PM2+PM3-PMA-PMC
24584 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
24589 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
24590 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24591 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24592 & ((SHR-PMA)**2-(PMB+PMC)**2)*
24593 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
24594 & ((1D0-PMBCN)*PMBCN*SH)
24595 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
24596 WDTP(I)=WDTP(I)*SQRT(
24597 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
24598 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
24599 ELSEIF(MDME(IDC,2).EQ.53) THEN
24600 PMA=MAX(PM1,PM2,PM3)
24601 PMC=MIN(PM1,PM2,PM3)
24602 PMB=PM1+PM2+PM3-PMA-PMC
24603 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
24608 FACACT=SQRT(MAX(0D0,
24609 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24610 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24611 & ((SHR-PMA)**2-(PMB+PMC)**2)*
24612 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
24613 & ((1D0-PMBCN)*PMBCN*SH)
24614 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
24618 PMBCN=PMBC**2/PMR**2
24619 FACNOM=SQRT(MAX(0D0,
24620 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24621 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24622 & ((PMR-PMA)**2-(PMB+PMC)**2)*
24623 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
24624 & ((1D0-PMBCN)*PMBCN*PMR**2)
24625 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
24627 WDTP(I)=FUDGE*WDTP(I)
24628 WDTP(0)=WDTP(0)+WDTP(I)
24630 C...Calculate secondary width (at most two identical/opposite).
24632 IF(MDME(IDC,1).GT.0) THEN
24633 IF(KFD2.EQ.KFD1) THEN
24634 IF(KCHG(KFC1,3).EQ.0) THEN
24636 ELSEIF(KFD1.GT.0) THEN
24642 WID2=WID2*WIDS(KFC3,2)
24643 ELSEIF(KFD3.LT.0) THEN
24644 WID2=WID2*WIDS(KFC3,3)
24646 ELSEIF(KFD2.EQ.-KFD1) THEN
24649 WID2=WID2*WIDS(KFC3,2)
24650 ELSEIF(KFD3.LT.0) THEN
24651 WID2=WID2*WIDS(KFC3,3)
24653 ELSEIF(KFD3.EQ.KFD1) THEN
24654 IF(KCHG(KFC1,3).EQ.0) THEN
24656 ELSEIF(KFD1.GT.0) THEN
24662 WID2=WID2*WIDS(KFC2,2)
24663 ELSEIF(KFD2.LT.0) THEN
24664 WID2=WID2*WIDS(KFC2,3)
24666 ELSEIF(KFD3.EQ.-KFD1) THEN
24669 WID2=WID2*WIDS(KFC2,2)
24670 ELSEIF(KFD2.LT.0) THEN
24671 WID2=WID2*WIDS(KFC2,3)
24673 ELSEIF(KFD3.EQ.KFD2) THEN
24674 IF(KCHG(KFC2,3).EQ.0) THEN
24676 ELSEIF(KFD2.GT.0) THEN
24682 WID2=WID2*WIDS(KFC1,2)
24683 ELSEIF(KFD1.LT.0) THEN
24684 WID2=WID2*WIDS(KFC1,3)
24686 ELSEIF(KFD3.EQ.-KFD2) THEN
24689 WID2=WID2*WIDS(KFC1,2)
24690 ELSEIF(KFD1.LT.0) THEN
24691 WID2=WID2*WIDS(KFC1,3)
24700 WID2=WID2*WIDS(KFC2,2)
24702 WID2=WID2*WIDS(KFC2,3)
24705 WID2=WID2*WIDS(KFC3,2)
24706 ELSEIF(KFD3.LT.0) THEN
24707 WID2=WID2*WIDS(KFC3,3)
24711 C...Store effective widths according to case.
24712 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24713 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24714 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24715 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24725 C...Here begins detailed dynamical calculation of resonance widths.
24726 C...Shared treatment of Higgs states.
24729 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
24734 C...Common electroweak and strong constants.
24737 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
24740 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
24742 RADC=1D0+AS/PARU(1)
24746 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24747 RADCT=1D0-2.5D0*AS/PARU(1)
24748 DO 140 I=1,MDCY(KC,3)
24750 IF(MDME(IDC,1).LT.0) GOTO 140
24751 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24752 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24753 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
24755 IF(I.GE.4.AND.I.LE.7) THEN
24756 C...t -> W + q; including approximate QCD correction factor.
24757 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
24758 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24759 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24762 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24765 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24767 ELSEIF(I.EQ.9) THEN
24769 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
24770 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24771 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
24772 & 4D0*SQRT(RM2R*RM2))
24774 IF(KFLR.LT.0) WID2=WIDS(37,3)
24776 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
24777 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
24780 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
24783 KFC1=PYCOMP(KFDP(IDC,1))
24784 KFC2=PYCOMP(KFDP(IDC,2))
24785 PMNCHI=PMAS(KFC1,1)
24786 PMSTOP=PMAS(KFC2,1)
24787 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24790 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
24792 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
24793 AR=-ET*ZMIXC(IZ,1)*TANW
24794 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
24796 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
24797 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
24798 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24799 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24800 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
24801 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
24802 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
24804 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24806 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24809 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
24811 KFC1=PYCOMP(KFDP(IDC,1))
24812 KFC2=PYCOMP(KFDP(IDC,2))
24813 PMNCHI=PMAS(KFC1,1)
24814 PMSTOP=PMAS(KFC2,1)
24815 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24818 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24819 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24820 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
24821 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
24823 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24825 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24828 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
24829 C...t -> ~gravitino + ~t
24831 KFC1=PYCOMP(KFDP(IDC,1))
24832 XMGR2=PMAS(KFC1,1)**2
24833 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
24834 KFC2=PYCOMP(KFDP(IDC,2))
24836 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
24839 WDTP(I)=FUDGE*WDTP(I)
24840 WDTP(0)=WDTP(0)+WDTP(I)
24841 IF(MDME(IDC,1).GT.0) THEN
24842 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24843 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24844 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24845 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24849 ELSEIF(KFLA.EQ.7) THEN
24851 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24852 DO 150 I=1,MDCY(KC,3)
24854 IF(MDME(IDC,1).LT.0) GOTO 150
24855 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24856 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24857 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
24859 IF(I.GE.4.AND.I.LE.7) THEN
24861 WDTP(I)=FAC*VCKM(I-3,4)*
24862 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24863 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24866 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
24867 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
24870 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
24871 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
24874 IF(KFLR.LT.0) WID2=WIDS(24,2)
24875 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24877 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24878 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24881 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
24884 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
24887 WDTP(I)=FUDGE*WDTP(I)
24888 WDTP(0)=WDTP(0)+WDTP(I)
24889 IF(MDME(IDC,1).GT.0) THEN
24890 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24891 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24892 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24893 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24897 ELSEIF(KFLA.EQ.8) THEN
24899 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24900 DO 160 I=1,MDCY(KC,3)
24902 IF(MDME(IDC,1).LT.0) GOTO 160
24903 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24904 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24905 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
24907 IF(I.GE.4.AND.I.LE.7) THEN
24909 WDTP(I)=FAC*VCKM(4,I-3)*
24910 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24911 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24914 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24917 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24919 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24921 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24922 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24925 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
24928 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
24931 WDTP(I)=FUDGE*WDTP(I)
24932 WDTP(0)=WDTP(0)+WDTP(I)
24933 IF(MDME(IDC,1).GT.0) THEN
24934 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24935 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24936 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24937 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24941 ELSEIF(KFLA.EQ.17) THEN
24943 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24944 DO 170 I=1,MDCY(KC,3)
24946 IF(MDME(IDC,1).LT.0) GOTO 170
24947 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24948 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24949 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
24952 C...tau' -> W + nu'_tau.
24953 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24954 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24957 WID2=WID2*WIDS(18,2)
24960 WID2=WID2*WIDS(18,3)
24962 ELSEIF(I.EQ.5) THEN
24963 C...tau' -> H + nu'_tau.
24964 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24965 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24968 WID2=WID2*WIDS(18,2)
24971 WID2=WID2*WIDS(18,3)
24974 WDTP(I)=FUDGE*WDTP(I)
24975 WDTP(0)=WDTP(0)+WDTP(I)
24976 IF(MDME(IDC,1).GT.0) THEN
24977 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24978 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24979 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24980 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24984 ELSEIF(KFLA.EQ.18) THEN
24985 C...nu'_tau neutrino.
24986 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24987 DO 180 I=1,MDCY(KC,3)
24989 IF(MDME(IDC,1).LT.0) GOTO 180
24990 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24991 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24992 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
24995 C...nu'_tau -> W + tau'.
24996 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24997 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25000 WID2=WID2*WIDS(17,2)
25003 WID2=WID2*WIDS(17,3)
25005 ELSEIF(I.EQ.3) THEN
25006 C...nu'_tau -> H + tau'.
25007 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25008 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
25011 WID2=WID2*WIDS(17,2)
25014 WID2=WID2*WIDS(17,3)
25017 WDTP(I)=FUDGE*WDTP(I)
25018 WDTP(0)=WDTP(0)+WDTP(I)
25019 IF(MDME(IDC,1).GT.0) THEN
25020 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25021 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25022 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25023 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25027 ELSEIF(KFLA.EQ.21) THEN
25029 C***Note that widths are not given in dimensional quantities here.
25030 DO 190 I=1,MDCY(KC,3)
25032 IF(MDME(IDC,1).LT.0) GOTO 190
25033 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25034 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25035 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
25038 C...QCD -> q + qbar
25039 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25040 IF(I.EQ.6) WID2=WIDS(6,1)
25041 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25043 WDTP(I)=FUDGE*WDTP(I)
25044 WDTP(0)=WDTP(0)+WDTP(I)
25045 IF(MDME(IDC,1).GT.0) THEN
25046 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25047 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25048 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25049 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25053 ELSEIF(KFLA.EQ.22) THEN
25055 C***Note that widths are not given in dimensional quantities here.
25056 DO 200 I=1,MDCY(KC,3)
25058 IF(MDME(IDC,1).LT.0) GOTO 200
25059 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25060 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25061 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
25064 C...QED -> q + qbar.
25067 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25068 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25069 IF(I.EQ.6) WID2=WIDS(6,1)
25070 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25071 ELSEIF(I.LE.12) THEN
25072 C...QED -> l+ + l-.
25073 EF=KCHG(9+2*(I-8),1)/3D0
25074 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25075 IF(I.EQ.12) WID2=WIDS(17,1)
25077 WDTP(I)=FUDGE*WDTP(I)
25078 WDTP(0)=WDTP(0)+WDTP(I)
25079 IF(MDME(IDC,1).GT.0) THEN
25080 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25081 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25082 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25083 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25087 ELSEIF(KFLA.EQ.23) THEN
25090 XWC=1D0/(16D0*XW*XW1)
25091 FAC=(AEM*XWC/3D0)*SHR
25093 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25098 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25100 IF(KFI.GT.20) KFI=IABS(MINT(16))
25106 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
25107 IF(MSTP(43).EQ.3) VINT(112)=
25108 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25109 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25110 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25112 DO 220 I=1,MDCY(KC,3)
25114 IF(MDME(IDC,1).LT.0) GOTO 220
25115 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25116 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25117 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
25122 AF=SIGN(1D0,EF+0.1D0)
25125 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25126 IF(I.EQ.6) WID2=WIDS(6,1)
25127 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25128 ELSEIF(I.LE.16) THEN
25129 C...Z0 -> l+ + l-, nu + nubar
25131 AF=SIGN(1D0,EF+0.1D0)
25134 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25136 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25137 IF(ICASE.EQ.1) THEN
25138 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
25140 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25141 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25142 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
25143 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
25144 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25145 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25146 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25147 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25149 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
25150 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
25151 IF(MDME(IDC,1).GT.0) THEN
25152 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25153 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25154 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25155 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25156 & WDTE(I,MDME(IDC,1))
25157 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25158 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25160 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25161 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
25162 & VINT(111)+FGGF*WID2
25163 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
25164 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25165 & VINT(114)+FZZF*WID2
25169 IF(MINT(61).GE.1) ICASE=3-ICASE
25170 IF(ICASE.EQ.2) GOTO 210
25172 ELSEIF(KFLA.EQ.24) THEN
25174 FAC=(AEM/(24D0*XW))*SHR
25175 DO 230 I=1,MDCY(KC,3)
25177 IF(MDME(IDC,1).LT.0) GOTO 230
25178 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25179 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25180 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
25183 C...W+/- -> q + qbar'
25184 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
25186 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25187 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25188 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25190 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25191 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25192 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25194 ELSEIF(I.LE.20) THEN
25195 C...W+/- -> l+/- + nu
25198 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25200 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25203 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25204 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25205 WDTP(I)=FUDGE*WDTP(I)
25206 WDTP(0)=WDTP(0)+WDTP(I)
25207 IF(MDME(IDC,1).GT.0) THEN
25208 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25209 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25210 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25211 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25215 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
25216 C...h0 (or H0, or A0):
25218 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25219 DO 270 I=1,MDCY(KFHIGG,3)
25220 IDC=I+MDCY(KFHIGG,2)-1
25221 IF(MDME(IDC,1).LT.0) GOTO 270
25222 KFC1=PYCOMP(KFDP(IDC,1))
25223 KFC2=PYCOMP(KFDP(IDC,2))
25224 RM1=PMAS(KFC1,1)**2/SH
25225 RM2=PMAS(KFC2,1)**2/SH
25226 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
25232 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
25233 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
25234 C...A0 behaves like beta, ho and H0 like beta**3.
25235 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25236 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25237 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
25238 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
25239 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
25240 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
25241 IF(IHIGG.NE.3) THEN
25242 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
25243 & PARU(151+10*IHIGG))**2
25247 IF(I.EQ.6) WID2=WIDS(6,1)
25248 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25249 ELSEIF(I.LE.12) THEN
25251 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
25252 C...A0 behaves like beta, ho and H0 like beta**3.
25253 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25254 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25255 & PARU(153+10*IHIGG)**2
25256 IF(I.EQ.12) WID2=WIDS(17,1)
25258 ELSEIF(I.EQ.13) THEN
25259 C...h0 -> g + g; quark loop contribution only
25262 DO 240 J=1,2*MSTP(1)
25263 EPS=(2D0*PMAS(J,1))**2/SH
25264 C...Loop integral; function of eps=4m^2/shat; different for A0.
25265 IF(EPS.LE.1D0) THEN
25266 IF(EPS.GT.1D-4) THEN
25268 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25270 RLN=LOG(4D0/EPS-2D0)
25272 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25273 PHIIM=0.5D0*PARU(1)*RLN
25275 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25278 IF(IHIGG.LE.2) THEN
25279 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25280 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
25282 ETAREJ=-0.5D0*EPS*PHIRE
25283 ETAIMJ=-0.5D0*EPS*PHIIM
25285 C...Couplings (=1 for standard model Higgs).
25286 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25287 IF(MOD(J,2).EQ.1) THEN
25288 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
25289 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
25291 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
25292 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
25298 ETA2=ETARE**2+ETAIM**2
25299 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
25301 ELSEIF(I.EQ.14) THEN
25302 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
25306 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25308 IF(J.LE.2*MSTP(1)) THEN
25310 EPS=(2D0*PMAS(J,1))**2/SH
25311 ELSEIF(J.LE.3*MSTP(1)) THEN
25312 JL=2*(J-2*MSTP(1))-1
25313 EJ=KCHG(10+JL,1)/3D0
25314 EPS=(2D0*PMAS(10+JL,1))**2/SH
25315 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25316 EPS=(2D0*PMAS(24,1))**2/SH
25318 EPS=(2D0*PMAS(37,1))**2/SH
25320 C...Loop integral; function of eps=4m^2/shat.
25321 IF(EPS.LE.1D0) THEN
25322 IF(EPS.GT.1D-4) THEN
25324 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25326 RLN=LOG(4D0/EPS-2D0)
25328 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25329 PHIIM=0.5D0*PARU(1)*RLN
25331 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25334 IF(J.LE.3*MSTP(1)) THEN
25335 C...Fermion loops: loop integral different for A0; charges.
25336 IF(IHIGG.LE.2) THEN
25337 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25338 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
25340 PHIPRE=-0.5D0*EPS*PHIRE
25341 PHIPIM=-0.5D0*EPS*PHIIM
25343 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25345 EJH=PARU(151+10*IHIGG)
25346 ELSEIF(J.LE.2*MSTP(1)) THEN
25348 EJH=PARU(152+10*IHIGG)
25351 EJH=PARU(153+10*IHIGG)
25353 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
25354 ETAREJ=EJC*EJH*PHIPRE
25355 ETAIMJ=EJC*EJH*PHIPIM
25356 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25357 C...W loops: loop integral and charges.
25358 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
25359 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
25360 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25361 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
25362 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
25365 C...Charged H loops: loop integral and charges.
25366 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
25367 & PARU(158+10*IHIGG+2*(IHIGG/3))
25368 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
25369 ETAIMJ=-EPS**2*PHIIM*FACHHH
25374 ETA2=ETARE**2+ETAIM**2
25375 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
25377 ELSEIF(I.EQ.15) THEN
25378 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
25382 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25384 IF(J.LE.2*MSTP(1)) THEN
25386 AJ=SIGN(1D0,EJ+0.1D0)
25388 EPS=(2D0*PMAS(J,1))**2/SH
25389 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
25390 ELSEIF(J.LE.3*MSTP(1)) THEN
25391 JL=2*(J-2*MSTP(1))-1
25392 EJ=KCHG(10+JL,1)/3D0
25393 AJ=SIGN(1D0,EJ+0.1D0)
25395 EPS=(2D0*PMAS(10+JL,1))**2/SH
25396 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
25398 EPS=(2D0*PMAS(24,1))**2/SH
25399 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
25401 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
25402 IF(EPS.LE.1D0) THEN
25404 IF(EPS.GT.1D-4) THEN
25405 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25407 RLN=LOG(4D0/EPS-2D0)
25409 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25410 PHIIM=0.5D0*PARU(1)*RLN
25411 PSIRE=0.5D0*ROOT*RLN
25412 PSIIM=-0.5D0*ROOT*PARU(1)
25414 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25416 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
25419 IF(EPSP.LE.1D0) THEN
25420 ROOT=SQRT(1D0-EPSP)
25421 IF(EPSP.GT.1D-4) THEN
25422 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25424 RLN=LOG(4D0/EPSP-2D0)
25426 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
25427 PHIIMP=0.5D0*PARU(1)*RLN
25428 PSIREP=0.5D0*ROOT*RLN
25429 PSIIMP=-0.5D0*ROOT*PARU(1)
25431 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
25433 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
25436 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
25437 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
25438 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
25439 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
25440 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
25441 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
25442 IF(J.LE.3*MSTP(1)) THEN
25443 C...Fermion loops: loop integral different for A0; charges.
25444 IF(IHIGG.EQ.3) FXYRE=0D0
25445 IF(IHIGG.EQ.3) FXYIM=0D0
25446 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25448 EJH=PARU(151+10*IHIGG)
25449 ELSEIF(J.LE.2*MSTP(1)) THEN
25451 EJH=PARU(152+10*IHIGG)
25454 EJH=PARU(153+10*IHIGG)
25456 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
25457 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
25458 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
25459 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25460 C...W loops: loop integral and charges.
25461 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
25462 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
25463 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
25464 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25465 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
25466 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
25469 C...Charged H loops: loop integral and charges.
25470 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
25471 & PARU(158+10*IHIGG+2*(IHIGG/3))
25472 ETAREJ=FACHHH*FXYRE
25473 ETAIMJ=FACHHH*FXYIM
25478 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
25479 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
25482 ELSEIF(I.LE.17) THEN
25483 C...h0 -> Z0 + Z0, W+ + W-
25484 PM1=PMAS(IABS(KFDP(IDC,1)),1)
25485 PG1=PMAS(IABS(KFDP(IDC,1)),2)
25486 IF(MINT(62).GE.1) THEN
25487 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
25488 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
25489 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
25490 MOFSV(IHIGG,I-15)=0
25491 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
25495 MOFSV(IHIGG,I-15)=1
25496 RMAS=SQRT(MAX(0D0,SH))
25497 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
25499 WIDWSV(IHIGG,I-15)=WIDW
25500 WID2SV(IHIGG,I-15)=WID2
25503 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
25504 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
25508 WIDW=WIDWSV(IHIGG,I-15)
25509 WID2=WID2SV(IHIGG,I-15)
25512 WDTP(I)=FAC*WIDW/(2D0*(18-I))
25513 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
25514 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25515 & PARU(138+I+10*IHIGG)**2
25516 WID2=WID2*WIDS(7+I,1)
25518 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
25519 C...H0 -> Z0 + h0, A0-> Z0 + h0
25520 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
25521 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25522 IF(IHIGG.EQ.2) THEN
25523 WDTP(I)=WDTP(I)*PARU(179)**2
25524 ELSEIF(IHIGG.EQ.3) THEN
25525 WDTP(I)=WDTP(I)*PARU(186)**2
25527 WID2=WIDS(23,2)*WIDS(25,2)
25529 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
25530 C...H0 -> h0 + h0, A0-> h0 + h0
25531 WDTP(I)=FAC*0.25D0*
25532 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25533 IF(IHIGG.EQ.2) THEN
25534 WDTP(I)=WDTP(I)*PARU(176)**2
25535 ELSEIF(IHIGG.EQ.3) THEN
25536 WDTP(I)=WDTP(I)*PARU(169)**2
25539 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
25540 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
25541 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
25542 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25543 & *PARU(195+IHIGG)**2
25545 WID2=WIDS(24,2)*WIDS(37,3)
25546 ELSEIF(I.EQ.21) THEN
25547 WID2=WIDS(24,3)*WIDS(37,2)
25550 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
25552 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
25553 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25554 WID2=WIDS(36,2)*WIDS(23,2)
25556 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
25558 WDTP(I)=FAC*0.5D0*PARU(180)**2*
25559 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25560 WID2=WIDS(25,2)*WIDS(36,2)
25562 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
25564 WDTP(I)=FAC*0.25D0*PARU(177)**2*
25565 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25570 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25573 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25574 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25575 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25580 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25582 IF(KFC2.EQ.KFC1) THEN
25586 IF(KFDP(IDC,1).LT.0) KSGN1=3
25588 IF(KFDP(IDC,2).LT.0) KSGN2=3
25589 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25592 WDTP(I)=FUDGE*WDTP(I)
25593 WDTP(0)=WDTP(0)+WDTP(I)
25594 IF(MDME(IDC,1).GT.0) THEN
25595 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25596 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25597 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25598 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25602 ELSEIF(KFLA.EQ.32) THEN
25605 XWC=1D0/(16D0*XW*XW1)
25606 FAC=(AEM*XWC/3D0)*SHR
25609 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25617 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25618 KFAI=IABS(MINT(15))
25619 EI=KCHG(KFAI,1)/3D0
25620 AI=SIGN(1D0,EI+0.1D0)
25623 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
25624 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
25625 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
25626 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
25627 VPI=PARU(119+2*KFAIC)
25628 API=PARU(120+2*KFAIC)
25629 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
25630 VPI=PARJ(178+2*KFAIC)
25631 API=PARJ(179+2*KFAIC)
25633 VPI=PARJ(186+2*KFAIC)
25634 API=PARJ(187+2*KFAIC)
25638 SQMZP=PMAS(32,1)**2
25640 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25641 & MSTP(44).EQ.7) VINT(111)=1D0
25642 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
25643 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25644 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
25645 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
25646 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25647 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25648 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
25649 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
25650 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
25651 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25652 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
25654 DO 290 I=1,MDCY(KC,3)
25656 IF(MDME(IDC,1).LT.0) GOTO 290
25657 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25658 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25659 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
25663 C...Z'0 -> q + qbar
25665 AF=SIGN(1D0,EF+0.1D0)
25668 VPF=PARU(123-2*MOD(I,2))
25669 APF=PARU(124-2*MOD(I,2))
25670 ELSEIF(I.LE.4) THEN
25671 VPF=PARJ(182-2*MOD(I,2))
25672 APF=PARJ(183-2*MOD(I,2))
25674 VPF=PARJ(190-2*MOD(I,2))
25675 APF=PARJ(191-2*MOD(I,2))
25678 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
25679 & PYHFTH(SH,SH*RM1,1D0)
25680 IF(I.EQ.6) WID2=WIDS(6,1)
25681 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25682 ELSEIF(I.LE.16) THEN
25683 C...Z'0 -> l+ + l-, nu + nubar
25685 AF=SIGN(1D0,EF+0.1D0)
25688 VPF=PARU(127-2*MOD(I,2))
25689 APF=PARU(128-2*MOD(I,2))
25690 ELSEIF(I.LE.12) THEN
25691 VPF=PARJ(186-2*MOD(I,2))
25692 APF=PARJ(187-2*MOD(I,2))
25694 VPF=PARJ(194-2*MOD(I,2))
25695 APF=PARJ(195-2*MOD(I,2))
25698 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25700 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25701 IF(ICASE.EQ.1) THEN
25702 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25703 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
25704 & APF**2*(1D0-4D0*RM1))*BE34
25705 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25706 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25707 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
25708 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
25709 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
25710 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
25711 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
25712 ELSEIF(MINT(61).EQ.2) THEN
25713 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25714 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25715 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
25716 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25717 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
25719 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
25722 ELSEIF(I.EQ.17) THEN
25724 WDTPZP=PARU(129)**2*XW1**2*
25725 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25726 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25727 IF(ICASE.EQ.1) THEN
25730 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25731 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25732 ELSEIF(MINT(61).EQ.2) THEN
25741 ELSEIF(I.EQ.18) THEN
25743 CZC=2D0*(1D0-2D0*XW)
25744 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25745 IF(ICASE.EQ.1) THEN
25746 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
25747 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
25748 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25749 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
25750 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
25751 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
25752 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
25753 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
25754 ELSEIF(MINT(61).EQ.2) THEN
25756 FGZF=0.25D0*PARU(142)*CZC*BE34C
25757 FGZPF=0.25D0*PARU(143)*CZC*BE34C
25758 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
25759 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
25760 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
25763 ELSEIF(I.EQ.19) THEN
25764 C...Z'0 -> Z0 + gamma.
25765 ELSEIF(I.EQ.20) THEN
25767 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25768 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
25769 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
25770 IF(ICASE.EQ.1) THEN
25773 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25774 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25775 ELSEIF(MINT(61).EQ.2) THEN
25783 WID2=WIDS(23,2)*WIDS(25,2)
25784 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
25785 C...Z' -> h0 + A0 or H0 + A0.
25786 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25794 IF(ICASE.EQ.1) THEN
25795 WDTPZ=CZAH**2*BE34C
25796 WDTP(I)=FAC*CZPAH**2*BE34C
25797 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25798 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
25799 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
25801 ELSEIF(MINT(61).EQ.2) THEN
25806 FZZPF=CZAH*CZPAH*BE34C
25807 FZPZPF=CZPAH**2*BE34C
25809 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
25810 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
25812 IF(ICASE.EQ.1) THEN
25813 VINT(117)=VINT(117)+FAC*WDTPZ
25814 WDTP(I)=FUDGE*WDTP(I)
25815 WDTP(0)=WDTP(0)+WDTP(I)
25817 IF(MDME(IDC,1).GT.0) THEN
25818 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25819 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25820 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25821 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25822 & WDTE(I,MDME(IDC,1))
25823 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25824 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25826 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25827 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25828 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
25829 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
25831 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
25833 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25834 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
25835 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
25837 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25838 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
25842 IF(MINT(61).GE.1) ICASE=3-ICASE
25843 IF(ICASE.EQ.2) GOTO 280
25845 ELSEIF(KFLA.EQ.34) THEN
25847 FAC=(AEM/(24D0*XW))*SHR
25848 DO 300 I=1,MDCY(KC,3)
25850 IF(MDME(IDC,1).LT.0) GOTO 300
25851 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25852 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25853 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
25857 C...W'+/- -> q + qbar'
25858 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
25859 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
25861 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25862 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25863 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25865 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25866 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25867 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25869 ELSEIF(I.LE.20) THEN
25870 C...W'+/- -> l+/- + nu
25871 FCOF=PARU(133)**2+PARU(134)**2
25873 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25875 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25878 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
25879 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25880 ELSEIF(I.EQ.21) THEN
25881 C...W'+/- -> W+/- + Z0
25882 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
25883 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25884 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25885 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
25886 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
25887 ELSEIF(I.EQ.23) THEN
25888 C...W'+/- -> W+/- + h0
25889 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25890 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
25891 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25892 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25894 WDTP(I)=FUDGE*WDTP(I)
25895 WDTP(0)=WDTP(0)+WDTP(I)
25896 IF(MDME(IDC,1).GT.0) THEN
25897 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25898 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25899 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25900 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25904 ELSEIF(KFLA.EQ.37) THEN
25906 C IF(MSTP(49).EQ.0) THEN
25909 C SHFS=PMAS(37,1)**2
25911 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25912 DO 310 I=1,MDCY(KC,3)
25914 IF(MDME(IDC,1).LT.0) GOTO 310
25915 KFC1=PYCOMP(KFDP(IDC,1))
25916 KFC2=PYCOMP(KFDP(IDC,2))
25917 RM1=PMAS(KFC1,1)**2/SH
25918 RM2=PMAS(KFC2,1)**2/SH
25919 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
25922 C...H+/- -> q + qbar'
25923 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
25924 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25925 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
25926 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
25927 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25929 IF(I.EQ.3) WID2=WIDS(6,2)
25930 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
25932 IF(I.EQ.3) WID2=WIDS(6,3)
25933 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
25935 ELSEIF(I.LE.8) THEN
25936 C...H+/- -> l+/- + nu
25937 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
25938 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
25939 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25941 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
25943 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
25945 ELSEIF(I.EQ.9) THEN
25946 C...H+/- -> W+/- + h0.
25947 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
25948 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25949 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25950 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25954 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25957 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25958 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25959 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25964 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25967 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
25969 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
25970 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25972 WDTP(I)=FUDGE*WDTP(I)
25973 WDTP(0)=WDTP(0)+WDTP(I)
25974 IF(MDME(IDC,1).GT.0) THEN
25975 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25976 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25977 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25978 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25982 ELSEIF(KFLA.EQ.41) THEN
25984 FAC=(AEM/(12D0*XW))*SHR
25985 DO 320 I=1,MDCY(KC,3)
25987 IF(MDME(IDC,1).LT.0) GOTO 320
25988 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25989 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25990 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
25995 ELSEIF(I.LE.9) THEN
25999 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26000 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26002 IF(I.EQ.4) WID2=WIDS(6,3)
26003 IF(I.EQ.5) WID2=WIDS(7,3)
26004 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
26005 IF(I.EQ.9) WID2=WIDS(17,3)
26007 IF(I.EQ.4) WID2=WIDS(6,2)
26008 IF(I.EQ.5) WID2=WIDS(7,2)
26009 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
26010 IF(I.EQ.9) WID2=WIDS(17,2)
26012 WDTP(I)=FUDGE*WDTP(I)
26013 WDTP(0)=WDTP(0)+WDTP(I)
26014 IF(MDME(IDC,1).GT.0) THEN
26015 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26016 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26017 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26018 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26022 ELSEIF(KFLA.EQ.42) THEN
26023 C...LQ (leptoquark).
26024 FAC=(AEM/4D0)*PARU(151)*SHR
26025 DO 330 I=1,MDCY(KC,3)
26027 IF(MDME(IDC,1).LT.0) GOTO 330
26028 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26029 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26030 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
26031 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26033 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
26034 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
26035 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
26036 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
26037 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
26038 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
26039 WDTP(I)=FUDGE*WDTP(I)
26040 WDTP(0)=WDTP(0)+WDTP(I)
26041 IF(MDME(IDC,1).GT.0) THEN
26042 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26043 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26044 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26045 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26049 C...UED: kk state width decays : flav: 451 476
26050 ELSEIF(IUED(1).EQ.1.AND.
26051 & PYCOMP(ABS(KFLA)).GE.KKFLMI.AND.
26052 & PYCOMP(ABS(KFLA)).LE.KKFLMA) THEN
26054 C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
26055 RMFLAS=PMAS(KCLA,1)
26056 FACSH=SH/PMAS(KCLA,1)**2
26057 ALPHEM=PYALEM(RMFLAS**2)
26058 ALPHS=PYALPS(RMFLAS**2)
26060 C...uedcor parameters (alpha_s is calculated at mkk scale)
26061 C...alpha_em is calculated at z pole !
26065 DO 1070 I=1,MDCY(KCLA,3)
26066 IDC=I+MDCY(KCLA,2)-1
26068 IF(MDME(IDC,1).LT.0) GOTO 1070
26069 KFC1=PYCOMP(ABS(KFDP(IDC,1)))
26070 KFC2=PYCOMP(ABS(KFDP(IDC,2)))
26071 RM1=PMAS(KFC1,1)**2/SH
26072 RM2=PMAS(KFC2,1)**2/SH
26073 IF(SQRT(RM1)+SQRT(RM2).GT.1D0)
26077 C...N.B. RINV=RUED(1)
26083 KKCLA=KCLA-KKFLMI+1
26084 IF(ABS(KFC1).GE.KKFLMI)KKPART=KFC1
26085 IF(ABS(KFC2).GE.KKFLMI)KKPART=KFC2
26086 IF(KKCLA.LE.6) THEN
26087 C...q*_S -> q + gamma* (in first time sw21=0)
26088 FAC=0.25*ALPHEM*RMFLAS*0.5*CW21/CW2*KCHG(KCLA,1)**2/9.
26089 C...Eventually change the following by enabling a choice of open or closed.
26090 C...Only the gamma_kk channel is open.
26092 + WDTP(I)=FAC*FKAC2(RMFLAS,RMKK)*FKAC1(RMKK,RMFLAS)**2
26093 WDTP(I)=FACSH*WDTP(I)
26095 ELSEIF(KKCLA.GT.6.AND.KKCLA.LE.12)THEN
26096 C...q*_D -> q + Z*/W*
26097 FAC=0.25*ALPHEM*RMFLAS/(4.*SW2)
26098 GAMMAW=FAC*FKAC2(RMFLAS,RMWKK)*FKAC1(RMWKK,RMFLAS)**2
26108 WDTP(I)=FACSH*WDTP(I)
26109 C...q*_D -> q + gamma* is closed
26110 ELSEIF(KKCLA.GT.12.AND.KKCLA.LE.21)THEN
26111 C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
26112 FAC=ALPHEM/4.*RMFLAS/CW2/8.
26114 WDTP(I)=FAC*FKAC2(RMFLAS,RMGAKK)*
26115 + FKAC1(RMGAKK,RMFLAS)**2
26116 WDTP(I)=FACSH*WDTP(I)
26118 ELSEIF(KKCLA.EQ.22)THEN
26119 RMQST=PMAS(KKPART,1)
26120 WID2=WIDS(KKPART,2)
26121 C...g* -> q*_S/q*_D + q
26122 FAC=10.*ALPHS/12.*RMFLAS
26123 WDTP(I)=FAC*FKAC1(RMQST,RMFLAS)**2*FKAC2(RMQST,RMFLAS)
26124 WDTP(I)=FACSH*WDTP(I)
26125 ELSEIF(KKCLA.EQ.23)THEN
26126 C...gamma* decays to graviton + gamma : initial value is used
26128 WDTP(I)=RMFLAS*(RMFLAS/RUED(2))**(IUED(4)+2)
26130 ELSEIF(KKCLA.EQ.24)THEN
26131 C...Z* -> l*_S + l is closed
26132 C... Z* -> l*_D + l
26133 IF(I.LE.3)GOTO 1070
26134 c... After closing the channels for a Z* decaying into positively charged
26135 C... KK lepton singlets, close the channels for a Z* decaying into negatively
26136 C... charged KK lepton singlets + positively charged SM particles
26137 IF(I.GE.10.AND.I.LE.12)GOTO 1070
26138 FAC=3./2.*ALPHEM/24./SW2*RMZKK
26139 RMLST=PMAS(KKPART,1)
26140 WDTP(I)=FAC*FKAC1(RMLST,RMZKK)**2*FKAC2(RMLST,RMZKK)
26141 WDTP(I)=FACSH*WDTP(I)
26142 WID2=WIDS(KKPART,2)
26143 ELSEIF(KKCLA.EQ.25)THEN
26144 C...W* -> l*_D lbar
26145 FAC=3.*ALPHEM/12./SW2*RMWKK
26146 RMLST=PMAS(KKPART,1)
26147 WDTP(I)=FAC*FKAC1(RMLST,RMWKK)**2*FKAC2(RMLST,RMWKK)
26148 WDTP(I)=FACSH*WDTP(I)
26149 WID2=WIDS(KKPART,2)
26151 WDTP(0)=WDTP(0)+WDTP(I)
26152 IF(MDME(IDC,1).GT.0) THEN
26153 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26154 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26155 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26156 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26161 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
26162 C...Techni-pi0 and techni-pi0':
26163 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26164 DO 340 I=1,MDCY(KC,3)
26166 IF(MDME(IDC,1).LT.0) GOTO 340
26167 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26168 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26171 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
26175 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
26176 & /(8D0*PARU(1))*SH*SHR
26177 IF(KFLA.EQ.KTECHN+111) THEN
26184 C...pi_tc -> f + fbar.
26186 IKA=IABS(KFDP(IDC,1))
26187 IF(IKA.LT.10) FCOF=3D0*RADC
26190 IF(IKA.GE.4.AND.IKA.LE.6) THEN
26191 FCOF=FCOF*RTCM(1+IKA)**2
26192 HM1=PYMRUN(KFDP(IDC,1),SH)
26193 HM2=PYMRUN(KFDP(IDC,2),SH)
26194 ELSEIF(IKA.EQ.15) THEN
26195 FCOF=FCOF*RTCM(8)**2
26197 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26198 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26200 WDTP(I)=FUDGE*WDTP(I)
26201 WDTP(0)=WDTP(0)+WDTP(I)
26202 IF(MDME(IDC,1).GT.0) THEN
26203 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26204 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26205 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26206 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26210 ELSEIF(KFLA.EQ.KTECHN+211) THEN
26212 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26213 DO 350 I=1,MDCY(KC,3)
26215 IF(MDME(IDC,1).LT.0) GOTO 350
26216 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26217 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26219 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26223 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
26225 C...pi_tc -> f + f'.
26227 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
26228 C...pi_tc+ -> W b b~
26229 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
26231 XMT2=PMAS(6,1)**2/SH
26232 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
26233 KFC3=PYCOMP(KFDP(IDC,3))
26234 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
26236 T0 = (1D0-CHECK**2)*
26237 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
26238 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
26239 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
26240 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
26241 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
26242 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
26251 IKA=IABS(KFDP(IDC,1))
26252 IF(IKA.LT.10) FCOF=3D0*RADC
26255 IF(I.GE.1.AND.I.LE.5) THEN
26257 FCOF=FCOF*RTCM(5)**2
26258 ELSEIF(I.LE.4) THEN
26259 FCOF=FCOF*RTCM(6)**2
26260 ELSEIF(I.EQ.5) THEN
26261 FCOF=FCOF*RTCM(7)**2
26263 HM1=PYMRUN(KFDP(IDC,1),SH)
26264 HM2=PYMRUN(KFDP(IDC,2),SH)
26265 ELSEIF(I.EQ.8) THEN
26266 FCOF=FCOF*RTCM(8)**2
26268 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26269 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26271 WDTP(I)=FUDGE*WDTP(I)
26272 WDTP(0)=WDTP(0)+WDTP(I)
26273 IF(MDME(IDC,1).GT.0) THEN
26274 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26275 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26276 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26277 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26281 ELSEIF(KFLA.EQ.KTECHN+331) THEN
26283 FAC=(SH/PARP(46)**2)*SHR
26284 DO 360 I=1,MDCY(KC,3)
26286 IF(MDME(IDC,1).LT.0) GOTO 360
26287 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26288 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26289 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
26292 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
26293 IF(I.EQ.2) WID2=WIDS(6,1)
26295 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
26297 WDTP(I)=FUDGE*WDTP(I)
26298 WDTP(0)=WDTP(0)+WDTP(I)
26299 IF(MDME(IDC,1).GT.0) THEN
26300 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26301 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26302 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26303 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26307 ELSEIF(KFLA.EQ.KTECHN+113) THEN
26309 ALPRHT=2.16D0*(3D0/ITCM(1))
26310 FAC=(ALPRHT/12D0)*SHR
26311 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26315 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26317 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26318 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26319 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26320 DO 370 I=1,MDCY(KC,3)
26322 IF(MDME(IDC,1).LT.0) GOTO 370
26323 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26324 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26325 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
26328 C...rho_tc0 -> W+ + W-.
26329 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26330 WDTP(I)=FAC*RTCM(3)**4*
26331 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26332 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26333 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26334 & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
26336 ELSEIF(I.EQ.2) THEN
26337 C...rho_tc0 -> W+ + pi_tc-.
26338 C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
26339 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26340 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26341 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26342 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
26343 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26344 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26345 ELSEIF(I.EQ.3) THEN
26346 C...rho_tc0 -> pi_tc+ + W-.
26347 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26348 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26349 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26350 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
26351 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26352 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
26353 ELSEIF(I.EQ.4) THEN
26354 C...rho_tc0 -> pi_tc+ + pi_tc-.
26355 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
26356 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26357 WID2=WIDS(PYCOMP(KTECHN+211),1)
26358 ELSEIF(I.EQ.5) THEN
26359 C...rho_tc0 -> gamma + pi_tc0
26360 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26361 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26363 WID2=WIDS(PYCOMP(KTECHN+111),2)
26364 ELSEIF(I.EQ.6) THEN
26365 C...rho_tc0 -> gamma + pi_tc0'
26366 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26367 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
26368 WID2=WIDS(PYCOMP(KTECHN+221),2)
26369 ELSEIF(I.EQ.7) THEN
26370 C...rho_tc0 -> Z0 + pi_tc0
26371 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26372 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26374 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
26375 ELSEIF(I.EQ.8) THEN
26376 C...rho_tc0 -> Z0 + pi_tc0'
26377 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26378 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
26380 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26381 ELSEIF(I.EQ.9) THEN
26382 C...rho_tc0 -> gamma + Z0
26383 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26384 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26386 ELSEIF(I.EQ.10) THEN
26387 C...rho_tc0 -> Z0 + Z0
26388 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26389 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
26393 C...rho_tc0 -> f + fbar.
26398 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26402 IF(IA.GE.17) WID2=WIDS(IA,1)
26405 AI=SIGN(1D0,EI+0.1D0)
26409 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26410 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26411 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26412 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
26414 WDTP(I)=FUDGE*WDTP(I)
26415 WDTP(0)=WDTP(0)+WDTP(I)
26416 IF(MDME(IDC,1).GT.0) THEN
26417 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26418 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26419 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26420 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26424 ELSEIF(KFLA.EQ.KTECHN+213) THEN
26426 ALPRHT=2.16D0*(3D0/ITCM(1))
26427 FAC=(ALPRHT/12D0)*SHR
26431 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
26433 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
26434 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26435 DO 380 I=1,MDCY(KC,3)
26437 IF(MDME(IDC,1).LT.0) GOTO 380
26438 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26439 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26440 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
26442 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26443 c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26446 C...rho_tc+ -> W+ + Z0.
26448 WDTP(I)=FAC*RTCM(3)**4*
26449 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26450 VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
26451 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
26453 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
26456 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
26458 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26461 WID2=WIDS(24,2)*WIDS(23,2)
26463 WID2=WIDS(24,3)*WIDS(23,2)
26465 ELSEIF(I.EQ.2) THEN
26466 C...rho_tc+ -> W+ + pi_tc0.
26467 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26468 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26469 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26470 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26471 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26473 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
26475 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
26477 ELSEIF(I.EQ.3) THEN
26478 C...rho_tc+ -> pi_tc+ + Z0.
26479 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26480 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26481 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26482 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
26483 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
26484 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26485 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26488 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
26490 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
26492 ELSEIF(I.EQ.4) THEN
26493 C...rho_tc+ -> pi_tc+ + pi_tc0.
26494 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
26495 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26497 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
26499 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
26501 ELSEIF(I.EQ.5) THEN
26502 C...rho_tc+ -> pi_tc+ + gamma
26503 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26504 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26507 WID2=WIDS(PYCOMP(KTECHN+211),2)
26509 WID2=WIDS(PYCOMP(KTECHN+211),3)
26511 ELSEIF(I.EQ.6) THEN
26512 C...rho_tc+ -> W+ + pi_tc0'
26513 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26514 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
26516 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
26518 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
26520 ELSEIF(I.EQ.7) THEN
26521 C...rho_tc+ -> W+ + gamma
26522 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26523 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26530 C...rho_tc+ -> f + fbar'.
26534 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
26536 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
26537 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
26538 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
26540 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
26541 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
26542 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
26547 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26549 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26552 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26553 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26555 WDTP(I)=FUDGE*WDTP(I)
26556 WDTP(0)=WDTP(0)+WDTP(I)
26557 IF(MDME(IDC,1).GT.0) THEN
26558 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26559 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26560 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26561 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26565 ELSEIF(KFLA.EQ.KTECHN+223) THEN
26567 ALPRHT=2.16D0*(3D0/ITCM(1))
26568 FAC=(ALPRHT/12D0)*SHR
26569 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
26572 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26574 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26575 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26576 DO 390 I=1,MDCY(KC,3)
26578 IF(MDME(IDC,1).LT.0) GOTO 390
26579 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26580 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26581 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
26584 C...omega_tc0 -> gamma + pi_tc0.
26585 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
26586 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
26587 WID2=WIDS(PYCOMP(KTECHN+111),2)
26588 ELSEIF(I.EQ.2) THEN
26589 C...omega_tc0 -> Z0 + pi_tc0
26590 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26591 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
26593 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
26594 ELSEIF(I.EQ.3) THEN
26595 C...omega_tc0 -> gamma + pi_tc0'
26596 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26597 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
26599 WID2=WIDS(PYCOMP(KTECHN+221),2)
26600 ELSEIF(I.EQ.4) THEN
26601 C...omega_tc0 -> Z0 + pi_tc0'
26602 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26603 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
26605 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26606 ELSEIF(I.EQ.5) THEN
26607 C...omega_tc0 -> W+ + pi_tc-
26608 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26609 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
26610 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
26611 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26612 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26613 ELSEIF(I.EQ.6) THEN
26614 C...omega_tc0 -> pi_tc+ + W-
26615 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26616 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
26617 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
26618 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26619 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
26620 ELSEIF(I.EQ.7) THEN
26621 C...omega_tc0 -> W+ + W-.
26622 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26623 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
26624 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26625 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26626 & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
26628 ELSEIF(I.EQ.8) THEN
26629 C...omega_tc0 -> pi_tc+ + pi_tc-.
26630 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
26631 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26632 WID2=WIDS(PYCOMP(KTECHN+211),1)
26633 C...omega_tc0 -> gamma + Z0
26634 ELSEIF(I.EQ.9) THEN
26635 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26636 & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26638 C...omega_tc0 -> Z0 + Z0
26639 ELSEIF(I.EQ.10) THEN
26640 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26641 & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
26642 & /24D0/RTCM(12)**2*SHR**3
26645 C...omega_tc0 -> f + fbar.
26650 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26654 IF(IA.GE.17) WID2=WIDS(IA,1)
26657 AI=SIGN(1D0,EI+0.1D0)
26659 VALI=-0.5D0*(VI+AI)
26660 VARI=-0.5D0*(VI-AI)
26661 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26662 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26663 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26664 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
26666 WDTP(I)=FUDGE*WDTP(I)
26667 WDTP(0)=WDTP(0)+WDTP(I)
26668 IF(MDME(IDC,1).GT.0) THEN
26669 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26670 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26671 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26672 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26676 C.....V8 -> quark anti-quark
26677 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
26680 IF(ITCM(2).EQ.0) THEN
26682 ELSEIF(ITCM(2).EQ.1) THEN
26685 DO 400 I=1,MDCY(KC,3)
26687 IF(MDME(IDC,1).LT.0) GOTO 400
26688 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26690 IF(RM1.GT.0.25D0) GOTO 400
26692 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
26697 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
26698 IF(I.EQ.6) WID2=WIDS(6,1)
26699 WDTP(I)=FUDGE*WDTP(I)
26700 WDTP(0)=WDTP(0)+WDTP(I)
26701 IF(MDME(IDC,1).GT.0) THEN
26702 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26703 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26704 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26705 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26709 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
26710 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
26712 DO 410 I=1,MDCY(KC,3)
26714 IF(MDME(IDC,1).LT.0) GOTO 410
26715 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26716 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26717 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
26721 IF(KFLA.EQ.KTECHN+100111) THEN
26726 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
26727 & /(2D0*PARU(1))*SH*SHR*CLEBG
26730 C...pi_tc -> f + fbar.
26731 IF(I.EQ.6) WID2=WIDS(6,1)
26733 IKA=IABS(KFDP(IDC,1))
26734 IF(IKA.LT.10) FCOF=3D0*RADC
26735 HM1=PYMRUN(KFDP(IDC,1),SH)
26736 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
26737 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26739 WDTP(I)=FUDGE*WDTP(I)
26740 WDTP(0)=WDTP(0)+WDTP(I)
26741 IF(MDME(IDC,1).GT.0) THEN
26742 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26743 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26744 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26745 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26749 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
26751 ALPRHT=2.16D0*(3D0/ITCM(1))
26753 SIN2T=2D0*TANT3/(TANT3**2+1D0)
26754 SINT3=TANT3/SQRT(TANT3**2+1D0)
26757 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
26758 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
26759 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
26760 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
26761 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
26763 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
26765 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
26767 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
26769 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
26770 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
26771 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
26772 IF(ITCM(2).EQ.0) THEN
26777 DO 420 I=1,MDCY(KC,3)
26778 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
26779 & KFLA.EQ.KTECHN+300113)) GOTO 420
26781 IF(MDME(IDC,1).LT.0) GOTO 420
26782 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26783 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26784 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
26787 IF(I.EQ.6) WID2=WIDS(6,1)
26789 IF(KFLA.EQ.KTECHN+200113) THEN
26792 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
26795 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
26800 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
26801 FMIX=1D0/TANT3/SIN2T
26805 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
26806 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
26807 ELSEIF(I.EQ.7) THEN
26808 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
26809 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
26810 PSH=SHR*(1D0-RM1)/2D0
26811 WDTP(I)=AS/9D0*PSH**3/RM82
26813 WDTP(I)=2D0*WDTP(I)*CSXPP**2
26814 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
26816 WDTP(I)=5D0*WDTP(I)
26817 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
26820 WDTP(I)=FUDGE*WDTP(I)
26821 WDTP(0)=WDTP(0)+WDTP(I)
26822 IF(MDME(IDC,1).GT.0) THEN
26823 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26824 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26825 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26826 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26830 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
26831 C...d* excited quark.
26832 FAC=(SH/RTCM(41)**2)*SHR
26833 DO 430 I=1,MDCY(KC,3)
26835 IF(MDME(IDC,1).LT.0) GOTO 430
26836 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26837 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26838 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
26842 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26844 ELSEIF(I.EQ.2) THEN
26845 C...d* -> gamma + d.
26846 QF=-RTCM(43)/2D0+RTCM(44)/6D0
26847 WDTP(I)=FAC*AEM*QF**2/4D0
26849 ELSEIF(I.EQ.3) THEN
26851 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26852 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26853 & (1D0-RM1)**2*(2D0+RM1)
26855 ELSEIF(I.EQ.4) THEN
26857 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26858 & (1D0-RM1)**2*(2D0+RM1)
26859 IF(KFLR.GT.0) WID2=WIDS(24,3)
26860 IF(KFLR.LT.0) WID2=WIDS(24,2)
26862 WDTP(I)=FUDGE*WDTP(I)
26863 WDTP(0)=WDTP(0)+WDTP(I)
26864 IF(MDME(IDC,1).GT.0) THEN
26865 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26866 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26867 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26868 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26872 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
26873 C...u* excited quark.
26874 FAC=(SH/RTCM(41)**2)*SHR
26875 DO 440 I=1,MDCY(KC,3)
26877 IF(MDME(IDC,1).LT.0) GOTO 440
26878 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26879 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26880 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
26884 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26886 ELSEIF(I.EQ.2) THEN
26887 C...u* -> gamma + u.
26888 QF=RTCM(43)/2D0+RTCM(44)/6D0
26889 WDTP(I)=FAC*AEM*QF**2/4D0
26891 ELSEIF(I.EQ.3) THEN
26893 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26894 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26895 & (1D0-RM1)**2*(2D0+RM1)
26897 ELSEIF(I.EQ.4) THEN
26899 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26900 & (1D0-RM1)**2*(2D0+RM1)
26901 IF(KFLR.GT.0) WID2=WIDS(24,2)
26902 IF(KFLR.LT.0) WID2=WIDS(24,3)
26904 WDTP(I)=FUDGE*WDTP(I)
26905 WDTP(0)=WDTP(0)+WDTP(I)
26906 IF(MDME(IDC,1).GT.0) THEN
26907 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26908 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26909 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26910 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26914 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
26915 C...e* excited lepton.
26916 FAC=(SH/RTCM(41)**2)*SHR
26917 DO 450 I=1,MDCY(KC,3)
26919 IF(MDME(IDC,1).LT.0) GOTO 450
26920 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26921 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26922 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
26925 C...e* -> gamma + e.
26926 QF=-RTCM(43)/2D0-RTCM(44)/2D0
26927 WDTP(I)=FAC*AEM*QF**2/4D0
26929 ELSEIF(I.EQ.2) THEN
26931 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26932 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26933 & (1D0-RM1)**2*(2D0+RM1)
26935 ELSEIF(I.EQ.3) THEN
26937 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26938 & (1D0-RM1)**2*(2D0+RM1)
26939 IF(KFLR.GT.0) WID2=WIDS(24,3)
26940 IF(KFLR.LT.0) WID2=WIDS(24,2)
26942 WDTP(I)=FUDGE*WDTP(I)
26943 WDTP(0)=WDTP(0)+WDTP(I)
26944 IF(MDME(IDC,1).GT.0) THEN
26945 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26946 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26947 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26948 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26952 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
26953 C...nu*_e excited neutrino.
26954 FAC=(SH/RTCM(41)**2)*SHR
26955 DO 460 I=1,MDCY(KC,3)
26957 IF(MDME(IDC,1).LT.0) GOTO 460
26958 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26959 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26960 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
26963 C...nu*_e -> Z0 + nu*_e.
26964 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26965 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26966 & (1D0-RM1)**2*(2D0+RM1)
26968 ELSEIF(I.EQ.2) THEN
26969 C...nu*_e -> W+ + e.
26970 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26971 & (1D0-RM1)**2*(2D0+RM1)
26972 IF(KFLR.GT.0) WID2=WIDS(24,2)
26973 IF(KFLR.LT.0) WID2=WIDS(24,3)
26975 WDTP(I)=FUDGE*WDTP(I)
26976 WDTP(0)=WDTP(0)+WDTP(I)
26977 IF(MDME(IDC,1).GT.0) THEN
26978 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26979 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26980 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26981 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26985 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
26986 C...G* (graviton resonance):
26987 FAC=(PARP(50)**2/PARU(1))*SHR
26988 DO 470 I=1,MDCY(KC,3)
26990 IF(MDME(IDC,1).LT.0) GOTO 470
26991 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26992 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26993 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
26998 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
26999 & PYHFTH(SH,SH*RM1,1D0)
27000 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27001 & (1D0+8D0*RM1/3D0)/320D0
27002 IF(I.EQ.6) WID2=WIDS(6,1)
27003 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
27004 ELSEIF(I.LE.16) THEN
27005 C...G* -> l+ + l-, nu + nubar
27007 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27008 & (1D0+8D0*RM1/3D0)/320D0
27009 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
27010 ELSEIF(I.EQ.17) THEN
27013 ELSEIF(I.EQ.18) THEN
27014 C...G* -> gamma + gamma.
27016 ELSEIF(I.EQ.19) THEN
27018 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27019 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
27021 ELSEIF(I.EQ.20) THEN
27023 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27024 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
27027 WDTP(I)=FUDGE*WDTP(I)
27028 WDTP(0)=WDTP(0)+WDTP(I)
27029 IF(MDME(IDC,1).GT.0) THEN
27030 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27031 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27032 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27033 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27037 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
27038 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
27039 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
27040 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
27041 DO 480 I=1,MDCY(KC,3)
27043 IF(MDME(IDC,1).LT.0) GOTO 480
27044 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
27045 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
27046 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
27047 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
27050 C...nu_lR -> l- qbar q'
27051 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27052 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27053 ELSEIF(I.LE.18) THEN
27054 C...nu_lR -> l+ q qbar'
27055 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
27056 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
27058 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
27060 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
27062 X=(PM1+PM2+PM3)/SHR
27063 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
27065 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
27066 WDTP(I)=FAC*FCOF*FX*FY
27067 WDTP(I)=FUDGE*WDTP(I)
27068 WDTP(0)=WDTP(0)+WDTP(I)
27069 IF(MDME(IDC,1).GT.0) THEN
27070 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27071 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27072 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27073 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27077 ELSEIF(KFLA.EQ.9900023) THEN
27079 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
27080 DO 490 I=1,MDCY(KC,3)
27082 IF(MDME(IDC,1).LT.0) GOTO 490
27083 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27084 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27085 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
27089 C...Z_R0 -> q + qbar
27091 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
27092 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
27094 IF(I.EQ.6) WID2=WIDS(6,1)
27095 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
27096 C...Z_R0 -> l+ + l-
27100 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
27101 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
27106 ELSEIF(I.LE.15) THEN
27107 C...Z0 -> nu_R + nu_R, assumed Majorana.
27111 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
27114 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
27115 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
27116 WDTP(I)=FUDGE*WDTP(I)
27117 WDTP(0)=WDTP(0)+WDTP(I)
27118 IF(MDME(IDC,1).GT.0) THEN
27119 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27120 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27121 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27122 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27126 ELSEIF(KFLA.EQ.9900024) THEN
27128 FAC=(AEM/(24D0*XW))*SHR
27129 DO 500 I=1,MDCY(KC,3)
27131 IF(MDME(IDC,1).LT.0) GOTO 500
27132 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27133 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27134 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
27137 C...W_R+/- -> q + qbar'
27138 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27140 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27142 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
27144 ELSEIF(I.LE.12) THEN
27145 C...W_R+/- -> l+/- + nu_R
27148 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27149 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27150 WDTP(I)=FUDGE*WDTP(I)
27151 WDTP(0)=WDTP(0)+WDTP(I)
27152 IF(MDME(IDC,1).GT.0) THEN
27153 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27154 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27155 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27156 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27160 ELSEIF(KFLA.EQ.9900041) THEN
27162 FAC=(1D0/(8D0*PARU(1)))*SHR
27163 DO 510 I=1,MDCY(KC,3)
27165 IF(MDME(IDC,1).LT.0) GOTO 510
27166 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27167 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27168 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
27171 C...H_L++/-- -> l+/- + l'+/-
27172 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27173 & (IABS(KFDP(IDC,2))-9)/2)**2
27174 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27175 ELSEIF(I.EQ.7) THEN
27176 C...H_L++/-- -> W_L+/- + W_L+/-
27177 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
27178 & (3D0*RM1+0.25D0/RM1-1D0)
27179 WID2=WIDS(24,4+(1-KFLS)/2)
27182 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27183 WDTP(I)=FUDGE*WDTP(I)
27184 WDTP(0)=WDTP(0)+WDTP(I)
27185 IF(MDME(IDC,1).GT.0) THEN
27186 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27187 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27188 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27189 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27193 ELSEIF(KFLA.EQ.9900042) THEN
27195 FAC=(1D0/(8D0*PARU(1)))*SHR
27196 DO 520 I=1,MDCY(KC,3)
27198 IF(MDME(IDC,1).LT.0) GOTO 520
27199 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27200 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27201 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
27204 C...H_R++/-- -> l+/- + l'+/-
27205 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27206 & (IABS(KFDP(IDC,2))-9)/2)**2
27207 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27208 ELSEIF(I.EQ.7) THEN
27209 C...H_R++/-- -> W_R+/- + W_R+/-
27210 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
27211 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
27214 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27215 WDTP(I)=FUDGE*WDTP(I)
27216 WDTP(0)=WDTP(0)+WDTP(I)
27217 IF(MDME(IDC,1).GT.0) THEN
27218 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27219 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27220 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27221 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27225 ELSEIF(KFLA.EQ.KTECHN+115) THEN
27227 C...Need to update to alpha_rho
27228 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27229 FAC=(ALPRHT/12D0)*SHR
27230 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
27234 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
27236 XWRHT=1D0/(4D0*XW*(1D0-XW))
27237 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
27238 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
27239 DO 530 I=1,MDCY(KC,3)
27241 IF(MDME(IDC,1).LT.0) GOTO 530
27242 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27243 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27244 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
27246 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27249 FACPA=PCM**2+1.5D0*RM1
27252 C...a2_tc0 -> W+ + W-
27254 AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
27255 C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
27257 C...a2_tc0 -> W+ + pi_tc- + c.c.
27258 ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
27259 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27261 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27263 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
27265 ELSEIF(I.EQ.4) THEN
27266 C...a2_tc0 -> Z0 + pi_tc0'
27267 VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
27268 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27270 WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
27271 ELSEIF(I.GE.5.AND.I.LE.10) THEN
27272 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27273 FACPA=PCM**2*(1D0+RM1+RM2)
27277 C...a_T^0 -> gamma rho_T^0
27278 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27279 WID2=WIDS(PYCOMP(KTECHN+113),2)
27280 ELSEIF(I.EQ.6) THEN
27281 C...a_T^0 -> gamma omega_T
27282 VA2=1D0/RTCM(50)**4
27283 WID2=WIDS(PYCOMP(KTECHN+223),2)
27284 ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
27285 C...a_T^0 -> W^+- rho_T^-+
27286 AA2=.25D0/XW/RTCM(51)**4
27288 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
27290 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
27292 ELSEIF(I.EQ.9) THEN
27293 C...a_T^0 -> Z^0 rho_T^0
27294 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27295 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
27296 ELSEIF(I.EQ.10) THEN
27297 C...a_T^0 -> Z^0 omega_T
27298 VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
27299 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
27301 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27303 C...a2_tc0 -> f + fbar.
27308 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27312 IF(IA.GE.17) WID2=WIDS(IA,1)
27315 AI=SIGN(1D0,EI+0.1D0)
27319 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27320 & ((VALI*BWZR)**2+(VALI*BWZI)**2+
27321 & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27322 & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
27324 WDTP(I)=FUDGE*WDTP(I)
27325 WDTP(0)=WDTP(0)+WDTP(I)
27326 IF(MDME(IDC,1).GT.0) THEN
27327 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27328 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27329 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27330 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27334 ELSEIF(KFLA.EQ.KTECHN+215) THEN
27336 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27337 FAC=(ALPRHT/12D0)*SHR
27341 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
27343 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
27344 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
27345 DO 540 I=1,MDCY(KC,3)
27347 IF(MDME(IDC,1).LT.0) GOTO 540
27348 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27349 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27350 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
27352 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27361 C...a2_tc+ -> gamma + W+.
27363 AA2=RTCM(3)**2/RTCM(49)**2
27364 WID2=WIDS(24,ICHANN)
27365 C...a2_tc+ -> gamma + pi_tc+.
27366 ELSEIF(I.EQ.2) THEN
27367 AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
27368 WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
27369 C...a2_tc+ -> W+ + Z
27370 ELSEIF(I.EQ.3) THEN
27371 AA2=RTCM(3)**2*(1D0/4D0/XW1 +
27372 & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
27373 WID2=WIDS(24,ICHANN)*WIDS(23,2)
27374 C...a2_tc+ -> W+ + pi_tc0.
27375 ELSEIF(I.EQ.4) THEN
27376 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27377 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
27378 C...a2_tc+ -> W+ + pi_tc'0.
27379 ELSEIF(I.EQ.5) THEN
27380 VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
27381 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
27382 C...a2_tc+ -> Z0 + pi_tc+.
27383 ELSEIF(I.EQ.6) THEN
27384 AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
27386 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
27388 WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27390 ELSEIF(I.LE.10) THEN
27391 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27392 FACPA=PCM**2*(1D0+RM1+RM2)
27395 C...a2_tc+ -> gamma + rho_tc+
27397 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27398 WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
27399 C...a2_tc+ -> W+ + rho_T^0
27400 ELSEIF(I.EQ.8) THEN
27401 AA2=1D0/(4D0*XW)/RTCM(51)**4
27402 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
27403 C...a2_tc+ -> W+ + omega_T
27404 ELSEIF(I.EQ.9) THEN
27405 VA2=.25D0/XW/RTCM(50)**4
27406 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
27407 C...a2_tc+ -> Z^0 + rho_T^+
27408 ELSEIF(I.EQ.10) THEN
27409 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27410 AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
27411 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
27413 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27415 C...a2_tc+ -> f + fbar'.
27419 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
27421 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
27422 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
27423 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
27425 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
27426 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
27427 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
27432 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
27434 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
27437 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27438 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27440 WDTP(I)=FUDGE*WDTP(I)
27441 WDTP(0)=WDTP(0)+WDTP(I)
27442 IF(MDME(IDC,1).GT.0) THEN
27443 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27444 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27445 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27446 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27457 C***********************************************************************
27460 C...Calculates partial width and differential cross-section maxima
27461 C...of channels/processes not allowed on mass-shell, and selects
27462 C...masses in such channels/processes.
27464 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
27466 C...Double precision and integer declarations.
27467 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27468 IMPLICIT INTEGER(I-N)
27469 INTEGER PYK,PYCHGE,PYCOMP
27471 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27472 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27473 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
27474 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27475 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27476 COMMON/PYINT1/MINT(400),VINT(400)
27477 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27478 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
27479 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
27482 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
27483 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
27484 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
27487 C...Find if particles equal, maximum mass, matrix elements, etc.
27493 IF(KFD(1).EQ.KFD(2)) MEQL=1
27495 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
27496 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
27502 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
27505 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
27506 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
27507 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
27508 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
27509 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
27510 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
27513 C...Find where Breit-Wigners are required, else select discrete masses.
27515 KFCA=PYCOMP(KFD(I))
27517 PMD(I)=PMAS(KFCA,1)
27518 PGD(I)=PMAS(KFCA,2)
27523 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
27526 RMG(I)=(PMG(I)/PMMX)**2
27532 C...Find allowed mass range and Breit-Wigner parameters.
27534 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
27536 PMU(I)=PMMX-PARP(42)
27537 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
27538 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27539 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
27541 IF(MLM.EQ.2) ILM=3-I
27542 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
27543 IF(MBW(3-I).EQ.0) THEN
27544 PMU(I)=PMMX-PMD(3-I)
27546 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
27548 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
27549 & MIN(PMU(I),CKIN(NOFF+2*ILM))
27550 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
27551 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
27552 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27553 IF(MBW(I).EQ.1) THEN
27554 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27555 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27556 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
27559 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
27561 IF(MLM.EQ.2) ILM=3-I
27562 PML(I)=MAX(CKIN(48+I),PARP(42))
27563 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
27564 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
27565 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
27566 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
27567 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27568 IF(MBW(I).EQ.1) THEN
27569 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27570 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27571 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
27576 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
27578 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
27583 C...Calculation of partial width of resonance.
27584 IF(MOFSH.EQ.1) THEN
27586 C..If only one integration, pick that to be the inner.
27587 IF(MBW(1).EQ.0) THEN
27593 ELSEIF(MBW(2).EQ.0) THEN
27597 C...Start outer loop of integration.
27598 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27599 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
27600 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
27606 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27607 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
27608 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
27612 C...Start inner loop of integration.
27614 PMU1=MIN(PMU(1),PMMX-PM2)
27615 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
27616 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
27617 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
27618 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
27626 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
27627 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
27630 C...Evaluate function value - inner loop.
27631 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27632 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
27633 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
27634 & RM2**2+10D0*RM1*RM2)
27635 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
27638 C...Go to next position in inner loop.
27644 ELSEIF(NPT1.LE.8) THEN
27646 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
27648 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
27649 INX1(NPT1)=INX1(ISH1)
27652 ELSEIF(NPT1.LT.100) THEN
27655 IF(ISH1.GT.NPT1) ISH1=2
27656 IF(ISH1.EQ.ISN1) GOTO 160
27657 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
27658 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
27660 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
27661 INX1(NPT1)=INX1(ISH1)
27666 C...Calculate integral over inner loop.
27669 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
27670 & (XPT1(INX1(IPT1))-XPT1(IPT1))
27672 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
27673 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27674 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
27677 C...Go to next position in outer loop.
27683 ELSEIF(NPT2.LE.8) THEN
27685 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
27687 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
27688 INX2(NPT2)=INX2(ISH2)
27691 ELSEIF(NPT2.LT.100) THEN
27694 IF(ISH2.GT.NPT2) ISH2=2
27695 IF(ISH2.EQ.ISN2) GOTO 200
27696 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
27697 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
27699 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
27700 INX2(NPT2)=INX2(ISH2)
27705 C...Calculate integral over outer loop.
27708 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
27709 & (XPT2(INX2(IPT2))-XPT2(IPT2))
27711 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
27712 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
27717 C...Save result; second integration for user-selected mass range.
27718 IF(LOOP.EQ.1) WIDW=FSUM2
27720 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
27721 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
27728 C...Select two decay product masses of a resonance.
27729 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
27731 IF(MBW(I).EQ.0) GOTO 230
27732 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
27734 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
27735 RMG(I)=(PMG(I)/PMMX)**2
27737 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
27738 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
27740 C...Weight with matrix element (if none known, use beta factor).
27741 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
27743 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
27744 ELSEIF(MMED.EQ.2) THEN
27745 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
27746 & RMG(2)**2+10D0*RMG(1)*RMG(2))
27747 ELSEIF(MMED.EQ.3) THEN
27748 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
27752 IF(WTBE.LT.PYR(0)) GOTO 220
27756 C...Find suitable set of masses for initialization of 2 -> 2 processes.
27757 ELSEIF(MOFSH.EQ.3) THEN
27758 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
27759 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
27761 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
27763 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
27767 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
27768 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
27769 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
27774 C...Evaluate importance of excluded tails of Breit-Wigners.
27775 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
27776 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
27780 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
27784 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
27785 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
27787 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
27788 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
27789 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
27790 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27792 C...Pick one particle to be the lighter (if improves efficiency).
27793 ELSEIF(MOFSH.EQ.4) THEN
27794 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
27795 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
27796 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
27798 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
27800 IF(MBW(I).EQ.0) GOTO 270
27802 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
27804 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
27806 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27807 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
27808 IF(RBR.LT.0.8D0) THEN
27809 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
27810 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
27811 ELSEIF(RBR.LT.0.9D0) THEN
27812 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
27813 ELSEIF(RBR.LT.1.5D0) THEN
27814 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
27816 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
27817 & (PMV**2-PML(I)**2))))
27820 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
27821 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
27822 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
27823 NGEN(0,1)=NGEN(0,1)+1
27824 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
27834 C...Give weight for selected mass distribution.
27837 IF(MBW(I).EQ.0) GOTO 280
27839 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
27841 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
27842 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
27843 & (PMD(I)*PGD(I))**2)/PARU(1)
27847 FI0=(ATV-ATL(I))/PARU(1)
27848 FI1=PMV**2-PML(I)**2
27849 FI2=2D0*LOG(PMV/PML(I))
27850 FI3=1D0/PML(I)**2-1D0/PMV**2
27851 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27852 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
27853 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
27856 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
27858 VINT(80)=VINT(80)*FI0
27860 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27866 C***********************************************************************
27869 C...Handles the possibility of colour reconnection in W+W- events,
27870 C...Based on the main scenarios of the Sjostrand and Khoze study:
27871 C...I, II, II', intermediate and instantaneous; plus one model
27872 C...along the lines of the Gustafson and Hakkinen: GH.
27873 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
27874 C...is as if first resonance is W+ and second W-.
27876 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
27878 C...Double precision and integer declarations.
27879 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27880 IMPLICIT INTEGER(I-N)
27881 INTEGER PYK,PYCHGE,PYCOMP
27882 C...Parameter value; number of points in MC integration.
27883 PARAMETER (NPT=100)
27885 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27886 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27887 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27888 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27889 COMMON/PYINT1/MINT(400),VINT(400)
27890 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27892 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
27893 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
27894 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
27895 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
27896 &TMC(20),IJOIN(100)
27898 C...Functions to give four-product and to do determinants.
27899 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)
27900 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
27901 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
27902 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
27904 C...Only allow fraction of recoupling for GH, intermediate and
27906 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27907 IF(PYR(0).GT.PARP(120)) RETURN
27911 C...Common part for scenarios I, II, II', and GH.
27912 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
27913 &MSTP(115).EQ.5) THEN
27915 C...Read out frequently-used parameters.
27919 IF(ISUB.EQ.22) PMW=PMAS(23,1)
27921 IF(ISUB.EQ.22) PGW=PMAS(23,2)
27928 C...Find range of decay products of the W's.
27929 C...Background: the W's are stored in IW1 and IW2.
27930 C...Their direct decay products in NSD1+1 through NSD1+4.
27931 C...Products after shower (if any) in NSD1+5 through NAFT1
27932 C...for first W and in NAFT1+1 through N for the second.
27933 IF(NAFT1.GT.NSD1+4) THEN
27940 IF(N.GT.NAFT1) THEN
27948 C...Rearrange parton shower products along strings.
27950 CALL PYPREP(NSD1+1)
27951 IF(MINT(51).NE.0) RETURN
27953 C...Find partons pointing back to W+ and W-; store them with quark
27954 C...end of string first.
27960 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
27961 IF(IABS(K(I,2)).GE.22) GOTO 120
27962 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
27963 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
27973 IF(K(I,1).EQ.1) ISGP=0
27974 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
27975 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
27985 IF(K(I,1).EQ.1) ISGM=0
27989 C...Boost to W+W- rest frame (not strictly needed).
27991 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
27993 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27994 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27995 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27997 C...Select decay vertices of W+ and W-.
27998 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
27999 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
28000 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
28001 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
28004 XP(J)=TP*P(IW1,J)/P(IW1,4)
28005 XM(J)=TM*P(IW2,J)/P(IW2,4)
28008 C...Begin scenario I specifics.
28009 IF(MSTP(115).EQ.1) THEN
28011 C...Reconstruct velocity and direction of W+ string pieces.
28013 IF(K(INP(IIP),2).LT.0) GOTO 170
28016 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28017 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28021 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
28022 DIRP(IIP,J)=V1(J)-V2(J)
28024 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
28026 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
28028 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
28032 C...Reconstruct velocity and direction of W- string pieces.
28034 IF(K(INM(IIM),2).LT.0) GOTO 200
28037 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28038 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28042 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
28043 DIRM(IIM,J)=V1(J)-V2(J)
28045 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
28047 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
28049 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
28053 C...Loop over number of space-time points.
28058 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
28059 R=SQRT(-LOG(PYR(0)))
28061 X=BLOWR*RHAD*R*COS(PHI)
28062 Y=BLOWR*RHAD*R*SIN(PHI)
28063 R=SQRT(-LOG(PYR(0)))
28065 Z=BLOWR*RHAD*R*COS(PHI)
28066 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
28068 C...Reject impossible points. Weight for sample distribution.
28069 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
28070 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
28071 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
28073 C...Loop over W+ string pieces and find one with largest weight.
28081 IF(K(INP(IIP),2).LT.0) GOTO 220
28082 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
28083 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
28085 XB(J)=XD(J)+BEDG*BETP(IIP,J)
28087 XB(4)=BETP(IIP,4)*(XD(4)-BED)
28088 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28089 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
28090 & DIRP(IIP,3)*XB(3))**2
28091 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28093 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
28094 IF(WTP.GT.WTMAXP) THEN
28100 C...Loop over W- string pieces and find one with largest weight.
28108 IF(K(INM(IIM),2).LT.0) GOTO 240
28109 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
28110 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
28112 XB(J)=XD(J)+BEDG*BETM(IIM,J)
28114 XB(4)=BETM(IIM,4)*(XD(4)-BED)
28115 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28116 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
28117 & DIRM(IIM,3)*XB(3))**2
28118 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28120 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
28121 IF(WTM.GT.WTMAXM) THEN
28127 C...Result of integration.
28129 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
28130 WT=WTMAXP*WTMAXM/WTSMP
28138 RES=BLOWR**3*BLOWT*SUM/NPT
28140 C...Decide whether to reconnect and, if so, where.
28142 PREC=1D0-EXP(-FACT*RES)
28143 IF(PREC.GT.PYR(0)) THEN
28148 IF(RSUM.LE.0D0) GOTO 270
28154 C...Begin scenario II and II' specifics.
28155 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
28157 C...Loop through all string pieces, one from W+ and one from W-.
28161 IF(K(INP(IIP),2).LT.0) GOTO 340
28165 IF(K(INM(IIM),2).LT.0) GOTO 330
28169 C...Find endpoint velocity vectors.
28171 V1P(J)=P(I1P,J)/P(I1P,4)
28172 V2P(J)=P(I2P,J)/P(I2P,4)
28173 V1M(J)=P(I1M,J)/P(I1M,4)
28174 V2M(J)=P(I2M,J)/P(I2M,4)
28177 C...Define q matrix and find t.
28179 Q(1,J)=V2P(J)-V1P(J)
28180 Q(2,J)=-(V2M(J)-V1M(J))
28181 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
28182 Q(4,J)=V1P(J)-V1M(J)
28184 T=-DETER(1,2,3)/DETER(1,2,4)
28186 C...Find alpha and beta; i.e. coordinates of crossing point.
28189 S13=Q(3,1)+Q(4,1)*T
28192 S23=Q(3,2)+Q(4,2)*T
28193 DEN=S11*S22-S12*S21
28194 ALP=(S12*S23-S22*S13)/DEN
28195 BET=(S21*S13-S11*S23)/DEN
28197 C...Check if solution acceptable.
28199 IF(T.LT.GTMAX) IANSW=0
28200 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
28201 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
28203 C...Find point of crossing and check that not inconsistent.
28205 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
28206 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
28208 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
28209 & (XPP(3)-XMM(3))**2
28210 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
28211 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
28212 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
28214 C...Find string eigentimes at crossing.
28215 IF(IANSW.EQ.1) THEN
28216 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
28217 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
28218 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
28219 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
28225 C...Order crossings by time. End loop over crossings.
28226 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
28228 DO 310 I1=NCROSS,1,-1
28229 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
28249 C...Loop over crossings; find first (if any) acceptable one.
28251 IF(NCROSS.GE.1) THEN
28253 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
28254 IF(PNFRAG.GT.PYR(0)) THEN
28255 C...Scenario II: only compare with fragmentation time.
28256 IF(MSTP(115).EQ.2) THEN
28261 C...Scenario II': also require that string length decreases.
28269 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28270 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28271 IF(ELNEW.LT.ELOLD) THEN
28283 C...Begin scenario GH specifics.
28284 ELSEIF(MSTP(115).EQ.5) THEN
28286 C...Loop through all string pieces, one from W+ and one from W-.
28290 IF(K(INP(IIP),2).LT.0) GOTO 380
28294 IF(K(INM(IIM),2).LT.0) GOTO 370
28298 C...Look for largest decrease of (exponent of) Lambda measure.
28299 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28300 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28301 ELDIF=ELNEW/MAX(1D-10,ELOLD)
28302 IF(ELDIF.LT.ELMIN) THEN
28314 C...Common for scenarios I, II, II' and GH: reconnect strings.
28318 DO 390 IS=1,NNP+NNM
28322 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
28324 ELSEIF(IS.LE.IIP+NNM) THEN
28325 I=INM(IS-IIP-NNM+IIM)
28330 IF(K(I,2).LT.0) THEN
28331 CALL PYJOIN(NJOIN,IJOIN)
28336 C...Restore original event record if no reconnection.
28338 DO 400 I=NSD1+1,NOLD
28339 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
28340 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28341 K(I,5)=MOD(K(I,5),MSTU(5)**2)
28350 C...Boost back system.
28351 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
28352 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
28353 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
28354 & BEWW(1),BEWW(2),BEWW(3))
28356 C...Common part for intermediate and instantaneous scenarios.
28357 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
28360 C...Remove old shower products and reset showering ones.
28362 DO 420 I=NSD1+1,NSD1+4
28364 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28365 K(I,5)=MOD(K(I,5),MSTU(5)**2)
28368 C...Identify quark-antiquark pairs.
28372 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
28375 C...Reconnect strings.
28378 CALL PYJOIN(2,IJOIN)
28381 CALL PYJOIN(2,IJOIN)
28383 C...Do new parton showers in intermediate scenario.
28384 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
28387 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
28388 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
28391 C...Do new parton showers in instantaneous scenario.
28392 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
28393 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
28394 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
28395 PPM=SQRT(MAX(0D0,PPM2))
28396 CALL PYSHOW(IQ1,IQ4,PPM)
28397 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
28398 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
28399 PPM=SQRT(MAX(0D0,PPM2))
28400 CALL PYSHOW(IQ3,IQ2,PPM)
28407 C***********************************************************************
28410 C...Checks generated variables against pre-set kinematical limits;
28411 C...also calculates limits on variables used in generation.
28413 SUBROUTINE PYKLIM(ILIM)
28415 C...Double precision and integer declarations.
28416 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28417 IMPLICIT INTEGER(I-N)
28418 INTEGER PYK,PYCHGE,PYCOMP
28420 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28421 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28422 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28423 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28424 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28425 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28426 COMMON/PYINT1/MINT(400),VINT(400)
28427 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28428 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
28431 C...Common kinematical expressions.
28435 IF(ISUB.EQ.96) GOTO 100
28439 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
28440 CKIN09=MAX(CKIN(9),CKIN(13))
28441 CKIN10=MIN(CKIN(10),CKIN(14))
28442 CKIN11=MAX(CKIN(11),CKIN(15))
28443 CKIN12=MIN(CKIN(12),CKIN(16))
28445 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
28446 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
28447 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
28448 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
28453 RM3=SQM3/(TAU*VINT(2))
28454 RM4=SQM4/(TAU*VINT(2))
28455 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
28458 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
28459 &PTHMIN=MAX(CKIN(3),CKIN(5))
28462 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
28463 C...pre-set kinematical limits.
28468 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
28469 X1=SQRT(TAUE)*EXP(YST)
28470 X2=SQRT(TAUE)*EXP(-YST)
28472 IF(MINT(47).NE.1) THEN
28473 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
28474 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
28475 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
28476 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
28478 IF(MINT(45).NE.1) THEN
28479 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
28481 IF(MINT(46).NE.1) THEN
28482 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
28484 IF(MINT(45).EQ.2) THEN
28485 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
28487 IF(MINT(46).EQ.2) THEN
28488 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
28490 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
28491 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
28492 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
28493 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
28494 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
28495 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
28496 Y3=YST+0.5D0*LOG(EXPY3)
28497 Y4=YST+0.5D0*LOG(EXPY4)
28502 STH=SQRT(MAX(0D0,1D0-CTH**2))
28503 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
28504 & CTH)**2-4D0*RM3))
28505 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
28506 & CTH)**2-4D0*RM4))
28507 IF(STH.GE.1D-10) THEN
28508 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
28510 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
28512 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
28513 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
28514 ETALAR=MAX(ETA3,ETA4)
28515 ETASMA=MIN(ETA3,ETA4)
28517 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
28518 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
28519 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
28520 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
28522 RPTS=4D0*VINT(71)**2/SH
28523 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
28524 RM34=MAX(1D-20,2D0*RM3*RM4)
28525 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28526 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28527 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
28528 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
28529 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
28530 IF(PTH.LT.PTHMIN) MINT(51)=1
28531 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
28532 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
28533 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
28534 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
28535 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
28536 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
28537 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
28538 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
28539 IF(THA.LT.CKIN(35)) MINT(51)=1
28540 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
28541 IF(UHA.LT.CKIN(37)) MINT(51)=1
28542 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
28544 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28545 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
28546 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
28549 C...Additional cuts on W2 (approximately) in DIS.
28550 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
28552 IF(IABS(MINT(12)).LT.20) XBJ=X1
28554 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
28555 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
28556 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
28559 ELSEIF(ILIM.EQ.1) THEN
28560 C...Calculate limits on tau
28561 C...0) due to definition
28564 C...1) due to limits on subsystem mass
28565 TAUMN1=CKIN(1)**2/VINT(2)
28567 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
28568 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
28569 TM3=SQRT(SQM3+PTHMIN**2)
28570 TM4=SQRT(SQM4+PTHMIN**2)
28572 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
28573 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
28575 C...3) due to limits on pT-hat and cos(theta-hat)
28576 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
28577 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
28579 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
28580 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
28581 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
28583 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
28584 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
28585 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
28586 C...4) due to limits on x1 and x2
28587 TAUMN4=CKIN(21)*CKIN(23)
28588 TAUMX4=CKIN(22)*CKIN(24)
28589 C...5) due to limits on xF
28591 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
28592 C...6) due to limits on that and uhat
28593 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
28595 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
28596 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
28598 C...Net effect of all separate limits.
28599 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
28600 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
28601 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28604 ELSEIF(MINT(47).EQ.5) THEN
28605 VINT(31)=MIN(VINT(31),1D0-2D-10)
28606 ELSEIF(MINT(47).GE.6) THEN
28607 VINT(31)=MIN(VINT(31),1D0-1D-10)
28609 IF(VINT(31).LE.VINT(11)) MINT(51)=1
28611 ELSEIF(ILIM.EQ.2) THEN
28612 C...Calculate limits on y*
28614 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28616 C...0) due to kinematics
28619 C...1) due to explicit limits
28622 C...2) due to limits on x1
28623 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
28624 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
28625 C...3) due to limits on x2
28626 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
28627 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
28628 C...4) due to limits on xF
28629 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
28630 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
28631 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
28632 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
28633 C...5) due to simultaneous limits on y-large and y-small
28634 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
28635 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
28636 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
28637 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
28638 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
28639 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
28640 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
28642 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
28643 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
28644 RZMX=BE34*MIN(CKIN(28),CTHLIM)
28645 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
28646 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
28647 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
28648 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
28649 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
28650 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
28652 C...Net effect of all separate limits.
28653 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
28654 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
28655 IF(MINT(47).EQ.1) THEN
28658 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28659 VINT(12)=(1D0-1D-9)*YSTMX0
28660 VINT(32)=(1D0+1D-9)*YSTMX0
28661 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28662 VINT(12)=-(1D0+1D-9)*YSTMX0
28663 VINT(32)=-(1D0-1D-9)*YSTMX0
28664 ELSEIF(MINT(47).EQ.5) THEN
28665 YSTEE=LOG((1D0-1D-10)/TAURT)
28666 VINT(12)=MAX(VINT(12),-YSTEE)
28667 VINT(32)=MIN(VINT(32),YSTEE)
28669 IF(VINT(32).LE.VINT(12)) MINT(51)=1
28671 ELSEIF(ILIM.EQ.3) THEN
28672 C...Calculate limits on cos(theta-hat)
28674 C...0) due to definition
28679 C...1) due to explicit limits
28680 CTNMN1=MIN(0D0,CKIN(27))
28681 CTNMX1=MIN(0D0,CKIN(28))
28682 CTPMN1=MAX(0D0,CKIN(27))
28683 CTPMX1=MAX(0D0,CKIN(28))
28684 C...2) due to limits on pT-hat
28685 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
28689 IF(CKIN(4).GE.0D0) THEN
28690 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
28691 & (BE34**2*TAU*VINT(2))))
28694 C...3) due to limits on y-large and y-small
28695 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
28696 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
28697 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
28698 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
28699 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
28700 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
28701 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
28702 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
28703 C...4) due to limits on that
28709 IF(CKIN(35).GT.0D0) THEN
28710 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
28711 IF(CTLIM.GT.0D0) THEN
28718 IF(CKIN(36).GT.0D0) THEN
28719 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
28720 IF(CTLIM.LT.0D0) THEN
28727 C...5) due to limits on uhat
28732 IF(CKIN(37).GT.0D0) THEN
28733 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
28734 IF(CTLIM.LT.0D0) THEN
28741 IF(CKIN(38).GT.0D0) THEN
28742 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
28743 IF(CTLIM.GT.0D0) THEN
28751 C...Net effect of all separate limits.
28752 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
28753 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
28754 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
28755 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
28756 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
28758 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
28759 IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
28761 ELSEIF(ILIM.EQ.4) THEN
28762 C...Calculate limits on tau'
28763 C...0) due to kinematics
28765 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
28766 PQRAT=(VINT(201)+VINT(206))/VINT(1)
28767 TAPMN0=(SQRT(TAU)+PQRAT)**2
28770 C...1) due to explicit limits
28771 TAPMN1=CKIN(31)**2/VINT(2)
28773 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
28775 C...Net effect of all separate limits.
28776 VINT(16)=MAX(TAPMN0,TAPMN1)
28777 VINT(36)=MIN(TAPMX0,TAPMX1)
28778 IF(MINT(47).EQ.1) THEN
28781 ELSEIF(MINT(47).EQ.5) THEN
28782 VINT(36)=MIN(VINT(36),1D0-2D-10)
28783 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
28784 VINT(36)=MIN(VINT(36),1D0-1D-10)
28786 IF(VINT(36).LE.VINT(16)) MINT(51)=1
28791 C...Special case for low-pT and multiple interactions:
28792 C...effective kinematical limits for tau, y*, cos(theta-hat).
28793 100 IF(ILIM.EQ.0) THEN
28794 ELSEIF(ILIM.EQ.1) THEN
28795 IF(MSTP(82).LE.1) THEN
28796 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
28799 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
28802 ELSEIF(ILIM.EQ.2) THEN
28803 VINT(12)=0.5D0*LOG(VINT(21))
28805 ELSEIF(ILIM.EQ.3) THEN
28806 IF(MSTP(82).LE.1) THEN
28807 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
28808 & (VINT(21)*VINT(2))
28810 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
28811 & (VINT(21)*VINT(2))
28813 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
28822 C*********************************************************************
28825 C...Maps a uniform distribution into a distribution of a kinematical
28826 C...variable according to one of the possibilities allowed. It is
28827 C...assumed that kinematical limits have been set by a PYKLIM call.
28829 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
28831 C...Double precision and integer declarations.
28832 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28833 IMPLICIT INTEGER(I-N)
28834 INTEGER PYK,PYCHGE,PYCOMP
28836 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28837 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28838 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28839 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28840 COMMON/PYINT1/MINT(400),VINT(400)
28841 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28842 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
28844 C...Convert VVAR to tau variable.
28850 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
28853 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
28856 ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
28860 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28862 ELSEIF(MVAR.EQ.1) THEN
28863 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
28864 ELSEIF(MVAR.EQ.2) THEN
28865 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
28866 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
28867 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
28868 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
28869 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
28870 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
28871 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
28872 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
28873 ELSEIF(MINT(47).EQ.5) THEN
28874 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
28875 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
28876 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28878 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
28879 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
28880 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28882 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
28884 C...Convert VVAR to y* variable.
28885 ELSEIF(IVAR.EQ.2) THEN
28889 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28890 IF(MINT(47).EQ.1) THEN
28892 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28893 YST=-0.5D0*LOG(TAUE)
28894 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28895 YST=0.5D0*LOG(TAUE)
28896 ELSEIF(MVAR.EQ.1) THEN
28897 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
28898 ELSEIF(MVAR.EQ.2) THEN
28899 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
28900 ELSEIF(MVAR.EQ.3) THEN
28901 AUPP=ATAN(EXP(YSTMAX))
28902 ALOW=ATAN(EXP(YSTMIN))
28903 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
28904 ELSEIF(MVAR.EQ.4) THEN
28905 YST0=-0.5D0*LOG(TAUE)
28906 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
28907 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28908 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
28910 YST0=-0.5D0*LOG(TAUE)
28911 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28912 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
28913 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
28915 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
28917 C...Convert VVAR to cos(theta-hat) variable.
28918 ELSEIF(IVAR.EQ.3) THEN
28919 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
28921 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28922 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28930 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28931 VCTN=VVAR*(ANEG+APOS)/ANEG
28932 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
28934 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28935 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
28937 ELSEIF(MVAR.EQ.2) THEN
28938 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28939 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28940 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28941 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28942 ANEG=LOG(RMNMIN/RMNMAX)
28943 APOS=LOG(RMPMIN/RMPMAX)
28944 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28945 VCTN=VVAR*(ANEG+APOS)/ANEG
28946 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
28948 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28949 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
28951 ELSEIF(MVAR.EQ.3) THEN
28952 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28953 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28954 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28955 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28956 ANEG=LOG(RMNMAX/RMNMIN)
28957 APOS=LOG(RMPMAX/RMPMIN)
28958 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28959 VCTN=VVAR*(ANEG+APOS)/ANEG
28960 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
28962 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28963 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
28965 ELSEIF(MVAR.EQ.4) THEN
28966 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28967 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28968 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28969 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28970 ANEG=1D0/RMNMAX-1D0/RMNMIN
28971 APOS=1D0/RMPMAX-1D0/RMPMIN
28972 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28973 VCTN=VVAR*(ANEG+APOS)/ANEG
28974 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
28976 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28977 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
28979 ELSEIF(MVAR.EQ.5) THEN
28980 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28981 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28982 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28983 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28984 ANEG=1D0/RMNMIN-1D0/RMNMAX
28985 APOS=1D0/RMPMIN-1D0/RMPMAX
28986 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28987 VCTN=VVAR*(ANEG+APOS)/ANEG
28988 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
28990 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28991 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
28994 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
28995 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
28998 C...Convert VVAR to tau' variable.
28999 ELSEIF(IVAR.EQ.4) THEN
29003 IF(MINT(47).EQ.1) THEN
29005 ELSEIF(MVAR.EQ.1) THEN
29006 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
29007 ELSEIF(MVAR.EQ.2) THEN
29008 AUPP=(1D0-TAU/TAUPMX)**4
29009 ALOW=(1D0-TAU/TAUPMN)**4
29010 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
29011 ELSEIF(MINT(47).EQ.5) THEN
29012 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
29013 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
29014 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29016 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
29017 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
29018 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29020 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
29022 C...Selection of extra variables needed in 2 -> 3 process:
29023 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
29024 C...Since no options are available, the functions of PYKLIM
29025 C...and PYKMAP are joint for these choices.
29026 ELSEIF(IVAR.EQ.5) THEN
29028 C...Read out total energy and particle masses.
29031 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
29032 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
29034 SHP=VINT(26)*VINT(2)
29038 PM3=SQRT(VINT(21))*VINT(1)
29039 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
29046 C...Specify coefficients of pT choice; upper and lower limits.
29047 IF(MPTPK.EQ.1) THEN
29055 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
29057 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
29059 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
29061 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
29064 C...Select transverse momenta according to
29065 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
29068 IF(HMX.LT.1.0001D0*HMN) THEN
29074 IF(RPT.LT.HWT1) THEN
29075 PTS1=PTSMN1+PYR(0)*HDE
29076 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29077 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
29079 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
29081 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
29082 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
29085 IF(HMX.LT.1.0001D0*HMN) THEN
29091 IF(RPT.LT.HWT1) THEN
29092 PTS2=PTSMN2+PYR(0)*HDE
29093 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29094 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
29096 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
29098 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
29099 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
29101 C...Select azimuthal angles and check pT choice.
29102 PHI1=PARU(2)*PYR(0)
29103 PHI2=PARU(2)*PYR(0)
29105 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
29106 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
29107 & CKIN(56)**2)) THEN
29112 C...Calculate transverse masses and check phase space not closed.
29119 PM12=(PMT1+PMT2)**2
29120 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
29125 C...Select rapidity for particle 3 and check phase space not closed.
29126 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
29127 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
29128 IF(Y3MAX.LT.1D-6) THEN
29132 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
29136 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
29139 PMS12=PE12**2-PZ12**2
29140 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
29141 IF(SQL12.LT.1D-6*SHP) THEN
29145 PMM1=PMS12+PMS1-PMS2
29146 PMM2=PMS12+PMS2-PMS1
29147 TFAC=-SHPR/(2D0*PMS12)
29148 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
29149 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
29150 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
29151 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
29153 C...Construct relative mirror weights and make choice.
29154 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
29158 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
29159 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
29161 WTP=WTPU/(WTPU+WTNU)
29162 WTN=WTNU/(WTPU+WTNU)
29164 IF(WTN.GT.PYR(0)) EPS=-1D0
29166 C...Store result of variable choice and associated weights.
29176 IF(EPS.GT.0D0) THEN
29185 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
29186 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
29187 VINT(219)=0.5D0*(PMS12-PTS3)
29194 C***********************************************************************
29197 C...Differential matrix elements for all included subprocesses
29198 C...Note that what is coded is (disregarding the COMFAC factor)
29199 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
29200 C...when d(sigma-hat) is given in the zero-width limit, the delta
29201 C...function in tau is replaced by a (modified) Breit-Wigner:
29202 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
29203 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
29204 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
29205 C...i.e., dimensionless quantities
29206 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
29207 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
29208 C...(2pi)^4 delta^4(P - sum p_i)
29209 C...COMFAC contains the factor pi/s (or equivalent) and
29210 C...the conversion factor from GeV^-2 to mb
29212 SUBROUTINE PYSIGH(NCHN,SIGS)
29214 C...Double precision and integer declarations
29215 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29216 IMPLICIT INTEGER(I-N)
29217 INTEGER PYK,PYCHGE,PYCOMP
29218 C...Parameter statement to help give large particle numbers.
29219 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29220 &KEXCIT=4000000,KDIMEN=5000000)
29222 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
29223 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29224 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29225 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29226 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29227 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29228 COMMON/PYINT1/MINT(400),VINT(400)
29229 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29230 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29231 COMMON/PYINT4/MWID(500),WIDS(500,5)
29232 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
29233 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29234 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29235 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29236 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
29237 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
29238 COMMON/PYPUED/IUED(0:99),RUED(0:99)
29239 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29240 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29241 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29242 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29243 COMMON/PYTCCO/COEFX(194:380,2)
29244 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
29245 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
29246 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/
29247 C...Local arrays and complex variables
29248 DIMENSION XPQ(-25:25)
29250 C...Map of processes onto which routine to call
29251 C...in order to evaluate cross section:
29252 C...0 = not implemented;
29253 C...1 = standard QCD (including photons);
29254 C...2 = heavy flavours;
29256 C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
29258 C...6 = Technicolor;
29259 C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29260 C...8 = Universal Extra Dimensions
29261 DIMENSION MAPPR(500)
29262 DATA (MAPPR(I),I=1,180)/
29263 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
29264 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
29265 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
29266 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
29267 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29268 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
29269 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
29270 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
29271 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29272 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
29273 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
29274 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
29275 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
29276 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29277 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
29278 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
29279 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
29280 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
29281 DATA (MAPPR(I),I=181,500)/
29282 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
29283 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
29285 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29286 & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
29288 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
29289 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
29290 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
29291 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
29292 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
29293 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
29295 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29296 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29298 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29299 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29302 C...Reset number of channels and cross-section
29306 C...Read process to consider.
29311 C...Read kinematical variables and limits
29329 C...Derive kinematical quantities
29331 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
29332 X(1)=SQRT(TAUE)*EXP(YST)
29333 X(2)=SQRT(TAUE)*EXP(-YST)
29334 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
29335 IF(X(1).GT.1D0-1D-7) RETURN
29336 ELSEIF(MINT(45).EQ.3) THEN
29337 X(1)=MIN(1D0-1.1D-10,X(1))
29339 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
29340 IF(X(2).GT.1D0-1D-7) RETURN
29341 ELSEIF(MINT(46).EQ.3) THEN
29342 X(2)=MIN(1D0-1.1D-10,X(2))
29344 SH=MAX(1D0,TAU*VINT(2))
29349 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
29350 RPTS=4D0*VINT(71)**2/SH
29351 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
29352 RM34=MAX(1D-20,2D0*RM3*RM4)
29354 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
29355 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
29356 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
29357 IF(ISTSB.EQ.0) THEN
29359 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
29360 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
29362 C...Kinematics with incoming masses tricky: now depends on how
29363 C...subprocess has been set up w.r.t. order of incoming partons.
29365 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
29367 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
29368 IF(ISUB.EQ.35) THEN
29372 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
29373 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
29374 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
29376 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
29378 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
29385 C...Choice of Q2 scale for hard process (e.g. alpha_s).
29386 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
29388 ELSEIF(ISTSB.EQ.8) THEN
29389 IF(MINT(107).EQ.4) Q2=VINT(307)
29390 IF(MINT(108).EQ.4) Q2=VINT(308)
29391 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
29393 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
29395 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
29396 IF(MSTP(32).EQ.1) THEN
29397 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
29398 ELSEIF(MSTP(32).EQ.2) THEN
29399 Q2=SQPTH+0.5D0*(SQM3+SQM4)
29400 ELSEIF(MSTP(32).EQ.3) THEN
29402 ELSEIF(MSTP(32).EQ.4) THEN
29404 ELSEIF(MSTP(32).EQ.5) THEN
29406 ELSEIF(MSTP(32).EQ.6) THEN
29408 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
29410 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
29411 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
29412 & (SQPTH+0.5D0*(SQM3+SQM4))
29413 ELSEIF(MSTP(32).EQ.7) THEN
29414 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
29415 ELSEIF(MSTP(32).EQ.8) THEN
29416 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
29417 ELSEIF(MSTP(32).EQ.9) THEN
29418 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
29419 ELSEIF(MSTP(32).EQ.10) THEN
29422 ELSEIF(MSTP(32).EQ.11) THEN
29423 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
29424 ELSEIF(MSTP(32).EQ.12) THEN
29427 ELSEIF(MSTP(32).EQ.13) THEN
29430 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
29431 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
29432 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
29435 C...Choice of Q2 scale for parton densities.
29438 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
29439 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
29442 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29444 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
29445 & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
29446 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
29447 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
29448 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
29449 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
29450 IF(MSTP(39).EQ.2) Q2SF=
29451 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
29452 IF(MSTP(39).EQ.3) Q2SF=SH
29453 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
29454 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
29456 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
29457 IF(MSTP(39).EQ.7) Q2SF=
29458 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
29459 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
29463 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
29467 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
29468 IF(MSTP(69).GE.2) Q2SF=VINT(2)
29470 C...Identify to which class(es) subprocess belongs
29474 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
29475 & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
29476 & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
29477 & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
29478 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
29479 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
29480 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
29481 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
29482 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
29483 IF (ISTSB.EQ.9) ISQCD=1
29484 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
29485 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
29486 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
29487 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
29488 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
29489 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
29490 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
29491 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
29492 C...WBF is special case of ISJETS
29493 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
29494 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
29495 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
29496 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
29497 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
29498 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
29499 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
29500 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
29501 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
29502 C...Some processes with photons also belong here.
29503 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
29504 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
29505 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
29506 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
29507 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
29508 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
29510 C...Choice of Q2 scale for parton-shower activity.
29511 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
29512 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
29514 IF(MINT(43).EQ.3) XBJ=X(1)
29515 IF(MSTP(22).EQ.1) THEN
29517 ELSEIF(MSTP(22).EQ.2) THEN
29518 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
29519 ELSEIF(MSTP(22).EQ.3) THEN
29520 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
29522 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
29525 C...For multiple interactions, start from scale defined above
29526 C...For all other QCD or "+jets"-type events, start shower from pThard.
29527 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
29528 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
29529 C...Max shower scale = s for ME corrected processes.
29530 C...(pT-ordering: max pT2 is s/4)
29532 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
29533 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
29534 C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
29535 C...(pT-ordering: max pT2 is s/4)
29537 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
29539 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
29541 C...Elastic and diffractive events not associated with scales so set 0.
29542 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
29547 C...Store derived kinematical quantities
29554 IF(ISTSB.NE.8) VINT(48)=SQPTH
29555 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
29556 VINT(50)=TAUP*VINT(2)
29557 VINT(49)=SQRT(MAX(0D0,VINT(50)))
29561 VINT(53)=SQRT(Q2SF)
29563 VINT(55)=SQRT(Q2PS)
29565 C...Set starting scale for multiple interactions
29566 IF (ISUBSV.EQ.95) THEN
29568 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
29569 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
29570 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
29571 & ISUBSV.NE.96)) THEN
29572 C...All accessible phase space allowed.
29573 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
29575 C...Scale of hard process sets limit.
29576 C...2 -> 1. Limit is tau = x1*x2.
29577 C...2 -> 2. Limit is XT2 for hard process + FS masses.
29578 C...2 -> n > 2. Limit is tau' = tau of outer process.
29580 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
29582 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
29583 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
29585 VINT(62)=0.25D0*XT2GMX*VINT(2)
29586 VINT(61)=SQRT(MAX(0D0,VINT(62)))
29588 C...Calculate parton distributions
29589 IF(ISTSB.LE.0) GOTO 160
29590 IF(MINT(47).GE.2) THEN
29591 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
29593 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
29594 IF(ISUB.EQ.99) THEN
29595 IF(MINT(140+I).EQ.0) THEN
29596 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
29598 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
29603 MINT(105)=MINT(102+I)
29604 MINT(109)=MINT(106+I)
29605 VINT(120)=VINT(2+I)
29607 C.... Store side in MINT(124)
29610 IF(MSTP(57).LE.1) THEN
29611 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
29613 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
29615 C...Safety margin against heavy flavour very close to threshold,
29616 C...e.g. caused by mismatch in c and b masses.
29617 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
29621 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
29626 XSFX(I,KFL)=XPQ(KFL)
29631 C...Calculate alpha_em, alpha_strong and K-factor
29634 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
29635 &1D0-(PMAS(24,1)/PMAS(23,1))**2
29637 XWC=1D0/(16D0*XW*XW1)
29639 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
29640 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
29643 IF(MSTP(33).EQ.1) THEN
29645 ELSEIF(MSTP(33).EQ.2) THEN
29647 FACA=PARP(32)/PARP(31)
29648 ELSEIF(MSTP(33).EQ.3) THEN
29650 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
29651 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
29658 C...Set flags for allowed reacting partons/leptons
29663 IF(MINT(44+I).EQ.1) THEN
29664 KFAC(I,MINT(10+I))=1
29665 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
29666 KFAC(I,MINT(10+I))=1
29672 KFAC(I,J)=KFIN(I,J)
29673 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
29674 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
29679 C...Lower and upper limit for fermion flavour loops
29685 IF(KFAC(1,-J).EQ.1) MMIN1=-J
29686 IF(KFAC(1,J).EQ.1) MMAX1=J
29687 IF(KFAC(2,-J).EQ.1) MMIN2=-J
29688 IF(KFAC(2,J).EQ.1) MMAX2=J
29690 MMINA=MIN(MMIN1,MMIN2)
29691 MMAXA=MAX(MMAX1,MMAX2)
29693 C...Common resonance mass and width combinations
29696 GMMZ=PMAS(23,1)*PMAS(23,2)
29697 GMMW=PMAS(24,1)*PMAS(24,2)
29699 C...Polarization factors...implemented so far for W+W-(25)
29700 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
29701 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
29702 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
29703 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
29705 C...Phase space integral in tau
29706 COMFAC=PARU(1)*PARU(5)/VINT(2)
29707 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
29708 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
29709 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
29710 ATAU1=LOG(TAUMAX/TAUMIN)
29711 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
29712 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
29713 IF(MINT(72).GE.1) THEN
29716 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
29718 IF(ATAUD.GT.1D-10) H1=H1+
29719 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
29720 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
29722 IF(ATAUD.GT.1D-10) H1=H1+
29723 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
29725 IF(MINT(72).GE.2) THEN
29728 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
29730 IF(ATAUD.GT.1D-10) H1=H1+
29731 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
29732 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
29734 IF(ATAUD.GT.1D-10) H1=H1+
29735 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
29737 IF(MINT(72).EQ.3) THEN
29740 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
29742 IF(ATAUD.GT.1D-10) H1=H1+
29743 & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
29744 ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
29746 IF(ATAUD.GT.1D-10) H1=H1+
29747 & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
29749 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
29750 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
29751 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
29752 & MAX(2D-10,1D0-TAU)
29753 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
29754 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
29755 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
29756 & MAX(1D-10,1D0-TAU)
29758 COMFAC=COMFAC*ATAU1/(TAU*H1)
29761 C...Phase space integral in y*
29762 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
29764 AYST0=YSTMAX-YSTMIN
29765 IF(AYST0.LT.1D-10) THEN
29768 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29770 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29771 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29772 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29773 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29774 IF(MINT(45).EQ.3) THEN
29775 YST0=-0.5D0*LOG(TAUE)
29776 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
29777 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
29778 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
29779 & MAX(1D-10,1D0-EXP(YST-YST0))
29781 IF(MINT(46).EQ.3) THEN
29782 YST0=-0.5D0*LOG(TAUE)
29783 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
29784 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
29785 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
29786 & MAX(1D-10,1D0-EXP(-YST-YST0))
29788 COMFAC=COMFAC*AYST0/H2
29792 C...2 -> 1 processes: reduction in angular part of phase space integral
29793 C...for case of decaying resonance
29794 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
29795 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
29796 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
29797 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
29798 & KFPR(ISUB,1).EQ.39) THEN
29799 COMFAC=COMFAC*0.5D0*ACTH0
29801 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
29802 & CTPMAX**3-CTPMIN**3)
29806 C...2 -> 2 processes: angular part of phase space integral
29807 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
29808 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
29809 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
29810 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
29811 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
29812 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
29813 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
29814 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
29815 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
29816 H3=COEF(ISUBSV,13)+
29817 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
29818 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
29819 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
29820 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
29821 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
29823 C...2 -> 2 processes: take into account final state Breit-Wigners
29824 COMFAC=COMFAC*VINT(80)
29827 C...2 -> 3, 4 processes: phace space integral in tau'
29828 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29829 ATAUP1=LOG(TAUPMX/TAUPMN)
29830 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
29831 H4=COEF(ISUBSV,18)+
29832 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
29833 IF(MINT(47).EQ.5) THEN
29834 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
29835 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
29836 ELSEIF(MINT(47).GE.6) THEN
29837 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
29838 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
29840 COMFAC=COMFAC*ATAUP1/H4
29843 C...2 -> 3, 4 processes: effective W/Z parton distributions
29844 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
29845 IF(1D0-TAU/TAUP.GT.1D-4) THEN
29846 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
29848 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
29853 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
29854 IF(ISTSB.EQ.5) THEN
29855 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
29856 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
29859 C...Phase space integral for low-pT and multiple interactions
29860 IF(ISTSB.EQ.9) THEN
29861 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
29862 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
29863 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
29864 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
29865 COMFAC=COMFAC*ATAU1/H1
29866 AYST0=YSTMAX-YSTMIN
29867 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29868 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29869 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29870 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29871 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29872 COMFAC=COMFAC*AYST0/H2
29873 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
29874 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
29875 C...introduced to make cross-section finite for xT2 -> 0
29876 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
29880 C...Real gamma + gamma: include factor 2 when different nature
29881 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
29882 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
29884 C...Extra factors to include the effects of
29885 C...longitudinal resolved photons (but not direct or DIS ones).
29887 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
29888 & MINT(106+ISDE).LE.3) THEN
29891 IF(MSTP(16).EQ.0) THEN
29892 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
29893 & XY=VINT(304+ISDE)
29895 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
29896 & XY=VINT(308+ISDE)
29898 Q2GA=VINT(306+ISDE)
29899 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
29900 & Q2GA.GT.0D0) THEN
29902 IF(MSTP(17).EQ.1) THEN
29903 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
29904 ELSEIF(MSTP(17).EQ.2) THEN
29905 REDUCE=4D0*Q2GA/(Q2+Q2GA)
29906 ELSEIF(MSTP(17).EQ.3) THEN
29907 PMVIRT=PMAS(PYCOMP(113),1)
29908 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29909 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
29910 PMVIRT=PMAS(PYCOMP(113),1)
29911 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29912 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
29913 PMVIRT=PMAS(PYCOMP(113),1)
29914 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29915 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
29916 PMVSMN=4D0*PARP(15)**2
29917 PMVSMX=4D0*VINT(154)**2
29918 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29919 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
29920 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
29921 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
29922 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
29923 PMVIRT=PMAS(PYCOMP(113),1)
29924 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29925 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
29926 PMVIRT=PMAS(PYCOMP(113),1)
29927 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29928 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
29929 PMVSMN=4D0*PARP(15)**2
29930 PMVSMX=4D0*VINT(154)**2
29931 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29932 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
29933 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
29936 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
29937 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
29938 & (1D0-2D0*BEAMAS**2/Q2GA))
29939 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
29944 COMFAC=COMFAC*VINT(314+ISDE)
29947 C...Evaluate cross sections - done in separate routines by kind
29948 C...of physics, to keep PYSIGH of sensible size.
29950 C...Standard QCD (including photons).
29951 CALL PYSGQC(NCHN,SIGS)
29952 ELSEIF(MAP.EQ.2) THEN
29953 C...Heavy flavours.
29954 CALL PYSGHF(NCHN,SIGS)
29955 ELSEIF(MAP.EQ.3) THEN
29957 CALL PYSGWZ(NCHN,SIGS)
29958 ELSEIF(MAP.EQ.4) THEN
29959 C...Higgs (2 doublets; including longitudinal W/Z scattering).
29960 CALL PYSGHG(NCHN,SIGS)
29961 ELSEIF(MAP.EQ.5) THEN
29963 CALL PYSGSU(NCHN,SIGS)
29964 ELSEIF(MAP.EQ.6) THEN
29966 CALL PYSGTC(NCHN,SIGS)
29967 ELSEIF(MAP.EQ.7) THEN
29968 C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29969 CALL PYSGEX(NCHN,SIGS)
29970 ELSEIF(MAP.EQ.8) THEN
29971 C... Universal Extra Dimensions
29972 CALL PYXUED(NCHN,SIGS)
29975 C...Multiply with parton distributions
29976 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
29978 IF(MINT(45).GE.2) THEN
29980 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
29982 IF(MINT(46).GE.2) THEN
29984 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
29986 SIGS=SIGS+SIGH(ICHN)
29993 C*********************************************************************
29996 C...Subprocess cross sections for QCD processes,
29997 C...including photons.
29998 C...Auxiliary to PYSIGH.
30000 SUBROUTINE PYSGQC(NCHN,SIGS)
30002 C...Double precision and integer declarations
30003 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30004 IMPLICIT INTEGER(I-N)
30005 INTEGER PYK,PYCHGE,PYCOMP
30006 C...Parameter statement to help give large particle numbers.
30007 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30008 &KEXCIT=4000000,KDIMEN=5000000)
30010 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30011 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30012 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
30013 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30014 COMMON/PYINT1/MINT(400),VINT(400)
30015 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30016 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30017 COMMON/PYINT4/MWID(500),WIDS(500,5)
30018 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
30019 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30020 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30021 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30022 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30023 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
30024 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
30026 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30028 C...Differential cross section expressions.
30030 IF(ISUB.LE.20) THEN
30031 IF(ISUB.EQ.10) THEN
30032 C...f + f' -> f + f' (gamma/Z/W exchange)
30033 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
30034 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
30035 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
30036 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
30037 DO 110 I=MMIN1,MMAX1
30038 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
30040 DO 100 J=MMIN2,MMAX2
30041 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
30043 C...Electroweak couplings
30044 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
30045 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
30047 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
30048 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
30051 C...gamma/Z exchange, only gamma exchange, or only Z exchange
30052 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
30053 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
30054 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
30055 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
30056 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
30057 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30058 ELSEIF(MSTP(21).EQ.2) THEN
30059 FACNCF=FACGGF*EI**2*EJ**2
30061 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
30062 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30064 C...Extrafactor 2 for only one incoming neutrino spin state.
30065 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
30066 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
30074 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
30075 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
30076 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
30077 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
30078 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
30088 ELSEIF(ISUB.EQ.11) THEN
30089 C...f + f' -> f + f' (g exchange)
30090 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30091 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30092 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30093 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
30094 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
30095 DO 130 I=MMIN1,MMAX1
30097 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
30098 DO 120 J=MMIN2,MMAX2
30100 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
30106 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30108 SIGH(NCHN)=0.5D0*SIGH(NCHN)
30113 SIGH(NCHN)=0.5D0*FACQQ2
30118 ELSEIF(ISUB.EQ.12) THEN
30119 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
30120 CALL PYWIDT(21,SH,WDTP,WDTE)
30121 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30122 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
30123 DO 140 I=MMINA,MMAXA
30124 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30125 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
30133 ELSEIF(ISUB.EQ.13) THEN
30134 C...f + fbar -> g + g (q + qbar -> g + g only)
30135 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30137 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30139 DO 150 I=MMINA,MMAXA
30140 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30141 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
30146 SIGH(NCHN)=0.5D0*FACGG1
30151 SIGH(NCHN)=0.5D0*FACGG2
30154 ELSEIF(ISUB.EQ.14) THEN
30155 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
30156 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
30157 DO 160 I=MMINA,MMAXA
30158 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30159 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
30160 EI=KCHG(IABS(I),1)/3D0
30165 SIGH(NCHN)=FACGG*EI**2
30168 ELSEIF(ISUB.EQ.18) THEN
30169 C...f + fbar -> gamma + gamma
30170 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
30171 DO 170 I=MMINA,MMAXA
30172 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
30173 EI=KCHG(IABS(I),1)/3D0
30175 IF(IABS(I).LE.10) FCOI=FACA/3D0
30180 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
30184 ELSEIF(ISUB.LE.40) THEN
30185 IF(ISUB.EQ.28) THEN
30186 C...f + g -> f + g (q + g -> q + g only)
30187 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30189 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30191 DO 190 I=MMINA,MMAXA
30192 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
30194 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
30195 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
30198 ISIG(NCHN,3-ISDE)=21
30203 ISIG(NCHN,3-ISDE)=21
30209 ELSEIF(ISUB.EQ.29) THEN
30210 C...f + g -> f + gamma (q + g -> q + gamma only)
30211 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
30212 DO 210 I=MMINA,MMAXA
30213 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
30214 EI=KCHG(IABS(I),1)/3D0
30217 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
30218 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
30221 ISIG(NCHN,3-ISDE)=21
30227 ELSEIF(ISUB.EQ.33) THEN
30228 C...f + gamma -> f + g (q + gamma -> q + g only)
30229 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
30230 DO 230 I=MMINA,MMAXA
30231 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
30232 EI=KCHG(IABS(I),1)/3D0
30235 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
30236 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
30239 ISIG(NCHN,3-ISDE)=22
30245 ELSEIF(ISUB.EQ.34) THEN
30246 C...f + gamma -> f + gamma
30247 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
30248 DO 250 I=MMINA,MMAXA
30249 IF(I.EQ.0) GOTO 250
30250 EI=KCHG(IABS(I),1)/3D0
30253 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
30254 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
30257 ISIG(NCHN,3-ISDE)=22
30264 ELSEIF(ISUB.LE.80) THEN
30265 IF(ISUB.EQ.53) THEN
30266 C...g + g -> f + fbar (g + g -> q + qbar only)
30267 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
30269 C...Begin by d, u, s flavours.
30271 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30272 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30273 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30274 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30275 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30276 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30277 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30278 & UH2/SH2)*FLAVWT*FACA
30279 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30280 & TH2/SH2)*FLAVWT*FACA
30291 C...Next c and b flavours: modified that and uhat for fixed
30292 C...cos(theta-hat).
30294 SQMAVG=PMAS(IFL,1)**2
30295 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30296 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30297 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30298 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30299 THUHQ=THQ*UHQ-SQMAVG*SH
30300 IF(MSTP(34).EQ.0) THEN
30301 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30302 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30304 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30305 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30306 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30307 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30309 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30310 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30314 ISIG(NCHN,3)=1+2*(IFL-3)
30319 ISIG(NCHN,3)=2+2*(IFL-3)
30325 ELSEIF(ISUB.EQ.54) THEN
30326 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
30327 CALL PYWIDT(21,SH,WDTP,WDTE)
30329 DO 280 I=1,MIN(8,MDCY(21,3))
30331 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30334 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
30335 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30342 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30350 ELSEIF(ISUB.EQ.58) THEN
30351 C...gamma + gamma -> f + fbar
30352 CALL PYWIDT(22,SH,WDTP,WDTE)
30354 DO 290 I=1,MIN(12,MDCY(22,3))
30355 IF(I.LE.8) EF= KCHG(I,1)/3D0
30356 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30357 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30360 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
30361 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30369 ELSEIF(ISUB.EQ.68) THEN
30371 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
30372 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
30374 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
30376 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
30382 SIGH(NCHN)=0.5D0*FACGG1
30387 SIGH(NCHN)=0.5D0*FACGG2
30392 SIGH(NCHN)=0.5D0*FACGG3
30395 ELSEIF(ISUB.EQ.80) THEN
30396 C...q + gamma -> q' + pi+/-
30397 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
30398 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
30399 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
30400 DELSH=UH*SQRT(ASSH*Q2FPSH)
30401 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
30402 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
30403 DELUH=SH*SQRT(ASUH*Q2FPUH)
30404 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
30405 IF(I.EQ.0) GOTO 320
30406 EI=KCHG(IABS(I),1)/3D0
30407 EJ=SIGN(1D0-ABS(EI),EI)
30409 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
30410 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
30413 ISIG(NCHN,3-ISDE)=22
30415 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
30420 ELSEIF(ISUB.LE.100) THEN
30421 IF(ISUB.EQ.91) THEN
30422 C...Elastic scattering
30423 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
30425 ELSEIF(ISUB.EQ.92) THEN
30426 C...Single diffractive scattering (first side, i.e. XB)
30427 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
30429 ELSEIF(ISUB.EQ.93) THEN
30430 C...Single diffractive scattering (second side, i.e. AX)
30431 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
30433 ELSEIF(ISUB.EQ.94) THEN
30434 C...Double diffractive scattering
30435 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
30437 ELSEIF(ISUB.EQ.95) THEN
30438 C...Low-pT scattering
30439 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
30441 ELSEIF(ISUB.EQ.96) THEN
30442 C...Multiple interactions: sum of QCD processes
30443 CALL PYWIDT(21,SH,WDTP,WDTE)
30445 C...q + q' -> q + q'
30446 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30447 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30448 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30449 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
30450 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
30451 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
30453 IF(I.EQ.0) GOTO 340
30455 IF(J.EQ.0) GOTO 330
30461 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30463 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
30468 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
30473 C...q + qbar -> q' + qbar' or g + g
30474 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30475 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
30476 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30478 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30481 IF(I.EQ.0) GOTO 350
30491 SIGH(NCHN)=0.5D0*FACGG1
30496 SIGH(NCHN)=0.5D0*FACGG2
30500 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30502 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30505 IF(I.EQ.0) GOTO 370
30509 ISIG(NCHN,3-ISDE)=21
30514 ISIG(NCHN,3-ISDE)=21
30520 C...g + g -> q + qbar (only d, u, s)
30523 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30524 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30525 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30526 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30527 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30528 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30529 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30530 & UH2/SH2)*FLAVWT*FACA
30531 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30532 & TH2/SH2)*FLAVWT*FACA
30544 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
30547 SQMAVG=PMAS(IFL,1)**2
30548 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30549 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30550 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30551 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30552 THUHQ=THQ*UHQ-SQMAVG*SH
30553 IF(MSTP(34).EQ.0) THEN
30554 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30555 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30557 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30558 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30559 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30560 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30562 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30563 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30567 ISIG(NCHN,3)=531+2*(IFL-3)
30572 ISIG(NCHN,3)=532+2*(IFL-3)
30578 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
30579 & 2D0*TH/SH+TH2/SH2)*FACA
30580 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
30581 & 2D0*SH/UH+SH2/UH2)*FACA
30582 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
30583 & 2D0*UH/TH+UH2/TH2)
30588 SIGH(NCHN)=0.5D0*FACGG1
30593 SIGH(NCHN)=0.5D0*FACGG2
30598 SIGH(NCHN)=0.5D0*FACGG3
30600 ELSEIF(ISUB.EQ.99) THEN
30601 C...f + gamma* -> f.
30602 IF(MINT(107).EQ.4) THEN
30611 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
30612 PM2RHO=PMAS(PYCOMP(113),1)**2
30613 IF(MSTP(19).EQ.0) THEN
30615 ELSEIF(MSTP(19).EQ.1) THEN
30616 COMFAC=COMFAC/(Q2GA+PM2RHO)
30617 ELSEIF(MSTP(19).EQ.2) THEN
30618 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
30620 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
30622 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
30623 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
30624 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
30625 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
30627 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
30629 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
30631 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
30632 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
30634 DO 390 I=MMINA,MMAXA
30635 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
30636 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
30637 EI=KCHG(IABS(I),1)/3D0
30640 ISIG(NCHN,3-ISDE)=22
30642 SIGH(NCHN)=COMFAC*EI**2
30647 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
30648 C...g + g -> gamma + gamma or g + g -> g + gamma
30663 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
30665 EI=KCHG(IABS(I),1)/3D0
30667 IF(ISUB.EQ.115) EIWT=EI
30672 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
30673 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
30676 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
30677 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
30678 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
30679 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
30685 CALL PYWAUX(1,EPSS,W1SR,W1SI)
30686 CALL PYWAUX(1,EPST,W1TR,W1TI)
30687 CALL PYWAUX(1,EPSU,W1UR,W1UI)
30688 CALL PYWAUX(2,EPSS,W2SR,W2SI)
30689 CALL PYWAUX(2,EPST,W2TR,W2TI)
30690 CALL PYWAUX(2,EPSU,W2UR,W2UI)
30691 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
30692 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
30693 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
30694 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
30695 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
30696 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
30697 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
30698 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
30699 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
30700 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
30701 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
30702 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
30703 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
30704 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
30705 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
30706 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
30707 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
30708 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
30709 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
30710 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
30711 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
30712 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
30713 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
30714 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
30715 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
30716 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
30717 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
30718 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
30719 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
30720 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
30721 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
30722 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
30723 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
30724 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
30725 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
30726 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
30727 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
30728 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
30729 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
30730 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
30731 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
30732 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
30733 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
30734 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
30735 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
30736 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
30737 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
30738 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
30739 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
30740 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
30741 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
30742 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
30743 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
30744 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
30745 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
30746 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
30748 A0STUR=A0STUR+EIWT*B0STUR
30749 A0STUI=A0STUI+EIWT*B0STUI
30750 A0TSUR=A0TSUR+EIWT*B0TSUR
30751 A0TSUI=A0TSUI+EIWT*B0TSUI
30752 A0UTSR=A0UTSR+EIWT*B0UTSR
30753 A0UTSI=A0UTSI+EIWT*B0UTSI
30754 A1STUR=A1STUR+EIWT*B1STUR
30755 A1STUI=A1STUI+EIWT*B1STUI
30756 A2STUR=A2STUR+EIWT*B2STUR
30757 A2STUI=A2STUI+EIWT*B2STUI
30759 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
30760 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
30761 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
30762 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
30763 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
30768 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
30769 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
30772 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
30773 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
30775 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30777 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30779 IF(ISUB.EQ.131) THEN
30780 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
30781 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
30783 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
30785 DO 430 I=MMINA,MMAXA
30786 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
30787 EI=KCHG(IABS(I),1)/3D0
30790 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
30791 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
30794 ISIG(NCHN,3-ISDE)=22
30800 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
30801 C...f + gamma*_(T,L) -> f + gamma
30803 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30805 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30807 IF(ISUB.EQ.133) THEN
30808 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
30809 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
30811 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
30813 DO 450 I=MMINA,MMAXA
30814 IF(I.EQ.0) GOTO 450
30815 EI=KCHG(IABS(I),1)/3D0
30818 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
30819 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
30822 ISIG(NCHN,3-ISDE)=22
30828 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
30829 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
30831 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30833 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30835 CALL PYWIDT(21,SH,WDTP,WDTE)
30837 DO 460 I=1,MIN(8,MDCY(21,3))
30839 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30842 IF(ISUB.EQ.135) THEN
30843 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
30844 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
30846 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
30848 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30855 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30863 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
30864 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
30866 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
30868 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
30869 CALL PYWIDT(22,SH,WDTP,WDTE)
30871 DO 470 I=1,MIN(12,MDCY(22,3))
30872 IF(I.LE.8) EF= KCHG(I,1)/3D0
30873 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30874 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30877 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
30878 IF(ISUB.EQ.137) THEN
30879 FPARAM=-SH*(TH+UH)/DLAMB2
30880 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
30881 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
30882 & 2D0*PH1*PH2*FPARAM**2)
30883 ELSEIF(ISUB.EQ.138) THEN
30884 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30885 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
30886 & 2D0*PH1**2*(TH-UH)**2)
30887 ELSEIF(ISUB.EQ.139) THEN
30888 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30889 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
30890 & 2D0*PH2**2*(TH-UH)**2)
30892 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
30893 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
30895 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30909 C*********************************************************************
30912 C...Subprocess cross sections for heavy flavour production,
30913 C...open and closed.
30914 C...Auxiliary to PYSIGH.
30916 SUBROUTINE PYSGHF(NCHN,SIGS)
30918 C...Double precision and integer declarations
30919 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30920 IMPLICIT INTEGER(I-N)
30921 INTEGER PYK,PYCHGE,PYCOMP
30922 C...Parameter statement to help give large particle numbers.
30923 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30924 &KEXCIT=4000000,KDIMEN=5000000)
30926 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30927 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30928 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30929 COMMON/PYINT1/MINT(400),VINT(400)
30930 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30931 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30932 COMMON/PYINT4/MWID(500),WIDS(500,5)
30933 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30934 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30935 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30936 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30937 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
30940 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30942 C...Determine where are charmonium/bottomonium wave function parameters.
30944 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
30946 C...Convert bottomonium process into equivalent charmonium ones.
30947 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
30949 C...Differential cross section expressions.
30951 IF(ISUB.LE.100) THEN
30952 IF(ISUB.EQ.81) THEN
30953 C...q + qbar -> Q + Qbar
30954 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30955 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30956 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30957 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
30959 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
30961 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30962 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30964 DO 100 I=MMINA,MMAXA
30965 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30966 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
30974 ELSEIF(ISUB.EQ.82) THEN
30975 C...g + g -> Q + Qbar
30976 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30977 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30978 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30979 THUHQ=THQ*UHQ-SQMAVG*SH
30980 IF(MSTP(34).EQ.0) THEN
30981 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30982 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30984 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30985 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30986 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30987 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30989 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
30990 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
30991 IF(MSTP(35).GE.1) THEN
30992 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
30993 FACQQ1=FACQQ1*FATRE
30994 FACQQ2=FACQQ2*FATRE
30997 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30998 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31001 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
31014 ELSEIF(ISUB.EQ.83) THEN
31015 C...f + q -> f' + Q
31016 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
31017 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
31018 DO 130 I=MMIN1,MMAX1
31019 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
31020 DO 120 J=MMIN2,MMAX2
31021 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
31022 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
31023 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
31024 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
31030 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31031 & (IABS(I)+1)/2)*VINT(180+J)
31032 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
31033 & (MINT(55)+1)/2)*VINT(180+J)
31036 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31037 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31040 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31041 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31044 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31045 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31047 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
31053 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31054 & (IABS(J)+1)/2)*VINT(180+I)
31055 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
31056 & (MINT(55)+1)/2)*VINT(180+I)
31059 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31060 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31063 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31064 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31067 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31068 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31073 ELSEIF(ISUB.EQ.84) THEN
31074 C...g + gamma -> Q + Qbar
31075 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31076 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31077 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31078 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
31079 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
31081 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
31083 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31084 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31086 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31093 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31101 ELSEIF(ISUB.EQ.85) THEN
31102 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
31103 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31104 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31105 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31106 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
31107 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
31108 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
31109 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
31110 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
31111 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
31112 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
31114 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
31115 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
31116 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
31118 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31126 ELSEIF(ISUB.EQ.86) THEN
31127 C...g + g -> J/Psi + g
31128 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
31129 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31130 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31131 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31139 ELSEIF(ISUB.EQ.87) THEN
31140 C...g + g -> chi_0c + g
31141 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31142 QGTW=(SH*TH*UH)/SH**3
31144 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31145 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31146 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
31147 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
31148 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
31149 & (QGTW*(QGTW-RGTW*PGTW)**4)
31150 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31158 ELSEIF(ISUB.EQ.88) THEN
31159 C...g + g -> chi_1c + g
31160 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31161 QGTW=(SH*TH*UH)/SH**3
31163 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31164 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
31165 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
31166 & (QGTW-RGTW*PGTW)**4
31167 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31175 ELSEIF(ISUB.EQ.89) THEN
31176 C...g + g -> chi_2c + g
31177 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31178 QGTW=(SH*TH*UH)/SH**3
31180 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31181 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31182 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
31183 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
31184 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
31185 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31186 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31195 ELSEIF(ISUB.LE.200) THEN
31196 IF(ISUB.EQ.104) THEN
31197 C...g + g -> chi_c0.
31199 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
31200 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31201 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31202 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31210 ELSEIF(ISUB.EQ.105) THEN
31211 C...g + g -> chi_c2.
31213 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
31214 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31215 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31216 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31224 ELSEIF(ISUB.EQ.106) THEN
31225 C...g + g -> J/Psi + gamma.
31226 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31227 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
31228 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31229 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31230 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31238 ELSEIF(ISUB.EQ.107) THEN
31239 C...g + gamma -> J/Psi + g.
31240 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31241 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
31242 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31243 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31244 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31251 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31259 ELSEIF(ISUB.EQ.108) THEN
31260 C...gamma + gamma -> J/Psi + gamma.
31261 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31262 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
31263 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31264 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31265 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31275 C...Additional code by Stefan Wolf
31278 C...Common code for quarkonium production.
31285 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
31286 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
31288 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
31289 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
31293 IF(MSTP(145).EQ.1) THEN
31294 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
31295 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
31296 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
31297 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
31298 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31299 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31300 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31301 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31302 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
31303 & ISUB.GE.437) THEN
31304 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
31305 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
31306 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31307 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31308 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31309 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31313 SMQQ2=SQMQQ*VINT(2)
31314 C...Polarisation frames
31315 IF(MSTP(146).EQ.1) THEN
31317 POLH1=SQRT(AQ2-SMQQ2)
31318 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31321 AX=AQ*BQ/(POLH1*POLH2)
31323 ELSEIF(MSTP(146).EQ.2) THEN
31324 C...Gottfried Jackson frame
31326 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31329 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
31330 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
31331 ELSEIF(MSTP(146).EQ.3) THEN
31334 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31337 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
31338 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
31339 ELSEIF(MSTP(146).EQ.4) THEN
31340 C...Collins Soper frame
31342 POLH2=SQRT(VINT(2)*POLH1)
31345 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
31346 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
31348 C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
31349 EL1K10=AZ*ATILK1+BZ*BTILK1
31350 EL1K20=AZ*ATILK2+BZ*BTILK2
31353 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
31354 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
31359 IF(ISUB.EQ.421) THEN
31360 C...g + g -> QQ~[3S11] + g
31361 IF(MSTP(145).EQ.0) THEN
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*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
31366 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31367 * & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
31369 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
31370 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
31374 IF(MSTP(147).EQ.0) THEN
31375 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31376 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31377 ELSEIF(MSTP(147).EQ.1) THEN
31378 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31379 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31380 ELSEIF(MSTP(147).EQ.3) THEN
31381 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31382 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31383 ELSEIF(MSTP(147).EQ.4) THEN
31384 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31385 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31386 ELSEIF(MSTP(147).EQ.5) THEN
31387 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31388 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31389 ELSEIF(MSTP(147).EQ.6) THEN
31390 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31391 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31393 FACQQG=COMFAC*FF*FACQQG
31395 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31400 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
31403 ELSEIF(ISUB.EQ.422) THEN
31404 C...g + g -> QQ~[3S18] + g
31405 IF(MSTP(145).EQ.0) THEN
31406 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
31407 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
31409 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
31411 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
31412 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
31413 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
31417 IF(MSTP(147).EQ.0) THEN
31418 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31419 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31420 ELSEIF(MSTP(147).EQ.1) THEN
31421 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31422 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31423 ELSEIF(MSTP(147).EQ.3) THEN
31424 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31425 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31426 ELSEIF(MSTP(147).EQ.4) THEN
31427 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31428 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31429 ELSEIF(MSTP(147).EQ.5) THEN
31430 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31431 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31432 ELSEIF(MSTP(147).EQ.6) THEN
31433 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31434 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31436 FACQQG=COMFAC*FF*FACQQG
31438 C...Split total contribution into different colour flows just like
31439 C...in g g -> g g (recalculate kinematics for massless partons).
31440 THP=-0.5D0*SH*(1D0-CTH)
31441 UHP=-0.5D0*SH*(1D0+CTH)
31442 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31443 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31444 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31445 FACGGS=FACGG1+FACGG2+FACGG3
31446 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31451 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31456 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31461 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
31464 ELSEIF(ISUB.EQ.423) THEN
31465 C...g + g -> QQ~[1S08] + g
31466 IF(MSTP(145).EQ.0) THEN
31467 * FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
31468 * & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
31469 * & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
31470 * & (SHTH2*THUH2*UHSH2)
31471 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
31472 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
31473 & TH2/(SHTH2*THUH2))*
31474 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
31476 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
31477 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
31478 & TH2/(SHTH2*THUH2))*
31479 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
31480 IF(MSTP(147).EQ.0) THEN
31482 ELSEIF(MSTP(147).EQ.1) THEN
31483 FACQQG=COMFAC*2D0*FA
31484 ELSEIF(MSTP(147).EQ.3) THEN
31486 ELSEIF(MSTP(147).EQ.4) THEN
31488 ELSEIF(MSTP(147).EQ.5) THEN
31490 ELSEIF(MSTP(147).EQ.6) THEN
31494 C...Split total contribution into different colour flows just like
31495 C...in g g -> g g (recalculate kinematics for massless partons).
31496 THP=-0.5D0*SH*(1D0-CTH)
31497 UHP=-0.5D0*SH*(1D0+CTH)
31498 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31499 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31500 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31501 FACGGS=FACGG1+FACGG2+FACGG3
31502 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31507 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31512 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31517 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
31520 ELSEIF(ISUB.EQ.424) THEN
31521 C...g + g -> QQ~[3PJ8] + g
31523 IF(MSTP(145).EQ.0) THEN
31524 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
31525 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
31526 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
31528 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
31529 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
31530 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
31532 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
31533 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
31534 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
31536 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
31537 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
31538 & +451D0*SH*TH**5+126D0*TH**6)
31539 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
31540 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
31541 & +171D0*SH*TH**5+42D0*TH**6)
31542 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
31543 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
31544 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
31545 & +99D0*SH*TH**3+35D0*TH**4)
31546 & +7D0*SQMQQ**8*SHTH*POLY)/
31547 & (SH*TH*UH*SQMQQR*SQMQQ*
31548 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
31550 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
31551 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
31552 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
31553 & -SQMQQ*SHTH2*POLY**2*
31554 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
31555 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
31556 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
31557 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
31558 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
31559 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
31560 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
31561 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
31562 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
31563 & +145D0*SH*TH**5+34D0*TH**6)
31564 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
31565 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
31567 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
31568 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
31569 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
31570 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
31571 & +3D0*SQMQQ**8*SHTH*POLY)
31572 BB=4D0*SHTH2*POLY**3
31573 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
31574 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
31575 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
31576 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
31577 & +84D0*SH*TH**9+20D0*TH**10)
31578 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
31579 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
31580 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
31582 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
31583 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
31584 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
31586 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
31587 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
31588 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
31589 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
31590 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
31592 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
31593 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
31594 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
31596 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
31597 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
31598 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
31599 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
31601 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
31602 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
31603 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
31604 & +394D0*SH*TH**9+84D0*TH**10)
31605 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
31606 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
31607 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
31608 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
31609 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
31610 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
31611 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
31612 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
31613 & +266D0*SH*TH**6+84D0*TH**7)
31614 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
31615 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
31617 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
31618 & +7D0*SH*TH**3+4*TH**4)
31619 & +SQMQQ**8*SH*(SH-TH)**2*TH
31620 DD=2D0*TH2*SHTH2*POLY**3
31621 & *(-SH2+2*SH*TH+2*TH2)
31622 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
31623 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
31624 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
31625 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
31626 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
31627 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
31628 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
31629 & -210D0*SH*TH**8-60D0*TH**9)
31630 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
31631 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
31632 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
31634 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
31635 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
31636 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
31637 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
31638 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
31639 & -30D0*SH*TH**6-24D0*TH**7)
31640 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
31641 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
31643 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
31644 IF(MSTP(147).EQ.0) THEN
31645 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31646 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31647 ELSEIF(MSTP(147).EQ.1) THEN
31648 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31649 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31650 ELSEIF(MSTP(147).EQ.3) THEN
31651 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31652 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31653 ELSEIF(MSTP(147).EQ.4) THEN
31654 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31655 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31656 ELSEIF(MSTP(147).EQ.5) THEN
31657 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31658 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31659 ELSEIF(MSTP(147).EQ.6) THEN
31660 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31661 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31663 FACQQG=COMFAC*FF*FACQQG
31665 C...Split total contribution into different colour flows just like
31666 C...in g g -> g g (recalculate kinematics for massless partons).
31667 THP=-0.5D0*SH*(1D0-CTH)
31668 UHP=-0.5D0*SH*(1D0+CTH)
31669 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31670 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31671 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31672 FACGGS=FACGG1+FACGG2+FACGG3
31673 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31678 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
31683 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
31688 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
31691 ELSEIF(ISUB.EQ.425) THEN
31692 C...q + g -> q + QQ~[3S18]
31693 IF(MSTP(145).EQ.0) THEN
31694 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
31695 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
31696 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
31698 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
31699 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
31704 IF(MSTP(147).EQ.0) THEN
31705 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31706 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31707 ELSEIF(MSTP(147).EQ.1) THEN
31708 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31709 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31710 ELSEIF(MSTP(147).EQ.3) THEN
31711 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31712 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31713 ELSEIF(MSTP(147).EQ.4) THEN
31714 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31715 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31716 ELSEIF(MSTP(147).EQ.5) THEN
31717 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31718 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31719 ELSEIF(MSTP(147).EQ.6) THEN
31720 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31721 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31723 FACQQG=COMFAC*FF*FACQQG
31725 C...Split total contribution into different colour flows just like
31726 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31727 C...(recalculate kinematics for massless partons).
31728 THP=-0.5D0*SH*(1D0-CTH)
31729 UHP=-0.5D0*SH*(1D0+CTH)
31730 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31731 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31732 FACQGS=FACQG1+FACQG2
31733 DO 2442 I=MMINA,MMAXA
31734 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
31736 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
31737 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
31740 ISIG(NCHN,3-ISDE)=21
31742 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
31745 ISIG(NCHN,3-ISDE)=21
31747 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
31751 ELSEIF(ISUB.EQ.426) THEN
31752 C...q + g -> q + QQ~[1S08]
31753 IF(MSTP(145).EQ.0) THEN
31754 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
31755 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
31757 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
31758 IF(MSTP(147).EQ.0) THEN
31760 ELSEIF(MSTP(147).EQ.1) THEN
31761 FACQQG=COMFAC*2D0*FA
31762 ELSEIF(MSTP(147).EQ.3) THEN
31764 ELSEIF(MSTP(147).EQ.4) THEN
31766 ELSEIF(MSTP(147).EQ.5) THEN
31768 ELSEIF(MSTP(147).EQ.6) THEN
31772 C...Split total contribution into different colour flows just like
31773 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31774 C...(recalculate kinematics for massless partons).
31775 THP=-0.5D0*SH*(1D0-CTH)
31776 UHP=-0.5D0*SH*(1D0+CTH)
31777 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31778 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31779 FACQGS=FACQG1+FACQG2
31780 DO 2444 I=MMINA,MMAXA
31781 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
31783 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
31784 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
31787 ISIG(NCHN,3-ISDE)=21
31789 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
31792 ISIG(NCHN,3-ISDE)=21
31794 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
31798 ELSEIF(ISUB.EQ.427) THEN
31799 C...q + g -> q + QQ~[3PJ8]
31800 IF(MSTP(145).EQ.0) THEN
31801 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
31802 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
31803 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
31804 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
31806 FF=10D0*PARU(1)*AS**3/
31807 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
31808 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
31809 BB=8D0*(SHTH2+TH*UH)
31810 CC=8D0*UHSH*(SHTH+THUH)
31811 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
31812 IF(MSTP(147).EQ.0) THEN
31813 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31814 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31815 ELSEIF(MSTP(147).EQ.1) THEN
31816 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31817 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31818 ELSEIF(MSTP(147).EQ.3) THEN
31819 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31820 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31821 ELSEIF(MSTP(147).EQ.4) THEN
31822 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31823 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31824 ELSEIF(MSTP(147).EQ.5) THEN
31825 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31826 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31827 ELSEIF(MSTP(147).EQ.6) THEN
31828 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31829 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31831 FACQQG=COMFAC*FF*FACQQG
31833 C...Split total contribution into different colour flows just like
31834 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31835 C...(recalculate kinematics for massless partons).
31836 THP=-0.5D0*SH*(1D0-CTH)
31837 UHP=-0.5D0*SH*(1D0+CTH)
31838 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31839 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31840 FACQGS=FACQG1+FACQG2
31841 DO 2446 I=MMINA,MMAXA
31842 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
31844 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
31845 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
31848 ISIG(NCHN,3-ISDE)=21
31850 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
31853 ISIG(NCHN,3-ISDE)=21
31855 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
31859 ELSEIF(ISUB.EQ.428) THEN
31860 C...q + q~ -> g + QQ~[3S18]
31861 IF(MSTP(145).EQ.0) THEN
31862 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
31863 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
31864 & (SQMQQ*SQMQQR*TH*UH*THUH2)
31866 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
31867 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
31872 IF(MSTP(147).EQ.0) THEN
31873 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31874 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31875 ELSEIF(MSTP(147).EQ.1) THEN
31876 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31877 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31878 ELSEIF(MSTP(147).EQ.3) THEN
31879 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31880 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31881 ELSEIF(MSTP(147).EQ.4) THEN
31882 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31883 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31884 ELSEIF(MSTP(147).EQ.5) THEN
31885 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31886 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31887 ELSEIF(MSTP(147).EQ.6) THEN
31888 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31889 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31891 FACQQG=COMFAC*FF*FACQQG
31893 C...Split total contribution into different colour flows just like
31894 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31895 C...(recalculate kinematics for massless partons).
31896 THP=-0.5D0*SH*(1D0-CTH)
31897 UHP=-0.5D0*SH*(1D0+CTH)
31898 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31899 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31900 FACGGS=FACGG1+FACGG2
31901 DO 2447 I=MMINA,MMAXA
31902 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31903 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
31908 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31913 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31916 ELSEIF(ISUB.EQ.429) THEN
31917 C...q + q~ -> g + QQ~[1S08]
31918 IF(MSTP(145).EQ.0) THEN
31919 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
31920 & (TH2+UH2)/(SQMQQR*SH*THUH2)
31922 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
31923 IF(MSTP(147).EQ.0) THEN
31925 ELSEIF(MSTP(147).EQ.1) THEN
31926 FACQQG=COMFAC*2D0*FA
31927 ELSEIF(MSTP(147).EQ.3) THEN
31929 ELSEIF(MSTP(147).EQ.4) THEN
31931 ELSEIF(MSTP(147).EQ.5) THEN
31933 ELSEIF(MSTP(147).EQ.6) THEN
31937 C...Split total contribution into different colour flows just like
31938 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31939 C...(recalculate kinematics for massless partons).
31940 THP=-0.5D0*SH*(1D0-CTH)
31941 UHP=-0.5D0*SH*(1D0+CTH)
31942 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31943 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31944 FACGGS=FACGG1+FACGG2
31945 DO 2448 I=MMINA,MMAXA
31946 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31947 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
31952 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31957 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31960 ELSEIF(ISUB.EQ.430) THEN
31961 C...q + q~ -> g + QQ~[3PJ8]
31962 IF(MSTP(145).EQ.0) THEN
31963 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
31964 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
31965 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
31966 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
31968 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
31969 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
31970 BB=8D0*(UHSH2+SH*TH)
31971 CC=8D0*(SHTH2+SH*UH)
31972 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
31973 IF(MSTP(147).EQ.0) THEN
31974 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31975 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31976 ELSEIF(MSTP(147).EQ.1) THEN
31977 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31978 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31979 ELSEIF(MSTP(147).EQ.3) THEN
31980 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31981 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31982 ELSEIF(MSTP(147).EQ.4) THEN
31983 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31984 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31985 ELSEIF(MSTP(147).EQ.5) THEN
31986 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31987 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31988 ELSEIF(MSTP(147).EQ.6) THEN
31989 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31990 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31992 FACQQG=COMFAC*FF*FACQQG
31994 C...Split total contribution into different colour flows just like
31995 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31996 C...(recalculate kinematics for massless partons).
31997 THP=-0.5D0*SH*(1D0-CTH)
31998 UHP=-0.5D0*SH*(1D0+CTH)
31999 FACGG1=UH/TH-9D0/4D0*UH2/SH2
32000 FACGG2=TH/UH-9D0/4D0*TH2/SH2
32001 FACGGS=FACGG1+FACGG2
32002 DO 2449 I=MMINA,MMAXA
32003 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32004 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
32009 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
32014 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
32017 ELSEIF(ISUB.EQ.431) THEN
32018 C...g + g -> QQ~[3P01] + g
32019 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32020 QGTW=(SH*TH*UH)/SH**3
32022 IF(MSTP(145).EQ.0) THEN
32023 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32024 & (9D0*RGTW**2*PGTW**4*
32025 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32026 & -6D0*RGTW*PGTW**3*QGTW*
32027 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32028 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32029 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32030 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32032 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
32033 & (9D0*RGTW**2*PGTW**4*
32034 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32035 & -6D0*RGTW*PGTW**3*QGTW*
32036 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32037 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32038 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32039 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32040 IF(MSTP(147).EQ.0) THEN
32042 ELSEIF(MSTP(147).EQ.1) THEN
32043 FACQQG=COMFAC*2D0*FC1
32044 ELSEIF(MSTP(147).EQ.3) THEN
32046 ELSEIF(MSTP(147).EQ.4) THEN
32048 ELSEIF(MSTP(147).EQ.5) THEN
32050 ELSEIF(MSTP(147).EQ.6) THEN
32054 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32059 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32062 ELSEIF(ISUB.EQ.432) THEN
32063 C...g + g -> QQ~[3P11] + g
32064 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32065 QGTW=(SH*TH*UH)/SH**3
32067 IF(MSTP(145).EQ.0) THEN
32068 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
32069 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
32070 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
32071 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
32073 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
32074 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
32075 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
32076 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
32077 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
32078 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32079 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32080 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
32081 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32082 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32083 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
32084 C4=-4D0*THUH*(TH-UH)**2*
32085 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
32086 & -SH2*TH*UH*(TH2+UH2))
32087 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
32088 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
32089 & +SH2*(5D0*THUH2-17D0*TH*UH)))
32090 IF(MSTP(147).EQ.0) THEN
32091 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32092 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32093 ELSEIF(MSTP(147).EQ.1) THEN
32094 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32095 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32096 ELSEIF(MSTP(147).EQ.3) THEN
32097 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32098 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32099 ELSEIF(MSTP(147).EQ.4) THEN
32100 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32101 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32102 ELSEIF(MSTP(147).EQ.5) THEN
32103 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32104 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32105 ELSEIF(MSTP(147).EQ.6) THEN
32106 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32107 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32109 FACQQG=COMFAC*FF*FACQQG
32111 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32116 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32119 ELSEIF(ISUB.EQ.433) THEN
32120 C...g + g -> QQ~[3P21] + g
32121 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32122 QGTW=(SH*TH*UH)/SH**3
32124 IF(MSTP(145).EQ.0) THEN
32125 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32126 & (12D0*RGTW**2*PGTW**4*
32127 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32128 & -3D0*RGTW*PGTW**3*QGTW*
32129 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
32130 & +2D0*PGTW**2*QGTW**2*
32131 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
32132 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
32133 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32135 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
32136 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
32137 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
32139 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
32140 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
32141 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
32142 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
32143 & +10D0*(SH2**2+TH2**2))
32144 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
32145 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
32146 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
32147 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
32148 & +4D0*SH*TH*UH2**4*SHTH2)
32149 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
32150 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
32151 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
32152 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
32153 & +10D0*(SH2**2+UH2**2))
32154 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
32155 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
32156 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
32157 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
32158 & +4D0*SH*UH*TH2**4*UHSH2)
32159 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
32160 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
32161 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
32162 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
32163 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
32164 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
32165 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
32166 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
32167 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
32168 & +3D0*(TH2**3+UH2**3)))
32169 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
32170 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
32171 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
32172 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
32173 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
32174 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
32175 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
32177 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
32179 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
32181 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
32182 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
32183 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
32184 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
32185 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
32186 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
32188 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
32190 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
32192 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
32193 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
32194 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
32195 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
32196 & +4D0*SH*TH2**2*UH2**2*THUH2
32197 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
32198 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
32199 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
32200 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
32201 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32202 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
32203 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
32204 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
32205 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
32206 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
32207 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
32208 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
32209 & +2D0*(TH2**3+UH2**3))
32210 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
32211 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
32212 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
32213 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32214 IF(MSTP(147).EQ.0) THEN
32215 FACQQG=1D0/3D0*(C1*3D0
32216 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32217 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32218 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32219 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32220 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32221 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32222 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32223 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32224 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32225 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32226 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32227 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32228 ELSEIF(MSTP(147).EQ.1) THEN
32230 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32231 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32232 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32233 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32234 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32235 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32236 & +EL1K10*EL2K20*EL1K11*EL2K11)
32237 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32238 & +EL1K10*EL2K20*EL1K21*EL2K21)
32239 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32240 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32241 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32242 & +EL1K20*EL2K20*EL1K11*EL2K11)
32243 ELSEIF(MSTP(147).EQ.2) THEN
32245 & -C2*EL1K11*EL2K11
32246 & -C3*EL1K21*EL2K21
32247 & -C4*EL1K11*EL2K21
32248 & +C5*(EL1K11*EL2K11)**2
32249 & +C6*(EL1K21*EL2K21)**2
32250 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32251 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32252 & +(C9+C0)*(EL1K11*EL2K21)**2)
32254 FACQQG=COMFAC*FF*FACQQG
32256 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32261 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32264 ELSEIF(ISUB.EQ.434) THEN
32265 C...q + g -> q + QQ~[3P01]
32266 IF(MSTP(145).EQ.0) THEN
32267 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
32268 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32270 FA=-PARU(1)*AS**3*(16D0/243D0)*
32271 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32272 IF(MSTP(147).EQ.0) THEN
32274 ELSEIF(MSTP(147).EQ.1) THEN
32275 FACQQG=COMFAC*2D0*FA
32276 ELSEIF(MSTP(147).EQ.3) THEN
32278 ELSEIF(MSTP(147).EQ.4) THEN
32280 ELSEIF(MSTP(147).EQ.5) THEN
32282 ELSEIF(MSTP(147).EQ.6) THEN
32286 DO 2452 I=MMINA,MMAXA
32287 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
32289 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
32290 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
32293 ISIG(NCHN,3-ISDE)=21
32295 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32299 ELSEIF(ISUB.EQ.435) THEN
32300 C...q + g -> q + QQ~[3P11]
32301 IF(MSTP(145).EQ.0) THEN
32302 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
32303 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
32305 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
32310 IF(MSTP(147).EQ.0) THEN
32311 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32312 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32313 ELSEIF(MSTP(147).EQ.1) THEN
32314 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32315 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32316 ELSEIF(MSTP(147).EQ.3) THEN
32317 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32318 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32319 ELSEIF(MSTP(147).EQ.4) THEN
32320 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32321 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32322 ELSEIF(MSTP(147).EQ.5) THEN
32323 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32324 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32325 ELSEIF(MSTP(147).EQ.6) THEN
32326 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32327 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32329 FACQQG=COMFAC*FF*FACQQG
32331 DO 2454 I=MMINA,MMAXA
32332 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
32334 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
32335 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
32338 ISIG(NCHN,3-ISDE)=21
32340 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32344 ELSEIF(ISUB.EQ.436) THEN
32345 C...q + g -> q + QQ~[3P21]
32346 IF(MSTP(145).EQ.0) THEN
32347 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
32348 & ((6D0*SQMQQ**2+TH2)*UHSH2
32349 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
32350 & (SQMQQR*TH*UHSH2**2)
32352 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
32354 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
32363 IF(MSTP(147).EQ.0) THEN
32364 FACQQG=1D0/3D0*(C1*3D0
32365 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32366 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32367 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32368 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32369 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32370 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32371 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32372 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32373 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32374 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32375 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32376 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32377 ELSEIF(MSTP(147).EQ.1) THEN
32379 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32380 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32381 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32382 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32383 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32384 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32385 & +EL1K10*EL2K20*EL1K11*EL2K11)
32386 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32387 & +EL1K10*EL2K20*EL1K21*EL2K21)
32388 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32389 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32390 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32391 & +EL1K20*EL2K20*EL1K11*EL2K11)
32392 ELSEIF(MSTP(147).EQ.2) THEN
32394 & -C2*EL1K11*EL2K11
32395 & -C3*EL1K21*EL2K21
32396 & -C4*EL1K11*EL2K21
32397 & +C5*(EL1K11*EL2K11)**2
32398 & +C6*(EL1K21*EL2K21)**2
32399 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32400 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32401 & +(C9+C0)*(EL1K11*EL2K21)**2)
32403 FACQQG=COMFAC*FF*FACQQG
32405 DO 2456 I=MMINA,MMAXA
32406 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
32408 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
32409 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
32412 ISIG(NCHN,3-ISDE)=21
32414 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32418 ELSEIF(ISUB.EQ.437) THEN
32419 C...q + q~ -> g + QQ~[3P01]
32420 IF(MSTP(145).EQ.0) THEN
32421 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
32422 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
32424 FA=PARU(1)*AS**3*(128D0/729D0)*
32425 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
32426 IF(MSTP(147).EQ.0) THEN
32428 ELSEIF(MSTP(147).EQ.1) THEN
32429 FACQQG=COMFAC*2D0*FA
32430 ELSEIF(MSTP(147).EQ.3) THEN
32432 ELSEIF(MSTP(147).EQ.4) THEN
32434 ELSEIF(MSTP(147).EQ.5) THEN
32436 ELSEIF(MSTP(147).EQ.6) THEN
32440 DO 2457 I=MMINA,MMAXA
32441 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32442 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
32447 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32450 ELSEIF(ISUB.EQ.438) THEN
32451 C...q + q~ -> g + QQ~[3P11]
32452 IF(MSTP(145).EQ.0) THEN
32453 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
32454 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
32456 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
32461 IF(MSTP(147).EQ.0) THEN
32462 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32463 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32464 ELSEIF(MSTP(147).EQ.1) THEN
32465 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32466 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32467 ELSEIF(MSTP(147).EQ.3) THEN
32468 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32469 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32470 ELSEIF(MSTP(147).EQ.4) THEN
32471 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32472 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32473 ELSEIF(MSTP(147).EQ.5) THEN
32474 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32475 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32476 ELSEIF(MSTP(147).EQ.6) THEN
32477 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32478 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32480 FACQQG=COMFAC*FF*FACQQG
32482 DO 2458 I=MMINA,MMAXA
32483 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32484 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
32489 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32492 ELSEIF(ISUB.EQ.439) THEN
32493 C...q + q~ -> g + QQ~[3P21]
32494 IF(MSTP(145).EQ.0) THEN
32495 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
32496 & ((6D0*SQMQQ**2+SH2)*THUH2
32497 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
32498 & (SQMQQR*SH*THUH2**2)
32500 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
32502 C2=4D0*(SH2+UH2+2D0*SH*THUH)
32503 C3=4D0*(SH2+TH2+2D0*SH*THUH)
32504 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
32511 IF(MSTP(147).EQ.0) THEN
32512 FACQQG=1D0/3D0*(C1*3D0
32513 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32514 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32515 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32516 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32517 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32518 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32519 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32520 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32521 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32522 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32523 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32524 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32525 ELSEIF(MSTP(147).EQ.1) THEN
32527 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32528 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32529 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32530 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32531 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32532 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32533 & +EL1K10*EL2K20*EL1K11*EL2K11)
32534 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32535 & +EL1K10*EL2K20*EL1K21*EL2K21)
32536 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32537 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32538 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32539 & +EL1K20*EL2K20*EL1K11*EL2K11)
32540 ELSEIF(MSTP(147).EQ.2) THEN
32542 & -C2*EL1K11*EL2K11
32543 & -C3*EL1K21*EL2K21
32544 & -C4*EL1K11*EL2K21
32545 & +C5*(EL1K11*EL2K11)**2
32546 & +C6*(EL1K21*EL2K21)**2
32547 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32548 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32549 & +(C9+C0)*(EL1K11*EL2K21)**2)
32551 FACQQG=COMFAC*FF*FACQQG
32553 DO 2459 I=MMINA,MMAXA
32554 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32555 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
32560 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32570 C*********************************************************************
32573 C...Subprocess cross sections for W/Z processes,
32574 C...except that longitudinal WW scattering is in Higgs sector.
32575 C...Auxiliary to PYSIGH.
32577 SUBROUTINE PYSGWZ(NCHN,SIGS)
32579 C...Double precision and integer declarations
32580 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32581 IMPLICIT INTEGER(I-N)
32582 INTEGER PYK,PYCHGE,PYCOMP
32583 C...Parameter statement to help give large particle numbers.
32584 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32585 &KEXCIT=4000000,KDIMEN=5000000)
32587 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32588 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32589 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32590 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
32591 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32592 COMMON/PYINT1/MINT(400),VINT(400)
32593 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
32594 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
32595 COMMON/PYINT4/MWID(500),WIDS(500,5)
32596 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
32597 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
32598 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
32599 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
32600 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
32601 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
32602 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
32603 C...Local arrays and complex numbers
32604 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
32606 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
32608 C...Differential cross section expressions.
32610 IF(ISUB.LE.20) THEN
32612 C...f + fbar -> gamma*/Z0
32614 CALL PYWIDT(23,SH,WDTP,WDTE)
32616 FACZ=4D0*COMFAC*3D0
32619 DO 100 I=MMINA,MMAXA
32620 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
32621 EI=KCHG(IABS(I),1)/3D0
32625 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
32627 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
32632 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
32633 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
32634 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
32635 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
32638 ELSEIF(ISUB.EQ.2) THEN
32639 C...f + fbar' -> W+/-
32640 CALL PYWIDT(24,SH,WDTP,WDTE)
32642 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
32643 HP=AEM/(24D0*XW)*SH
32644 DO 120 I=MMIN1,MMAX1
32645 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
32647 DO 110 J=MMIN2,MMAX2
32648 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
32650 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
32651 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32653 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32655 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
32660 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
32661 SIGH(NCHN)=HI*FACBW*HF
32665 ELSEIF(ISUB.EQ.15) THEN
32666 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
32667 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32668 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32672 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32673 DO 130 I=1,MIN(16,MDCY(23,3))
32675 IF(MDME(IDC,1).LT.0) GOTO 130
32677 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32681 AF=SIGN(1D0,EF+0.1D0)
32683 ELSEIF(I.LE.16) THEN
32685 AF=SIGN(1D0,EF+0.1D0)
32688 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32689 IF(4D0*RM1.LT.1D0) THEN
32691 IF(I.LE.8) FCOF=3D0*RADC4
32692 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32694 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32695 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32696 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32697 & AF**2*(1D0-4D0*RM1))*BE34
32701 C...Propagators: as simulated in PYOFSH and as desired
32702 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32706 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32708 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32709 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32710 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32711 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32712 C...Loop over flavours; consider full gamma/Z structure
32713 DO 140 I=MMINA,MMAXA
32714 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32715 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
32716 EI=KCHG(IABS(I),1)/3D0
32723 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
32724 & (VI**2+AI**2)*HFZZ)/HBW4
32727 ELSEIF(ISUB.EQ.16) THEN
32728 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
32729 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32730 C...Propagators: as simulated in PYOFSH and as desired
32731 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32732 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32733 GMMWC=SQRT(SQM4)*WDTP(0)
32734 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32735 FACWG=FACWG*HBW4C/HBW4
32736 DO 160 I=MMIN1,MMAX1
32738 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
32739 DO 150 J=MMIN2,MMAX2
32741 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
32742 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
32743 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32744 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32745 FCKM=VCKM((IA+1)/2,(JA+1)/2)
32750 SIGH(NCHN)=FACWG*FCKM*WIDSC
32754 ELSEIF(ISUB.EQ.19) THEN
32755 C...f + fbar -> gamma + (gamma*/Z0)
32756 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32757 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32761 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32762 DO 170 I=1,MIN(16,MDCY(23,3))
32764 IF(MDME(IDC,1).LT.0) GOTO 170
32766 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32770 AF=SIGN(1D0,EF+0.1D0)
32772 ELSEIF(I.LE.16) THEN
32774 AF=SIGN(1D0,EF+0.1D0)
32777 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32778 IF(4D0*RM1.LT.1D0) THEN
32780 IF(I.LE.8) FCOF=3D0*RADC4
32781 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32783 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32784 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32785 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32786 & AF**2*(1D0-4D0*RM1))*BE34
32790 C...Propagators: as simulated in PYOFSH and as desired
32791 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32795 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32797 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32798 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32799 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32800 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32801 C...Loop over flavours; consider full gamma/Z structure
32802 DO 180 I=MMINA,MMAXA
32803 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
32804 EI=KCHG(IABS(I),1)/3D0
32808 IF(IABS(I).LE.10) FCOI=FACA/3D0
32813 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
32814 & (VI**2+AI**2)*HFZZ)/HBW4
32817 ELSEIF(ISUB.EQ.20) THEN
32818 C...f + fbar' -> gamma + W+/-
32819 FACGW=COMFAC*0.5D0*AEM**2/XW
32820 C...Propagators: as simulated in PYOFSH and as desired
32821 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32822 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32823 GMMWC=SQRT(SQM4)*WDTP(0)
32824 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32825 FACGW=FACGW*HBW4C/HBW4
32826 C...Anomalous couplings
32827 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32830 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
32831 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
32832 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
32833 & (4D0*SQMW))/(TH+UH)**2
32835 DO 200 I=MMIN1,MMAX1
32837 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
32838 DO 190 J=MMIN2,MMAX2
32840 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
32841 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
32842 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32844 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32845 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32847 FACWR=UH/(TH+UH)-1D0/3D0
32848 FCKM=VCKM((IA+1)/2,(JA+1)/2)
32855 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
32860 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
32865 ELSEIF(ISUB.LE.40) THEN
32866 IF(ISUB.EQ.22) THEN
32867 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
32868 C...Kinematics dependence
32869 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
32870 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
32871 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32877 RADC3=1D0+PYALPS(SQM3)/PARU(1)
32878 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32879 DO 230 I=1,MIN(16,MDCY(23,3))
32881 IF(MDME(IDC,1).LT.0) GOTO 230
32883 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
32884 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
32887 AF=SIGN(1D0,EF+0.1D0)
32889 ELSEIF(I.LE.16) THEN
32891 AF=SIGN(1D0,EF+0.1D0)
32894 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
32895 IF(4D0*RM1.LT.1D0) THEN
32897 IF(I.LE.8) FCOF=3D0*RADC3
32898 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32900 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32901 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32902 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32903 & AF**2*(1D0-4D0*RM1))*BE34
32906 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32907 IF(4D0*RM1.LT.1D0) THEN
32909 IF(I.LE.8) FCOF=3D0*RADC4
32910 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32912 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32913 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32914 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32915 & AF**2*(1D0-4D0*RM1))*BE34
32919 C...Propagators: as simulated in PYOFSH and as desired
32920 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32921 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32925 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32927 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32929 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
32930 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
32931 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
32936 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32938 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32940 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
32941 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
32942 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
32944 C...Loop over flavours; separate left- and right-handed couplings
32945 DO 270 I=MMINA,MMAXA
32946 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
32947 EI=KCHG(IABS(I),1)/3D0
32953 IF(IABS(I).LE.10) FCOI=FACA/3D0
32955 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
32956 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
32957 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
32958 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
32960 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
32961 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
32962 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
32963 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
32968 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
32971 ELSEIF(ISUB.EQ.23) THEN
32972 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
32973 FACZW=COMFAC*0.5D0*(AEM/XW)**2
32974 FACZW=FACZW*WIDS(23,2)
32975 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32976 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
32977 DO 290 I=MMIN1,MMAX1
32979 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
32980 DO 280 J=MMIN2,MMAX2
32982 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
32983 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
32984 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32986 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32988 AI=SIGN(1D0,EI+0.1D0)
32991 AJ=SIGN(1D0,EJ+0.1D0)
32993 IF(VI+AI.GT.0) THEN
33002 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33004 IF(IA.LE.10) FCOI=FACA/3D0
33009 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
33010 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
33011 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
33012 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
33013 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
33014 & WIDS(24,(5-KCHW)/2)
33015 C***Protect against slightly negative cross sections. (Reason yet to be
33016 C***sorted out. One possibility: addition of width to the W propagator.)
33017 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
33021 ELSEIF(ISUB.EQ.25) THEN
33022 C...f + fbar -> W+ + W-
33023 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
33025 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
33026 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33027 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33028 GMMW3=SQRT(SQM3)*WDTP(0)
33029 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33030 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33031 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33032 GMMW4=SQRT(SQM4)*WDTP(0)
33033 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
33034 C...Kinematical functions
33035 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33036 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
33037 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
33038 GT=THUH34+4D0*THUH/TH2
33039 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
33040 GU=THUH34+4D0*THUH/UH2
33041 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
33042 C...Common factors and couplings
33043 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
33044 FACWW=FACWW*WIDS(24,1)
33046 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
33047 CZZ=AEM**2/(32D0*XW**2)*HBWZC
33048 CNG=AEM**2/(4D0*XW)
33049 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
33050 CNN=AEM**2/(16D0*XW**2)
33051 C...Coulomb factor for W+W- pair
33052 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
33053 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
33054 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
33055 IF(COULE.LT.100D0*PMAS(24,2)) THEN
33056 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33057 & PMAS(24,2)**2)-COULE))
33059 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
33061 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
33062 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33063 & PMAS(24,2)**2)+COULE))
33065 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
33068 IF(MSTP(40).EQ.1) THEN
33069 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
33070 & MAX(1D-10,2D0*COULP*COULP1))
33071 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33072 ELSEIF(MSTP(40).EQ.2) THEN
33073 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
33074 COULCP=DCMPLX(0D0,DBLE(COULP))
33075 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
33076 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
33077 & (4D0*COULCP)*LOG(COULCD)
33078 COULCS=DCMPLX(0D0,0D0)
33081 COULXX=(ISTP-0.5)/NSTP
33082 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
33083 & (1D0+COULXX/COULCD))
33085 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
33087 FACCOU=ABS(COULCR)**2
33088 ELSEIF(MSTP(40).EQ.3) THEN
33089 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
33090 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
33091 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33093 ELSEIF(MSTP(40).EQ.4) THEN
33094 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
33100 C...Loop over allowed flavours
33101 DO 310 I=MMINA,MMAXA
33102 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
33103 EI=KCHG(IABS(I),1)/3D0
33104 AI=SIGN(1D0,EI+0.1D0)
33107 IF(IABS(I).LE.10) FCOI=FACA/3D0
33108 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
33110 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
33111 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
33113 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
33114 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
33117 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
33118 BET=SQRT(1D0-4D0*XMW02/SH)
33119 GAT=1D0/SQRT(1D0-BET**2)
33121 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
33122 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
33123 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
33124 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
33125 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
33126 & (1D0-2D0*BET*CTH+BET**2))
33127 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
33128 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
33129 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
33130 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
33131 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
33132 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
33133 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
33140 SIGH(NCHN)=FACWW*FCOI*DSIGWW
33143 ELSEIF(ISUB.EQ.30) THEN
33144 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
33145 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
33147 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33151 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33152 DO 320 I=1,MIN(16,MDCY(23,3))
33154 IF(MDME(IDC,1).LT.0) GOTO 320
33156 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33160 AF=SIGN(1D0,EF+0.1D0)
33162 ELSEIF(I.LE.16) THEN
33164 AF=SIGN(1D0,EF+0.1D0)
33167 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33168 IF(4D0*RM1.LT.1D0) THEN
33170 IF(I.LE.8) FCOF=3D0*RADC4
33171 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33173 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33174 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33175 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33176 & AF**2*(1D0-4D0*RM1))*BE34
33180 C...Propagators: as simulated in PYOFSH and as desired
33181 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33185 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33187 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33188 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33189 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33190 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33191 C...Loop over flavours; consider full gamma/Z structure
33192 DO 340 I=MMINA,MMAXA
33193 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
33194 EI=KCHG(IABS(I),1)/3D0
33197 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
33198 & (VI**2+AI**2)*HFZZ)/HBW4
33200 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
33201 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
33204 ISIG(NCHN,3-ISDE)=21
33210 ELSEIF(ISUB.EQ.31) THEN
33211 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
33212 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
33213 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
33214 C...Propagators: as simulated in PYOFSH and as desired
33215 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33216 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33217 GMMWC=SQRT(SQM4)*WDTP(0)
33218 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33219 FACWQ=FACWQ*HBW4C/HBW4
33220 DO 360 I=MMINA,MMAXA
33221 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
33223 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33224 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33226 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
33227 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
33230 ISIG(NCHN,3-ISDE)=21
33232 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33236 ELSEIF(ISUB.EQ.35) THEN
33237 C...f + gamma -> f + (gamma*/Z0)
33238 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
33239 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
33240 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
33241 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
33242 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
33243 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
33245 FZQN=SH2+UH2+2D0*SQM4*TH
33248 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
33249 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33253 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33254 DO 370 I=1,MIN(16,MDCY(23,3))
33256 IF(MDME(IDC,1).LT.0) GOTO 370
33258 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33262 AF=SIGN(1D0,EF+0.1D0)
33264 ELSEIF(I.LE.16) THEN
33266 AF=SIGN(1D0,EF+0.1D0)
33269 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33270 IF(4D0*RM1.LT.1D0) THEN
33272 IF(I.LE.8) FCOF=3D0*RADC4
33273 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33275 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33276 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33277 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33278 & AF**2*(1D0-4D0*RM1))*BE34
33282 C...Propagators: as simulated in PYOFSH and as desired
33283 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33287 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33289 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33290 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33291 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33292 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33293 C...Loop over flavours; consider full gamma/Z structure
33294 DO 390 I=MMINA,MMAXA
33295 IF(I.EQ.0) GOTO 390
33296 EI=KCHG(IABS(I),1)/3D0
33299 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
33300 & (VI**2+AI**2)*HFZZ)/HBW4
33301 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
33303 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
33304 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
33307 ISIG(NCHN,3-ISDE)=22
33309 SIGH(NCHN)=FACZQ*FZQN/FZQD
33313 ELSEIF(ISUB.EQ.36) THEN
33314 C...f + gamma -> f' + W+/-
33315 FWQ=COMFAC*AEM**2/(2D0*XW)*
33316 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
33317 C...Propagators: as simulated in PYOFSH and as desired
33318 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33319 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33320 GMMWC=SQRT(SQM4)*WDTP(0)
33321 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33323 DO 410 I=MMINA,MMAXA
33324 IF(I.EQ.0) GOTO 410
33326 EIA=ABS(KCHG(IABS(I),1)/3D0)
33327 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
33328 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33329 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33331 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
33332 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
33335 ISIG(NCHN,3-ISDE)=22
33337 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33342 ELSEIF(ISUB.LE.100) THEN
33343 IF(ISUB.EQ.69) THEN
33344 C...gamma + gamma -> W+ + W-
33345 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
33346 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
33347 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
33348 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
33349 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
33357 ELSEIF(ISUB.EQ.70) THEN
33358 C...gamma + W+/- -> Z0 + W+/-
33359 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
33360 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
33361 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
33362 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
33363 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
33364 DO 440 KCHW=1,-1,-2
33366 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
33369 ISIG(NCHN,3-ISDE)=24*KCHW
33371 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
33380 C*********************************************************************
33383 C...Subprocess cross sections for Higgs processes,
33384 C...except Higgs pairs in PYSGSU, but including WW scattering.
33385 C...Auxiliary to PYSIGH.
33387 SUBROUTINE PYSGHG(NCHN,SIGS)
33389 C...Double precision and integer declarations
33390 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33391 IMPLICIT INTEGER(I-N)
33392 INTEGER PYK,PYCHGE,PYCOMP
33393 C...Parameter statement to help give large particle numbers.
33394 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33395 &KEXCIT=4000000,KDIMEN=5000000)
33397 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33398 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33399 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
33400 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33401 COMMON/PYINT1/MINT(400),VINT(400)
33402 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33403 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33404 COMMON/PYINT4/MWID(500),WIDS(500,5)
33405 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
33406 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33407 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33408 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33409 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33410 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33411 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
33412 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
33413 C...Local arrays and complex variables
33414 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
33415 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
33416 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
33418 C...Convert H or A process into equivalent h one
33421 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
33422 KFHIGG=KFPR(ISUB,1)
33424 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
33425 &ISUB.LE.190)) THEN
33427 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
33429 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
33430 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
33431 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
33432 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
33433 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
33434 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
33435 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
33436 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
33437 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
33438 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
33439 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
33440 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
33442 SQMH=PMAS(KFHIGG,1)**2
33443 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
33445 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33446 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
33447 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
33448 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
33449 IF(MSTP(46).LE.4) THEN
33450 HDTLH=LOG(PMAS(25,1)/PARP(44))
33451 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
33452 HDTNR=-1D0/18D0+HDTLH/6D0
33454 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
33455 HDTLQ=LOG(PARP(45)/PARP(44))
33456 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
33457 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
33460 C...Calculate lowest and next-to-lowest order partial wave amplitudes
33461 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
33465 HDTLS=LOG(SH/PARP(44)**2)
33466 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
33467 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
33468 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
33469 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
33470 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
33471 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
33472 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
33473 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
33475 C...Unitarize partial wave amplitudes with Pade or K-matrix method
33476 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
33477 A00U=A00L/(1D0-A004/A00L)
33478 A20U=A20L/(1D0-A204/A20L)
33479 A11U=A11L/(1D0-A114/A11L)
33481 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
33482 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
33483 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
33487 C...Differential cross section expressions.
33489 IF(ISUB.LE.60) THEN
33491 C...f + fbar -> h0 (or H0, or A0)
33492 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33494 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33495 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33497 HP=AEM/(8D0*XW)*SH/SQMW*SH
33498 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33499 DO 100 I=MMINA,MMAXA
33500 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
33502 RMQ=PYMRUN(IA,SH)**2/SH
33504 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
33505 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33507 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33508 IF(IA.GT.10) IKFI=3
33509 HI=HI*PARU(150+10*IHIGG+IKFI)**2
33510 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33511 HI=HI/(1D0+RMSS(41))**2
33512 IF(IHIGG.NE.3) THEN
33513 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33514 & PARU(151+10*IHIGG))**2
33522 SIGH(NCHN)=HI*FACBW*HF
33525 ELSEIF(ISUB.EQ.5) THEN
33527 CALL PYWIDT(25,SH,WDTP,WDTE)
33529 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33530 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
33531 HP=AEM/(8D0*XW)*SH/SQMW*SH
33532 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33534 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
33535 DO 120 I=MMIN1,MMAX1
33536 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
33537 DO 110 J=MMIN2,MMAX2
33538 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
33539 EI=KCHG(IABS(I),1)/3D0
33542 EJ=KCHG(IABS(J),1)/3D0
33549 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
33553 ELSEIF(ISUB.EQ.8) THEN
33555 CALL PYWIDT(25,SH,WDTP,WDTE)
33557 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33558 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
33559 HP=AEM/(8D0*XW)*SH/SQMW*SH
33560 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33562 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
33563 DO 140 I=MMIN1,MMAX1
33564 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
33565 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33566 DO 130 J=MMIN2,MMAX2
33567 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
33568 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33569 IF(EI*EJ.GT.0D0) GOTO 130
33574 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
33578 ELSEIF(ISUB.EQ.24) THEN
33579 C...f + fbar -> Z0 + h0 (or H0, or A0)
33580 C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
33581 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
33582 CALL PYWIDT(23,SQM3,WDTP,WDTE)
33583 GMMZ3=SQRT(SQM3)*WDTP(0)
33584 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
33585 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33586 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33587 GMMH4=SQRT(SQM4)*WDTP(0)
33588 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
33589 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33590 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
33591 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
33592 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
33593 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
33594 & PARU(154+10*IHIGG)**2
33595 DO 150 I=MMINA,MMAXA
33596 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
33597 EI=KCHG(IABS(I),1)/3D0
33601 IF(IABS(I).LE.10) FCOI=FACA/3D0
33606 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
33609 ELSEIF(ISUB.EQ.26) THEN
33610 C...f + fbar' -> W+/- + h0 (or H0, or A0)
33611 C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
33612 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33613 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33614 GMMW3=SQRT(SQM3)*WDTP(0)
33615 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33616 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33617 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33618 GMMH4=SQRT(SQM4)*WDTP(0)
33619 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
33620 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33621 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
33622 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
33623 FACHW=FACHW*WIDS(KFHIGG,2)
33624 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
33625 & PARU(155+10*IHIGG)**2
33626 DO 170 I=MMIN1,MMAX1
33628 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
33629 DO 160 J=MMIN2,MMAX2
33631 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
33632 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
33633 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33635 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33637 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33639 IF(IA.LE.10) FCOI=FACA/3D0
33644 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
33648 ELSEIF(ISUB.EQ.32) THEN
33649 C...f + g -> f + h0 (q + g -> q + h0 only)
33650 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
33651 C...H propagator: as simulated in PYOFSH and as desired
33652 SQMHC=PMAS(25,1)**2
33653 GMMHC=PMAS(25,1)*PMAS(25,2)
33654 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
33655 CALL PYWIDT(25,SQM4,WDTP,WDTE)
33656 GMMHCC=SQRT(SQM4)*WDTP(0)
33657 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
33658 FHCQ=FHCQ*HBW4C/HBW4
33659 DO 190 I=MMINA,MMAXA
33661 IF(IA.NE.5) GOTO 190
33662 SQML=PYMRUN(IA,SH)**2
33664 FACHCQ=FHCQ*SQML/SQMW*
33665 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
33666 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
33667 & (SQM4-SQMQ-SH)/SH)
33669 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
33670 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
33673 ISIG(NCHN,3-ISDE)=21
33675 SIGH(NCHN)=FACHCQ*WIDS(25,2)
33680 ELSEIF(ISUB.LE.80) THEN
33681 IF(ISUB.EQ.71) THEN
33682 C...Z0 + Z0 -> Z0 + Z0
33683 IF(SH.LE.4.01D0*SQMZ) GOTO 220
33685 IF(MSTP(46).LE.2) THEN
33686 C...Exact scattering ME:s for on-mass-shell gauge bosons
33687 BE2=1D0-4D0*SQMZ/SH
33688 TH=-0.5D0*SH*BE2*(1D0-CTH)
33689 UH=-0.5D0*SH*BE2*(1D0+CTH)
33690 IF(MAX(TH,UH).GT.-1D0) GOTO 220
33691 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
33692 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33693 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33694 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
33695 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33696 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33697 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
33698 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33699 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33700 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
33701 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
33702 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33703 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
33704 & (ASHIM+ATHIM+AUHIM)**2)
33705 IF(MSTP(46).EQ.2) FACZZ=0D0
33708 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33709 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
33710 & ABS(A00U+2D0*A20U)**2
33712 FACZZ=FACZZ*WIDS(23,1)
33714 DO 210 I=MMIN1,MMAX1
33715 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
33716 EI=KCHG(IABS(I),1)/3D0
33720 DO 200 J=MMIN2,MMAX2
33721 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
33722 EJ=KCHG(IABS(J),1)/3D0
33730 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
33735 ELSEIF(ISUB.EQ.72) THEN
33736 C...Z0 + Z0 -> W+ + W-
33737 IF(SH.LE.4.01D0*SQMZ) GOTO 250
33739 IF(MSTP(46).LE.2) THEN
33740 C...Exact scattering ME:s for on-mass-shell gauge bosons
33741 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33743 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33744 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33745 IF(MAX(TH,UH).GT.-1D0) GOTO 250
33746 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33747 & (1D0-2D0*SQMZ/SH)
33748 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33749 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33750 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33751 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33752 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33753 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33754 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33756 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33757 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33758 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33759 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33760 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33762 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33764 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
33765 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
33766 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
33767 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33768 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33769 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
33770 & (ATWIM+AUWIM+A4IM)**2)
33773 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33774 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
33775 & ABS(A00U-A20U)**2
33777 FACWW=FACWW*WIDS(24,1)
33779 DO 240 I=MMIN1,MMAX1
33780 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
33781 EI=KCHG(IABS(I),1)/3D0
33785 DO 230 J=MMIN2,MMAX2
33786 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
33787 EJ=KCHG(IABS(J),1)/3D0
33795 SIGH(NCHN)=FACWW*AVI*AVJ
33800 ELSEIF(ISUB.EQ.73) THEN
33801 C...Z0 + W+/- -> Z0 + W+/-
33802 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
33804 IF(MSTP(46).LE.2) THEN
33805 C...Exact scattering ME:s for on-mass-shell gauge bosons
33806 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
33807 EP1=1D0-(SQMZ-SQMW)/SH
33808 EP2=1D0+(SQMZ-SQMW)/SH
33809 TH=-0.5D0*SH*BE2*(1D0-CTH)
33810 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
33811 IF(MAX(TH,UH).GT.-1D0) GOTO 280
33812 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
33813 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33814 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33815 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
33816 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
33817 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
33818 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
33820 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
33821 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
33822 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
33823 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
33824 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
33825 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
33826 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
33827 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
33828 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
33829 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
33830 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
33831 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
33833 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
33834 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
33836 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
33837 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
33838 IF(MSTP(46).LE.0) FACZW=0D0
33839 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
33840 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
33841 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
33842 & (ASWIM+AUWIM+A4IM)**2)
33845 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33846 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
33847 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
33849 FACZW=FACZW*WIDS(23,2)
33851 DO 270 I=MMIN1,MMAX1
33852 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
33853 EI=KCHG(IABS(I),1)/3D0
33857 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
33858 DO 260 J=MMIN2,MMAX2
33859 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
33860 EJ=KCHG(IABS(J),1)/3D0
33864 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
33869 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
33874 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
33879 ELSEIF(ISUB.EQ.75) THEN
33880 C...W+ + W- -> gamma + gamma
33882 ELSEIF(ISUB.EQ.76) THEN
33883 C...W+ + W- -> Z0 + Z0
33884 IF(SH.LE.4.01D0*SQMZ) GOTO 310
33886 IF(MSTP(46).LE.2) THEN
33887 C...Exact scattering ME:s for on-mass-shell gauge bosons
33888 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33890 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33891 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33892 IF(MAX(TH,UH).GT.-1D0) GOTO 310
33893 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33894 & (1D0-2D0*SQMZ/SH)
33895 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33896 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33897 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33898 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33899 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33900 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33901 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33903 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33904 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33905 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33906 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33907 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33909 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33911 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33913 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33914 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33915 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33916 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
33917 & (ATWIM+AUWIM+A4IM)**2)
33920 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33921 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33922 & ABS(A00U-A20U)**2
33924 FACZZ=FACZZ*WIDS(23,1)
33926 DO 300 I=MMIN1,MMAX1
33927 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
33928 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33929 DO 290 J=MMIN2,MMAX2
33930 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
33931 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33932 IF(EI*EJ.GT.0D0) GOTO 290
33937 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
33942 ELSEIF(ISUB.EQ.77) THEN
33943 C...W+/- + W+/- -> W+/- + W+/-
33944 IF(SH.LE.4.01D0*SQMW) GOTO 340
33946 IF(MSTP(46).LE.2) THEN
33947 C...Exact scattering ME:s for on-mass-shell gauge bosons
33948 BE2=1D0-4D0*SQMW/SH
33952 TH=-0.5D0*SH*BE2*(1D0-CTH)
33953 UH=-0.5D0*SH*BE2*(1D0+CTH)
33954 IF(MAX(TH,UH).GT.-1D0) GOTO 340
33956 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33957 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33959 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33960 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33962 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33963 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33964 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
33967 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
33969 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
33970 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
33971 ATGRE=0.5D0*XW*SH/TH*TGZANG
33973 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
33975 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
33976 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
33977 AUGRE=0.5D0*XW*SH/UH*UGZANG
33979 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
33981 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
33983 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
33985 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33987 IF(MSTP(46).LE.0) THEN
33992 ELSEIF(MSTP(46).EQ.1) THEN
33993 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33994 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33995 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33996 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33998 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33999 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
34000 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
34001 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
34003 AWWA2=AWWARE**2+AWWAIM**2
34004 AWWS2=AWWSRE**2+AWWSIM**2
34007 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34008 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
34009 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
34010 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
34013 DO 330 I=MMIN1,MMAX1
34014 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
34015 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34016 DO 320 J=MMIN2,MMAX2
34017 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
34018 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34019 IF(EI*EJ.LT.0D0) THEN
34021 IF(MSTP(45).EQ.1) GOTO 320
34022 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
34023 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
34026 IF(MSTP(45).EQ.2) GOTO 320
34027 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
34028 IF(MSTP(46).GE.3) FACWW=FWWS
34029 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
34030 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
34036 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
34037 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
34043 ELSEIF(ISUB.LE.120) THEN
34044 IF(ISUB.EQ.102) THEN
34045 C...g + g -> h0 (or H0, or A0)
34046 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34048 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34049 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34050 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34052 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34053 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34055 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34056 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34057 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34059 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34060 & '(PYSGHG:) did not find Higgs -> g g channel')
34063 HI=SHR*WDTP(13)/32D0
34065 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
34070 SIGH(NCHN)=HI*FACBW*HF
34073 ELSEIF(ISUB.EQ.103) THEN
34074 C...gamma + gamma -> h0 (or H0, or A0)
34075 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34077 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34078 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34079 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34081 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34082 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34084 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34085 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
34086 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
34088 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
34089 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
34092 HI=SHR*WDTP(14)*2D0
34094 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
34099 SIGH(NCHN)=HI*FACBW*HF
34102 ELSEIF(ISUB.EQ.110) THEN
34103 C...f + fbar -> gamma + h0
34104 THUH=MAX(TH*UH,SH*CKIN(3)**2)
34105 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
34106 FACHG=FACHG*WIDS(KFHIGG,2)
34107 C...Calculate loop contributions for intermediate gamma* and Z0
34108 CIGTOT=DCMPLX(0D0,0D0)
34109 CIZTOT=DCMPLX(0D0,0D0)
34112 IF(J.LE.2*MSTP(1)) THEN
34115 AJ=SIGN(1D0,EJ+0.1D0)
34117 BALP=SQM4/(2D0*PMAS(J,1))**2
34118 BBET=SH/(2D0*PMAS(J,1))**2
34119 ELSEIF(J.LE.3*MSTP(1)) THEN
34121 JL=2*(J-2*MSTP(1))-1
34122 EJ=KCHG(10+JL,1)/3D0
34123 AJ=SIGN(1D0,EJ+0.1D0)
34125 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
34126 BBET=SH/(2D0*PMAS(10+JL,1))**2
34128 BALP=SQM4/(2D0*PMAS(24,1))**2
34129 BBET=SH/(2D0*PMAS(24,1))**2
34131 BABI=1D0/(BALP-BBET)
34132 IF(BALP.LT.1D0) THEN
34133 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
34136 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
34137 & -DBLE(0.5D0*PARU(1)))
34140 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
34141 IF(BBET.LT.1D0) THEN
34142 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
34145 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
34146 & -DBLE(0.5D0*PARU(1)))
34149 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
34150 IF(J.LE.3*MSTP(1)) THEN
34151 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
34152 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
34153 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
34154 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
34157 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
34158 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
34159 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
34160 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
34161 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
34162 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
34166 CIGTOT=CIGTOT/DBLE(SH)
34167 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
34168 C...Loop over initial flavours
34169 DO 380 I=MMINA,MMAXA
34170 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
34171 EI=KCHG(IABS(I),1)/3D0
34175 IF(IABS(I).LE.10) FCOI=FACA/3D0
34180 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
34181 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
34184 ELSEIF(ISUB.EQ.111) THEN
34185 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
34186 IF(MSTP(38).NE.0) THEN
34187 C...Simple case: only do gg <-> h exactly.
34188 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34189 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34190 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34192 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34193 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34194 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34196 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34197 & '(PYSGHG:) did not find Higgs -> g g channel')
34198 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
34199 & (TH**2+UH**2)/(SH*SQM4)
34201 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
34202 & (TH**2+UH**2)/(SH*SQM4)
34204 C...Propagators: as simulated in PYOFSH and as desired
34205 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34206 GMMHC=SQRT(SQM4)*WDTP(0)
34207 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34208 & ((SQM4-SQMH)**2+GMMHC**2)
34209 FACGH=FACGH*HBW4C/HBW4
34211 C...Messy case: do full loop integrals
34214 DO 390 I=1,2*MSTP(1)
34218 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34219 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34220 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34221 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34222 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
34223 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
34224 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
34225 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
34227 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34228 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
34229 FACGH=FACGH*WIDS(25,2)
34231 DO 400 I=MMINA,MMAXA
34232 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34233 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34241 ELSEIF(ISUB.EQ.112) THEN
34242 C...f + g -> f + h0 (q + g -> q + h0 only)
34243 IF(MSTP(38).NE.0) THEN
34244 C...Simple case: only do gg <-> h exactly.
34245 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34246 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34247 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34249 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34250 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34251 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34253 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34254 & '(PYSGHG:) did not find Higgs -> g g channel')
34255 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
34256 & (SH**2+UH**2)/(-TH*SQM4)
34258 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
34259 & (SH**2+UH**2)/(-TH*SQM4)
34261 C...Propagators: as simulated in PYOFSH and as desired
34262 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34263 GMMHC=SQRT(SQM4)*WDTP(0)
34264 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34265 & ((SQM4-SQMH)**2+GMMHC**2)
34266 FACQH=FACQH*HBW4C/HBW4
34268 C...Messy case: do full loop integrals
34271 DO 410 I=1,2*MSTP(1)
34275 CALL PYWAUX(1,EPST,W1TR,W1TI)
34276 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34277 CALL PYWAUX(2,EPST,W2TR,W2TI)
34278 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34279 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
34280 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
34281 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
34282 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
34284 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34285 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
34286 FACQH=FACQH*WIDS(25,2)
34288 DO 430 I=MMINA,MMAXA
34289 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
34291 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
34292 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
34295 ISIG(NCHN,3-ISDE)=21
34301 ELSEIF(ISUB.EQ.113) THEN
34302 C...g + g -> g + h0
34303 IF(MSTP(38).NE.0) THEN
34304 C...Simple case: only do gg <-> h exactly.
34305 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34306 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34307 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34309 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34310 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34311 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34313 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34314 & '(PYSGHG:) did not find Higgs -> g g channel')
34315 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
34316 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34318 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
34319 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34321 C...Propagators: as simulated in PYOFSH and as desired
34322 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34323 GMMHC=SQRT(SQM4)*WDTP(0)
34324 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34325 & ((SQM4-SQMH)**2+GMMHC**2)
34326 FACGH=FACGH*HBW4C/HBW4
34328 C...Messy case: do full loop integrals
34337 DO 440 I=1,2*MSTP(1)
34343 IF(EPSH.LT.1D-6) GOTO 440
34344 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34345 CALL PYWAUX(1,EPST,W1TR,W1TI)
34346 CALL PYWAUX(1,EPSU,W1UR,W1UI)
34347 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34348 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34349 CALL PYWAUX(2,EPST,W2TR,W2TI)
34350 CALL PYWAUX(2,EPSU,W2UR,W2UI)
34351 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34352 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
34353 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
34354 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
34355 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
34356 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
34357 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
34358 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
34359 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
34360 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
34361 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
34362 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
34363 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
34364 W3STUR=YHSTUR-Y3STUR-Y3UTSR
34365 W3STUI=YHSTUI-Y3STUI-Y3UTSI
34366 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
34367 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
34368 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
34369 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
34370 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
34371 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
34372 W3USTR=YHUSTR-Y3USTR-Y3TSUR
34373 W3USTI=YHUSTI-Y3USTI-Y3TSUI
34374 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
34375 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
34376 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
34377 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
34378 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
34379 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
34380 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
34381 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
34382 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
34383 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
34384 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
34385 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
34386 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
34387 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
34388 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
34389 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
34390 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
34391 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
34392 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
34393 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
34394 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
34395 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
34396 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
34397 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
34398 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
34399 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
34400 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
34401 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
34402 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
34403 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
34404 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
34405 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
34406 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
34407 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
34408 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
34409 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
34410 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
34411 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
34412 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
34413 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
34414 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
34415 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
34416 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
34417 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
34418 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
34419 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
34420 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
34421 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
34422 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
34423 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
34424 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
34425 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
34426 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
34427 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
34428 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
34429 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
34430 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
34431 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
34432 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
34433 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
34434 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
34435 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
34436 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34437 & (W2SR-W2HR+W3STUR))
34438 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
34439 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34440 & (W2TR-W2HR+W3TUSR))
34441 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
34442 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34443 & (W2UR-W2HR+W3USTR))
34444 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
34445 A2STUR=A2STUR+B2STUR+B2SUTR
34446 A2STUI=A2STUI+B2STUI+B2SUTI
34447 A2USTR=A2USTR+B2USTR+B2UTSR
34448 A2USTI=A2USTI+B2USTI+B2UTSI
34449 A2TUSR=A2TUSR+B2TUSR+B2TSUR
34450 A2TUSI=A2TUSI+B2TUSI+B2TSUI
34451 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
34452 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
34454 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
34455 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
34456 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
34457 FACGH=FACGH*WIDS(25,2)
34459 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
34468 ELSEIF(ISUB.LE.170) THEN
34469 IF(ISUB.EQ.121) THEN
34470 C...g + g -> Q + Qbar + h0
34471 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
34474 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
34475 & (0.5D0*PMF/PMAS(24,1))**2
34477 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
34479 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34481 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34482 IF(IA.GT.10) IKFI=3
34483 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
34484 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34485 FACQQH=FACQQH/(1D0+RMSS(41))**2
34486 IF(IHIGG.NE.3) THEN
34487 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34488 & PARU(151+10*IHIGG))**2
34492 CALL PYQQBH(WTQQBH)
34493 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34495 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34496 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34497 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34503 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
34506 ELSEIF(ISUB.EQ.122) THEN
34507 C...q + qbar -> Q + Qbar + h0
34510 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
34511 & (0.5D0*PMF/PMAS(24,1))**2
34513 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
34515 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34517 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34518 IF(IA.GT.10) IKFI=3
34519 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
34520 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34521 FACQQH=FACQQH/(1D0+RMSS(41))**2
34522 IF(IHIGG.NE.3) THEN
34523 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34524 & PARU(151+10*IHIGG))**2
34528 CALL PYQQBH(WTQQBH)
34529 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34531 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34532 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34533 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34535 DO 470 I=MMINA,MMAXA
34536 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34537 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
34542 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
34545 ELSEIF(ISUB.EQ.123) THEN
34546 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
34548 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
34549 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
34550 & PARU(154+10*IHIGG)**2
34551 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
34552 & (VINT(216)-VINT(209)**2))**2
34553 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
34554 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
34555 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34557 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34558 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34559 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34561 DO 490 I=MMIN1,MMAX1
34562 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
34564 DO 480 J=MMIN2,MMAX2
34565 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
34567 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
34568 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
34570 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
34571 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
34573 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
34574 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
34579 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
34583 ELSEIF(ISUB.EQ.124) THEN
34584 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
34586 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
34587 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
34588 & PARU(155+10*IHIGG)**2
34589 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
34590 & (VINT(216)-VINT(209)**2))**2
34591 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
34592 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34594 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34595 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34596 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34598 DO 510 I=MMIN1,MMAX1
34599 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
34600 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34601 DO 500 J=MMIN2,MMAX2
34602 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
34603 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34604 IF(EI*EJ.GT.0D0) GOTO 500
34605 FACLR=VINT(180+I)*VINT(180+J)
34610 SIGH(NCHN)=FACLR*FACWW*FACBW
34614 ELSEIF(ISUB.EQ.143) THEN
34615 C...f + fbar' -> H+/-
34616 SQMHC=PMAS(37,1)**2
34617 CALL PYWIDT(37,SH,WDTP,WDTE)
34619 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
34620 HP=AEM/(8D0*XW)*SH/SQMW*SH
34621 DO 530 I=MMIN1,MMAX1
34622 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
34624 IM=(MOD(IA,10)+1)/2
34625 DO 520 J=MMIN2,MMAX2
34626 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
34628 JM=(MOD(JA,10)+1)/2
34629 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
34630 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34632 IF(MOD(IA,2).EQ.0) THEN
34639 RML=PYMRUN(IL,SH)**2/SH
34640 RMU=PYMRUN(IU,SH)**2/SH
34641 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
34642 IF(IA.LE.10) HI=HI*FACA/3D0
34643 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
34644 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
34649 SIGH(NCHN)=HI*FACBW*HF
34653 ELSEIF(ISUB.EQ.161) THEN
34654 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
34655 C...(choice of only b and t to avoid kinematics problems)
34656 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
34657 C...H propagator: as simulated in PYOFSH and as desired
34658 SQMHC=PMAS(37,1)**2
34659 GMMHC=PMAS(37,1)*PMAS(37,2)
34660 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
34661 CALL PYWIDT(37,SQM4,WDTP,WDTE)
34662 GMMHCC=SQRT(SQM4)*WDTP(0)
34663 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
34664 FHCQ=FHCQ*HBW4C/HBW4
34666 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
34667 DO 550 I=MMINA,MMAXA
34669 IF(IA.NE.5) GOTO 550
34670 SQML=PYMRUN(IA,Q2RM)**2
34672 SQMQ=PYMRUN(IUA,Q2RM)**2
34673 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
34674 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
34675 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
34676 & (SQMHC-SQMQ-SH)/SH)
34677 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
34679 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
34680 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
34683 ISIG(NCHN,3-ISDE)=21
34685 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
34686 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
34691 ELSEIF(ISUB.LE.402) THEN
34692 IF(ISUB.EQ.401) THEN
34693 C... g + g -> t + bbar + H-
34694 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
34697 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34699 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
34700 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34706 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
34707 c Since we don't know yet if H+ or H-, assume H+
34708 c when calculating suppression due to closed channels.
34709 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
34710 IF(ABS(WIDS(37,2)-WIDS(37,3))
34711 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
34712 & ABS(WIDS(6,2)-WIDS(6,3))
34713 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
34714 WRITE(*,*)'Error: Process 401 cannot handle different'
34715 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34716 WRITE(*,*)'Execution stopped.'
34721 ELSEIF(ISUB.EQ.402) THEN
34722 C... q + qbar -> t + bbar + H-
34725 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34727 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
34728 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34730 DO 570 I=MMINA,MMAXA
34731 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34732 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
34737 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
34738 c Since we don't know yet if H+ or H-, assume H+
34739 c when calculating suppression due to closed channels.
34740 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
34741 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
34743 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
34745 WRITE(*,*)'Error: Process 402 cannot handle different'
34746 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34747 WRITE(*,*)'Execution stopped.'
34757 C*********************************************************************
34760 C...Subprocess cross sections for SUSY processes,
34761 C...including Higgs pair production.
34762 C...Auxiliary to PYSIGH.
34764 SUBROUTINE PYSGSU(NCHN,SIGS)
34766 C...Double precision and integer declarations
34767 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34768 IMPLICIT INTEGER(I-N)
34769 INTEGER PYK,PYCHGE,PYCOMP
34770 C...Parameter statement to help give large particle numbers.
34771 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34772 &KEXCIT=4000000,KDIMEN=5000000)
34774 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34775 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34776 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34777 COMMON/PYINT1/MINT(400),VINT(400)
34778 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
34779 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
34780 COMMON/PYINT4/MWID(500),WIDS(500,5)
34781 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34782 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34783 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
34784 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
34785 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
34786 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
34787 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
34788 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
34789 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
34790 C...Local arrays and complex variables
34791 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
34792 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
34793 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
34794 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
34797 C...Z and W width, combinations of weak mixing angle
34801 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
34803 C...Convert almost equivalent SUSY processes into each other
34804 C...Extract differences in flavours and couplings
34806 C...Sleptons and sneutrinos
34807 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
34808 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34811 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
34812 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34815 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
34816 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34818 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
34819 IF(ISUB.EQ.210) THEN
34821 ELSEIF(ISUB.EQ.211) THEN
34823 ELSEIF(ISUB.EQ.212) THEN
34827 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
34828 IF(ISUB.EQ.213) THEN
34829 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34831 ELSEIF(ISUB.EQ.214) THEN
34838 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
34839 IF(ISUB.EQ.216) THEN
34842 ELSEIF(ISUB.EQ.217) THEN
34845 ELSEIF(ISUB.EQ.218) THEN
34848 ELSEIF(ISUB.EQ.219) THEN
34851 ELSEIF(ISUB.EQ.220) THEN
34854 ELSEIF(ISUB.EQ.221) THEN
34857 ELSEIF(ISUB.EQ.222) THEN
34860 ELSEIF(ISUB.EQ.223) THEN
34863 ELSEIF(ISUB.EQ.224) THEN
34866 ELSEIF(ISUB.EQ.225) THEN
34873 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
34874 IF(ISUB.EQ.226) THEN
34877 ELSEIF(ISUB.EQ.227) THEN
34880 ELSEIF(ISUB.EQ.228) THEN
34886 C...Neutralino + chargino
34887 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
34888 IF(ISUB.EQ.229) THEN
34891 ELSEIF(ISUB.EQ.230) THEN
34894 ELSEIF(ISUB.EQ.231) THEN
34897 ELSEIF(ISUB.EQ.232) THEN
34900 ELSEIF(ISUB.EQ.233) THEN
34903 ELSEIF(ISUB.EQ.234) THEN
34906 ELSEIF(ISUB.EQ.235) THEN
34909 ELSEIF(ISUB.EQ.236) THEN
34915 C...Gluino + neutralino
34916 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
34917 IF(ISUB.EQ.237) THEN
34919 ELSEIF(ISUB.EQ.238) THEN
34921 ELSEIF(ISUB.EQ.239) THEN
34923 ELSEIF(ISUB.EQ.240) THEN
34928 C...Gluino + chargino
34929 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
34930 IF(ISUB.EQ.241) THEN
34932 ELSEIF(ISUB.EQ.242) THEN
34937 C...Squark + neutralino
34938 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
34940 IF(MOD(ISUB,2).NE.0) ILR=1
34941 IF(ISUB.LE.247) THEN
34943 ELSEIF(ISUB.LE.249) THEN
34945 ELSEIF(ISUB.LE.251) THEN
34947 ELSEIF(ISUB.LE.253) THEN
34953 C...Squark + chargino
34954 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
34955 IF(ISUB.LE.255) THEN
34957 ELSEIF(ISUB.LE.257) THEN
34960 IF(MOD(ISUB,2).EQ.0) THEN
34968 C...Squark + gluino
34969 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
34974 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
34976 IF(ISUB.EQ.262) ILR=1
34978 ELSEIF(ISUB.EQ.265) THEN
34982 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
34984 IF(ISUB.LE.273) THEN
34985 IF(ISUB.EQ.273) ILR=1
34988 ELSEIF(ISUB.LE.276) THEN
34989 IF(ISUB.EQ.276) ILR=1
34992 ELSEIF(ISUB.LE.278) THEN
34993 IF(ISUB.EQ.278) ILR=1
34997 IF(ISUB.EQ.280) ILR=1
35002 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
35004 IF(ISUB.LE.283) THEN
35005 IF(ISUB.EQ.283) ILR=1
35008 ELSEIF(ISUB.LE.286) THEN
35009 IF(ISUB.EQ.286) ILR=1
35012 ELSEIF(ISUB.LE.288) THEN
35013 IF(ISUB.EQ.288) ILR=1
35016 ELSEIF(ISUB.LE.290) THEN
35017 IF(ISUB.EQ.290) ILR=1
35020 ELSEIF(ISUB.LE.293) THEN
35021 IF(ISUB.EQ.293) ILR=1
35024 ELSEIF(ISUB.EQ.296) THEN
35028 C...Squark + gluino
35029 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
35034 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
35035 IF(ISUB.EQ.297) THEN
35036 RKF=.5D0*PARU(195)**2
35037 ELSEIF(ISUB.EQ.298) THEN
35038 RKF=.5D0*(1D0-PARU(195)**2)
35042 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
35043 IF(ISUB.EQ.299) THEN
35046 ELSEIF(ISUB.EQ.300) THEN
35052 ELSEIF(ISUB.EQ.301) THEN
35058 C...Supersymmetric processes - all of type 2 -> 2 :
35059 C...correct final-state Breit-Wigners from fixed to running width.
35060 IF(MSTP(42).GT.0) THEN
35062 KFLW=KFPR(ISUBSV,I)
35064 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
35065 IF(I.EQ.1) SQMI=SQM3
35066 IF(I.EQ.2) SQMI=SQM4
35067 SQMS=PMAS(KCW,1)**2
35068 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
35069 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
35070 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
35071 GMMI=SQRT(SQMI)*WDTP(0)
35072 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
35073 COMFAC=COMFAC*(HBWI/HBWS)
35077 C...Differential cross section expressions.
35079 IF(ISUB.LE.210) THEN
35080 IF(ISUB.EQ.201) THEN
35081 C...f + fbar -> e_L + e_Lbar
35082 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35083 DO 130 I=MMIN1,MMAX1
35085 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
35087 TT3I=SIGN(1D0,EI+1D-6)/2D0
35091 C...Color factor for e+ e-
35092 IF(IA.GE.11) FCOL=3D0
35093 IF(ISUBSV.EQ.301) THEN
35096 ELSEIF(ILR.EQ.1) THEN
35097 A1=SFMIX(KFID,3)**2
35098 A2=SFMIX(KFID,4)**2
35099 ELSEIF(ILR.EQ.0) THEN
35100 A1=SFMIX(KFID,1)**2
35101 A2=SFMIX(KFID,2)**2
35103 XLQ=(TT3J-EJ*XW)*A1
35107 TAA=(EI*EJ)**2*(POLL+POLR)
35108 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
35109 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
35110 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
35111 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35115 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35121 DK=1D0/(TH-SMZ(II)**2)
35122 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35124 FREK=FAC2*TANW*EI*ZMIX(II,1)
35125 TNN1=TNN1+FLEK**2*DK
35126 TNN2=TNN2+FREK**2*DK
35128 DL=1D0/(TH-SMZ(JJ)**2)
35129 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35131 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35132 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35135 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
35136 & A2**2*TNN2**2*POLR)
35137 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
35138 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
35139 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
35140 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
35141 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35144 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
35147 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
35148 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
35149 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
35154 SIGH(NCHN)=FACQQ1+FACQQ2
35157 ELSEIF(ISUB.EQ.203) THEN
35158 C...f + fbar -> e_L + e_Rbar
35159 DO 160 I=MMIN1,MMAX1
35161 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
35162 EI=KCHG(IABS(I),1)/3D0
35163 TT3I=SIGN(1D0,EI)/2D0
35167 C...Color factor for e+ e-
35168 IF(IA.GE.11) FCOL=3D0
35169 A1=SFMIX(KFID,1)**2
35170 A2=SFMIX(KFID,2)**2
35175 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
35176 & /XW**2/XW1**2*A1*A2
35177 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35182 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35188 DK=1D0/(TH-SMZ(II)**2)
35189 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35191 FREK=FAC2*TANW*EI*ZMIX(II,1)
35192 TNN1=TNN1+FLEK**2*DK
35193 TNN2=TNN2+FREK**2*DK
35195 DL=1D0/(TH-SMZ(JJ)**2)
35196 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35198 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35199 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35202 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
35203 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
35204 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
35205 TZN=(UH*TH-SQM3*SQM4)*A1*A2
35206 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
35207 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35210 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
35211 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
35212 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
35218 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35219 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35224 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35225 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35228 ELSEIF(ISUB.EQ.210) THEN
35229 C...q + qbar' -> W*- > ~l_L + ~nu_L
35230 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
35231 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
35232 DO 180 I=MMIN1,MMAX1
35234 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
35235 DO 170 J=MMIN2,MMAX2
35237 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
35238 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
35240 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35241 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35243 IF(KCHSUM.LT.0) KCHW=3
35248 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
35249 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35250 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35252 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35253 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35255 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
35260 ELSEIF(ISUB.LE.220) THEN
35261 IF(ISUB.EQ.213) THEN
35262 C...f + fbar -> ~nu_L + ~nu_Lbar
35263 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
35264 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35265 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35267 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35270 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
35273 DO 190 I=MMIN1,MMAX1
35275 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
35278 C...Color factor for e+ e-
35279 IF(IA.GE.11) FCOL=3D0
35280 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
35284 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
35285 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
35288 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
35290 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
35296 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
35297 & *AEM**2*FCOL/3D0/XW**2
35300 ELSEIF(ISUB.EQ.216) THEN
35301 C...q + qbar -> ~chi0_1 + ~chi0_1
35302 IF(IZID1.EQ.IZID2) THEN
35303 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35305 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35306 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35308 FACXX=COMFAC*AEM**2/3D0/XW**2
35309 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
35312 WU2 = (UH-ZM12)*(UH-ZM22)
35313 WT2 = (TH-ZM12)*(TH-ZM22)
35314 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
35315 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35316 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35318 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
35319 IF(IZID2.NE.IZID1) THEN
35320 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35323 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
35324 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
35326 DO 210 I=MMINA,MMAXA
35327 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
35328 EI=KCHG(IABS(I),1)/3D0
35329 T3I=SIGN(1D0,EI+1D-6)/2D0
35330 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
35331 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
35332 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
35333 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
35334 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
35335 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
35336 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
35338 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
35339 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
35340 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
35342 IF(IABS(I).GE.11) FCOL=3D0
35343 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
35344 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
35345 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
35346 & QRL*DCONJG(QRR)*POLR)*WS2
35351 SIGH(NCHN)=FACXX*FACGG1*FCOL
35355 ELSEIF(ISUB.LE.230) THEN
35356 IF(ISUB.EQ.226) THEN
35357 C...f + fbar -> ~chi+_1 + ~chi-_1
35358 FACXX=COMFAC*AEM**2/3D0
35361 WU2 = (UH-ZM12)*(UH-ZM22)
35362 WT2 = (TH-ZM12)*(TH-ZM22)
35363 WS2 = SMW(IZID1)*SMW(IZID2)*SH
35364 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35365 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35367 IF(IZID1.EQ.IZID2) DIFF=1D0
35369 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
35370 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
35371 IF(IZID2.NE.IZID1) THEN
35372 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
35373 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
35376 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
35377 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
35378 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
35379 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
35380 DO 230 I=MMINA,MMAXA
35381 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
35382 EI=KCHG(IABS(I),1)/3D0
35383 T3I=SIGN(1D0,EI+1D-6)/2D0
35384 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
35385 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
35386 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
35387 IF(MOD(I,2).EQ.0) THEN
35388 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
35389 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
35390 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
35391 & DCMPLX(T3I/XW/(TH-XML2))
35393 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
35394 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
35395 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
35396 & DCMPLX(T3I/XW/(TH-XML2))
35399 IF(IABS(I).GE.11) FCOL=3D0
35400 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
35401 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
35402 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
35403 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
35408 IF(IZID1.EQ.IZID2) THEN
35409 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35411 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35412 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35417 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35418 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35422 ELSEIF(ISUB.EQ.229) THEN
35423 C...q + qbar' -> ~chi0_1 + ~chi+-_1
35424 FACXX=COMFAC*AEM**2/6D0/XW**2
35427 WU2 = (UH-ZM12)*(UH-ZM22)
35428 WT2 = (TH-ZM12)*(TH-ZM22)
35429 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
35430 RT2I = 1D0/SQRT(2D0)
35431 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
35432 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
35434 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
35435 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
35438 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35440 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
35441 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
35442 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
35443 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
35445 DO 270 I=MMIN1,MMAX1
35447 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
35449 T3I=SIGN(1D0,EI+1D-6)/2D0
35450 DO 260 J=MMIN2,MMAX2
35452 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
35453 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
35455 T3J=SIGN(1D0,EJ+1D-6)/2D0
35457 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35458 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35460 IF(KCHSUM.LT.0) KCHW=3
35461 IF(MOD(IA,2).EQ.0) THEN
35462 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
35463 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
35464 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
35465 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
35466 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
35467 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
35470 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
35471 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
35472 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
35473 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
35474 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
35475 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
35478 ZINTR=DBLE(QLR*DCONJG(QLL))
35479 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
35485 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35486 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35491 ELSEIF(ISUB.LE.240) THEN
35492 IF(ISUB.EQ.237) THEN
35493 C...q + qbar -> gluino + ~chi0_1
35494 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35495 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35497 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
35500 DO 280 I=MMINA,MMAXA
35501 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
35502 EI=KCHG(IABS(I),1)/3D0
35504 XLQC = -TANW*EI*ZMIX(IZID,1)
35505 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
35506 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
35509 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
35510 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
35511 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
35512 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
35513 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
35514 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
35515 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
35516 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
35517 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
35518 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
35523 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
35527 ELSEIF(ISUB.LE.250) THEN
35528 IF(ISUB.EQ.241) THEN
35529 C...q + qbar' -> ~chi+-_1 + gluino
35530 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
35533 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
35534 FAC0=UMIX(IZID,1)**2
35535 FAC1=VMIX(IZID,1)**2
35536 DO 300 I=MMIN1,MMAX1
35538 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
35539 DO 290 J=MMIN2,MMAX2
35541 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
35542 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
35544 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35545 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35547 IF(KCHSUM.LT.0) KCHW=3
35548 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
35549 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
35550 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
35551 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
35552 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
35553 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
35554 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
35555 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
35556 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
35557 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
35558 & SH/(TH-XMU2)/(UH-XMD2))/2D0
35563 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
35564 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35565 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35569 ELSEIF(ISUB.EQ.243) THEN
35570 C...q + qbar -> gluino + gluino
35571 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35574 DO 310 I=MMINA,MMAXA
35575 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35576 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
35578 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
35579 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
35580 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
35581 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
35582 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
35583 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
35584 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
35585 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
35586 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
35587 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
35588 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
35589 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
35593 C...1/2 for identical particles
35594 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
35597 ELSEIF(ISUB.EQ.244) THEN
35598 C...g + g -> gluino + gluino
35599 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35602 FACQQ1=COMFAC*AS**2*9D0/4D0*(
35603 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
35604 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
35605 FACQQ2=COMFAC*AS**2*9D0/4D0*(
35606 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
35607 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
35608 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
35609 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
35610 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
35615 SIGH(NCHN)=FACQQ1/2D0
35620 SIGH(NCHN)=FACQQ2/2D0
35625 SIGH(NCHN)=FACQQ3/2D0
35628 ELSEIF(ISUB.EQ.246) THEN
35629 C...g + q_j -> ~chi0_1 + ~q_j
35630 FAC0=COMFAC*AS*AEM/6D0/XW
35633 FACZQ0=FAC0*( (ZM2-TH)/SH +
35634 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
35635 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
35636 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35637 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
35638 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
35639 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
35640 EI=KCHG(IABS(I),1)/3D0
35642 XRQZ = -TANW*EI*ZMIX(IZID,1)
35643 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
35644 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
35646 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
35648 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
35654 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
35655 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
35658 ISIG(NCHN,3-ISDE)=21
35660 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35661 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35666 ELSEIF(ISUB.LE.260) THEN
35667 IF(ISUB.EQ.254) THEN
35668 C...g + q_j -> ~chi1_1 + ~q_i
35669 FAC0=COMFAC*AS*AEM/12D0/XW
35674 FACZQ0=FAC0*( (ZM2-TH)/SH +
35675 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
35676 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
35677 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
35678 IF(MOD(KFNSQ1,2).EQ.0) THEN
35685 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
35686 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
35687 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
35689 IF(MOD(IA,2).EQ.0) THEN
35694 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
35698 IF(I.LT.0) KCHWQ=5-KCHW
35700 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
35701 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
35704 ISIG(NCHN,3-ISDE)=21
35706 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35707 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
35711 ELSEIF(ISUB.EQ.258) THEN
35712 C...g + q_j -> gluino + ~q_i
35719 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
35720 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
35721 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
35722 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
35723 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
35725 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
35726 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
35727 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
35729 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
35730 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
35731 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35732 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
35733 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
35734 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
35737 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35738 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35740 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
35741 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
35744 ISIG(NCHN,3-ISDE)=21
35746 SIGH(NCHN)=FACQG1*FACSEL
35749 ISIG(NCHN,3-ISDE)=21
35751 SIGH(NCHN)=FACQG2*FACSEL
35756 ELSEIF(ISUB.LE.270) THEN
35757 IF(ISUB.EQ.261) THEN
35758 C...q_i + q_ibar -> ~t_1 + ~t_1bar
35759 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
35760 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35761 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35763 DO 390 I=MMIN1,MMAX1
35765 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
35766 IF(IA.GE.11.AND.IA.LE.18) THEN
35768 EJ=KCHG(KFNSQ,1)/3D0
35769 T3I=SIGN(1D0,EI)/2D0
35770 T3J=SIGN(1D0,EJ)/2D0
35771 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
35772 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
35773 XLF=2D0*(T3I-EI*XW)
35775 TAA=0.5D0*(EI*EJ)**2
35776 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35777 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35778 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35779 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35780 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35786 SIGH(NCHN)=FACQQ1*FAC0
35789 ELSEIF(ISUB.EQ.263) THEN
35790 C...f + fbar -> ~t1 + ~t2bar
35791 DO 400 I=MMIN1,MMAX1
35793 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
35794 EI=KCHG(IABS(I),1)/3D0
35795 TT3I=SIGN(1D0,EI)/2D0
35799 C...Color factor for e+ e-
35800 IF(IA.GE.11) FCOL=3D0
35801 XLQ=2D0*(TT3J-EJ*XW)
35803 XLF=2D0*(TT3I-EI*XW)
35805 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
35806 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
35807 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35808 C...Factor of 2 for t1 t2bar + t2 t1bar
35809 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
35810 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
35815 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35816 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35821 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35822 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35825 ELSEIF(ISUB.EQ.264) THEN
35826 C...g + g -> ~t_1 + ~t_1bar
35829 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
35830 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35831 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
35832 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
35833 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
35847 ELSEIF(ISUB.LE.280) THEN
35848 IF(ISUB.EQ.271) THEN
35849 C...q + q' -> ~q + ~q' (~g exchange)
35850 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35859 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
35860 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
35863 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
35864 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
35865 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
35868 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35869 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35870 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
35871 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
35873 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
35876 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35877 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
35879 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
35880 IF(I*J.LT.0) GOTO 420
35885 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35886 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35889 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
35890 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35892 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
35893 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35894 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35901 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
35902 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35904 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
35905 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35906 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35912 ELSEIF(ISUB.EQ.274) THEN
35913 C...q + qbar' -> ~q + ~qbar'
35914 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35918 C...Mrenna...Normalization.and.1/XMT
35919 FACQQ1=COMFAC*AS**2*2D0/9D0*(
35920 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
35921 FACQQB=COMFAC*AS**2*4D0/9D0*(
35922 & (UH*TH-SQM3*SQM4)/SH2 )
35923 FACQQI=-COMFAC*AS**2*4D0/27D0*(
35924 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
35925 FACQQB=FACQQB+FACQQ1+FACQQI
35927 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
35930 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35931 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35932 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
35933 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
35935 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
35938 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35939 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
35941 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
35942 IF(I*J.GT.0) GOTO 440
35947 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35948 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
35949 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
35950 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35954 ELSEIF(ISUB.EQ.277) THEN
35955 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
35956 C...if i .eq. j covered in 274
35957 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
35958 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35960 DO 460 I=MMIN1,MMAX1
35962 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
35963 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
35964 IF(IA.EQ.KFNSQ) GOTO 460
35965 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
35967 EJ=KCHG(KFNSQ,1)/3D0
35969 T3I=SIGN(1D0,EI)/2D0
35971 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
35972 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
35974 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
35975 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
35977 XLF=2D0*(T3I-EI*XW)
35984 TAA=0.5D0*(EI*EJ)**2
35985 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35986 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35987 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35988 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35989 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35990 ELSEIF(IA.LE.6) THEN
35991 FAC0=AS**2*8D0/9D0/2D0
35997 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36000 ELSEIF(ISUB.EQ.279) THEN
36001 C...g + g -> ~q_j + ~q_jbar
36004 C...5=RKF because ~t ~tbar treated separately
36005 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
36006 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
36007 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
36008 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
36013 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36018 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36028 C*********************************************************************
36031 C...Subprocess cross sections for Technicolor processes.
36032 C...Auxiliary to PYSIGH.
36034 SUBROUTINE PYSGTC(NCHN,SIGS)
36036 C...Double precision and integer declarations
36037 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36038 IMPLICIT INTEGER(I-N)
36039 INTEGER PYK,PYCHGE,PYCOMP
36040 C...Parameter statement to help give large particle numbers.
36041 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36042 &KEXCIT=4000000,KDIMEN=5000000)
36044 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36045 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36046 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36047 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36048 COMMON/PYINT1/MINT(400),VINT(400)
36049 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36050 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36051 COMMON/PYINT4/MWID(500),WIDS(500,5)
36052 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36053 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36054 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36055 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36056 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36057 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36058 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36059 C...Local arrays and complex variables
36060 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36061 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
36062 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
36063 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
36064 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
36065 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
36066 COMPLEX*16 DVVS,DVVT,DVVU
36069 C...Combinations of weak mixing angle.
36071 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
36073 C...Convert almost equivalent technicolor processes into
36074 C...a few basic processes, and set distinguishing parameters.
36075 IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
36078 SN2W=2D0*SQRT(XW*XW1)
36081 CSXI=COS(ASIN(RTCM(3)))
36082 CSXIP=COS(ASIN(RTCM(4)))
36083 QUPD=2D0*RTCM(2)-1D0
36084 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
36095 C... rho_tc0, etc. -> W_L W_L, W_L W_T
36096 IF(ISUB.EQ.361) THEN
36100 AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36101 ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36102 VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
36103 C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
36104 AXGP = SQRT(2D0)*AXGP
36105 ARGP = SQRT(2D0)*ARGP
36106 VOGP = SQRT(2D0)*VOGP
36107 C... rho_tc0 -> W_L pi_tc-
36108 ELSEIF(ISUB.EQ.362) THEN
36112 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36114 ELSEIF(ISUB.EQ.363) THEN
36118 CAB2=(1D0-RTCM(3)**2)**2
36119 C... rho_tc0/omega_tc -> gamma pi_tc
36120 ELSEIF(ISUB.EQ.364) THEN
36127 VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36129 ELSEIF(ISUB.EQ.365) THEN
36133 VRGP=CSXIP/RTCM(12)
36135 VAGP=2D0*Q2UD*CSXIP
36136 VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
36138 ELSEIF(ISUB.EQ.366) THEN
36142 VOGP=CSXI*CT2W/RTCM(12)
36143 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36144 VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36145 VZGP=-QUPD*CSXI*CS2W/XW1
36147 ELSEIF(ISUB.EQ.367) THEN
36151 C...RTCM(48) is the M_V for the techni-a
36152 VXGP=-CSXIP/SN2W/RTCM(48)
36153 VRGP=CSXIP*CT2W/RTCM(12)
36154 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
36155 VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
36156 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
36158 ELSEIF(ISUB.EQ.368) THEN
36162 C...RTCM(49) is the M_A for the techni-a
36163 AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
36164 VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
36165 ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
36166 VAGP=QUPD*CSXI/(2D0*SQRT(XW))
36167 VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36168 C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
36169 ELSEIF(ISUB.EQ.370) THEN
36173 ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36174 AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36176 ELSEIF(ISUB.EQ.371) THEN
36180 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36182 ELSEIF(ISUB.EQ.372) THEN
36186 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36188 ELSEIF(ISUB.EQ.373) THEN
36192 CAB2=(1D0-RTCM(3)**2)**2
36194 ELSEIF(ISUB.EQ.374) THEN
36198 VRGP=QUPD*CSXI/RTCM(12)
36199 VWGP=QUPD*CSXI/(2D0*SQRT(XW))
36200 AXGP=-CSXI/RTCM(49)
36202 ELSEIF(ISUB.EQ.375) THEN
36206 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36207 ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
36208 VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36209 AXGP=-CSXI*CT2W/RTCM(49)
36211 ELSEIF(ISUB.EQ.376) THEN
36216 ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
36217 AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
36219 ELSEIF(ISUB.EQ.377) THEN
36223 VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
36224 VWGP=CSXIP/(2D0*XW)
36225 VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
36227 ELSEIF(ISUB.EQ.378) THEN
36231 VRGP=QUPD*RTCM(3)/RTCM(12)
36232 AXGP=-RTCM(3)/RTCM(49)
36234 ELSEIF(ISUB.EQ.379) THEN
36238 VOGP=RTCM(3)/RTCM(12)
36239 VRGP=QUPD*RTCM(3)/RTCM(12)
36240 ELSEIF(ISUB.EQ.380) THEN
36244 VOGP=RTCM(3)*CT2W/RTCM(12)
36245 VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
36249 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
36250 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
36251 IF(ITCM(5).LE.4) THEN
36269 ELSEIF(ITCM(5).EQ.5) THEN
36271 IF(ITCM(2).EQ.0) THEN
36276 ALPRHT=2.16D0*(3D0/ITCM(1))
36277 SIN2T=2D0*TANT3/(TANT3**2+1D0)
36278 SINT3=TANT3/SQRT(TANT3**2+1D0)
36279 XIG=SQRT(PYALPS(SH)/ALPRHT)
36280 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
36281 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
36282 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
36283 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
36284 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
36285 & SINT3**2)*2D0/SIN2T
36286 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
36287 & SINT3**2)*2D0/SIN2T
36289 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
36290 SM1112=X12*RTCM(28)**2*SIN2T
36291 SM1121=-X21*RTCM(28)**2*SIN2T
36294 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
36295 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
36298 ZTC(1,1)=DCMPLX(SH,0D0)
36299 CALL PYWIDT(3100021,SH,WDTP,WDTE)
36300 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
36301 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
36302 CALL PYWIDT(3100113,SH,WDTP,WDTE)
36303 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
36304 CALL PYWIDT(3400113,SH,WDTP,WDTE)
36305 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
36306 CALL PYWIDT(3200113,SH,WDTP,WDTE)
36307 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
36308 CALL PYWIDT(3300113,SH,WDTP,WDTE)
36309 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
36311 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
36315 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
36316 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
36317 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
36318 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
36331 CALL PYLDCM(ZTC,6,6,INDX,D)
36335 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36340 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36346 XIG=SQRT(PYALPS(-TH)/ALPRHT)
36348 ZTC(1,1)=DCMPLX(TH)
36349 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
36350 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
36351 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
36352 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
36353 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
36355 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
36359 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
36360 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
36361 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
36362 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
36374 CALL PYLDCM(ZTC,6,6,INDX,D)
36378 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36382 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36388 XIG=SQRT(PYALPS(-UH)/ALPRHT)
36390 ZTC(1,1)=DCMPLX(UH,0D0)
36391 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
36392 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
36393 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
36394 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
36395 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
36397 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
36401 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
36402 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
36403 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
36404 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
36416 CALL PYLDCM(ZTC,6,6,INDX,D)
36420 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36424 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36431 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
36432 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
36433 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
36434 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
36435 DQGS=DGGS-DGVS*DCMPLX(TANT3)
36436 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36438 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
36439 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
36440 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
36441 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
36442 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36443 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36446 SQDQTS=ABS(DQTS)**2
36447 SQDQQS=ABS(DQQS)**2
36448 SQDQQT=ABS(DQQT)**2
36449 SQDQQU=ABS(DQQU)**2
36450 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
36452 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
36454 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
36456 SQDGGS=ABS(DGGS)**2
36457 SQDGGT=ABS(DGGT)**2
36458 SQDGGU=ABS(DGGU)**2
36462 REDGTU=DBLE(DGGU*DCONJG(DGGT))
36463 REDGSU=DBLE(DGGU*DCONJG(DGGS))
36464 REDGST=DBLE(DGGS*DCONJG(DGGT))
36465 REDQST=DBLE(DQQS*DCONJG(DQQT))
36466 REDQTU=DBLE(DQQT*DCONJG(DQQU))
36471 C...Differential cross section expressions.
36473 IF(ISUB.LE.190) THEN
36474 IF(ISUB.EQ.149) THEN
36475 C...g + g -> eta_tc
36476 KCTC=PYCOMP(KTECHN+331)
36477 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
36479 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
36480 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36482 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
36484 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36489 SIGH(NCHN)=HI*FACBW*HF
36492 ELSEIF(ISUB.EQ.165) THEN
36493 C...q + qbar -> l+ + l- (including contact term for compositeness)
36494 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36495 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36496 KFF=IABS(KFPR(ISUB,1))
36498 AF=SIGN(1D0,EF+0.1D0)
36503 IF(KFF.LE.10) FCOF=3D0
36505 IF(KFF.EQ.6) WID2=WIDS(6,1)
36506 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
36507 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
36508 DO 260 I=MMINA,MMAXA
36509 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
36510 EI=KCHG(IABS(I),1)/3D0
36511 AI=SIGN(1D0,EI+0.1D0)
36516 IF(IABS(I).LE.10) FCOI=FACA/3D0
36517 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
36518 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
36519 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
36520 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
36522 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
36523 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
36525 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
36526 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
36527 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
36528 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
36529 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
36534 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
36537 ELSEIF(ISUB.EQ.166) THEN
36538 C...q + q'bar -> l + nu_l (including contact term for compositeness)
36539 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
36540 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
36541 KFF=IABS(KFPR(ISUB,1))
36543 IF(KFF.LE.10) FCOF=3D0
36544 DO 280 I=MMIN1,MMAX1
36545 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
36547 DO 270 J=MMIN2,MMAX2
36548 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
36550 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
36551 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36554 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36556 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
36557 & MOD(J,2).EQ.0)) THEN
36558 IF(KFF.EQ.5) WID2=WIDS(6,2)
36559 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
36560 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
36562 IF(KFF.EQ.5) WID2=WIDS(6,3)
36563 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
36564 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
36570 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
36571 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
36572 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
36577 ELSEIF(ISUB.LE.200) THEN
36578 IF(ISUB.EQ.191) THEN
36579 C...q + qbar -> rho_tc0.
36580 KCTC=PYCOMP(KTECHN+113)
36581 SQMRHT=PMAS(KCTC,1)**2
36582 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36584 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
36585 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36586 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36587 ALPRHT=2.16D0*(3D0/ITCM(1))
36588 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
36589 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
36590 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36591 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36592 DO 290 I=MMINA,MMAXA
36593 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
36595 EI=KCHG(IABS(I),1)/3D0
36596 AI=SIGN(1D0,EI+0.1D0)
36600 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
36601 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
36602 IF(IA.LE.10) HI=HI*FACA/3D0
36607 SIGH(NCHN)=HI*FACBW*HF
36610 ELSEIF(ISUB.EQ.192) THEN
36611 C...q + qbar' -> rho_tc+/-.
36612 KCTC=PYCOMP(KTECHN+213)
36613 SQMRHT=PMAS(KCTC,1)**2
36614 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36616 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
36617 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36618 ALPRHT=2.16D0*(3D0/ITCM(1))
36619 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
36620 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
36621 DO 310 I=MMIN1,MMAX1
36622 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
36624 DO 300 J=MMIN2,MMAX2
36625 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
36627 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
36628 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36630 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36631 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
36633 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36638 SIGH(NCHN)=HI*FACBW*HF
36642 ELSEIF(ISUB.EQ.193) THEN
36643 C...q + qbar -> omega_tc0.
36644 KCTC=PYCOMP(KTECHN+223)
36645 SQMOMT=PMAS(KCTC,1)**2
36646 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36648 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
36649 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36650 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36651 ALPRHT=2.16D0*(3D0/ITCM(1))
36652 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
36653 & (2D0*RTCM(2)-1D0)**2
36654 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36655 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36656 DO 320 I=MMINA,MMAXA
36657 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
36659 EI=KCHG(IABS(I),1)/3D0
36660 AI=SIGN(1D0,EI+0.1D0)
36664 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
36665 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
36666 IF(IA.LE.10) HI=HI*FACA/3D0
36671 SIGH(NCHN)=HI*FACBW*HF
36674 ELSEIF(ISUB.EQ.194) THEN
36675 C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
36676 C...Default final state is e+e-
36678 ALPRHT=2.16D0*(3D0/ITCM(1))
36681 SN2W=2D0*SQRT(XW*XW1)
36682 C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
36683 C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
36685 QUPD=2D0*RTCM(2)-1D0
36686 FAR=SQRT(AEM/ALPRHT)
36690 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36691 FZX=-FAR/SN2W*RTCM(47)
36697 CALL PYWIDT(23,SH,WDTP,WDTE)
36698 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
36699 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36700 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
36701 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36702 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
36703 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
36704 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
36705 C...Propagator including a_T^0
36706 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
36707 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
36708 C...Add in techni-a contribution
36709 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
36710 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
36711 $ SFZX*SSMR*SSMO)/DETD/SH
36712 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
36713 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
36715 XWRHT=1D0/(4D0*XW*(1D0-XW))
36716 KFF=IABS(KFPR(ISUB,1))
36718 AF=SIGN(1D0,EF+0.1D0)
36723 IF(KFF.LE.10) FCOF=3D0
36726 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
36727 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
36728 DZZ=DZZ*DCMPLX(XWRHT,0D0)
36729 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
36731 DO 330 I=MMINA,MMAXA
36732 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
36733 EI=KCHG(IABS(I),1)/3D0
36734 AI=SIGN(1D0,EI+0.1D0)
36739 IF(IABS(I).LE.10) FCOI=FCOI/3D0
36740 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
36741 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
36742 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
36743 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
36744 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
36745 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
36750 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
36753 ELSEIF(ISUB.EQ.195) THEN
36754 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
36757 ALPRHT=2.16D0*(3D0/ITCM(1))
36758 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
36760 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36761 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36763 C...Propagator including a_T^+
36765 CALL PYWIDT(24,SH,WDTP,WDTE)
36766 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36767 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36768 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36769 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36770 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36771 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36772 & DCMPLX(FWX**2,0D0)*SSMR
36773 DWW=SSMR*SSMX/DETD/SH
36775 IF(KFA.LE.8) FCOF=3D0
36776 HP=FACTC*ABS(DWW)**2*FCOF
36778 DO 350 I=MMIN1,MMAX1
36779 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
36781 DO 340 J=MMIN2,MMAX2
36782 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
36784 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
36785 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36787 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36789 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36794 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
36799 ELSEIF(ISUB.LE.380) THEN
36800 ALPRHT=2.16D0*(3D0/ITCM(1))
36801 IF(ISUB.EQ.361) THEN
36802 FAR=SQRT(AEM/ALPRHT)
36806 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36807 FZX=-FAR/SN2W*RTCM(47)
36813 CALL PYWIDT(23,SH,WDTP,WDTE)
36814 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
36815 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36816 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
36817 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36818 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
36819 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
36820 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
36821 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
36822 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
36823 C...Add in techni-a contribution
36824 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
36825 DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
36826 $ SFZX*FAR*SSMO)/DETD/SH
36827 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
36828 DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
36829 $ SFZX*FAO*SSMR)/DETD/SH
36830 DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
36831 DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
36832 DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
36833 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
36834 $ SFZX*SSMR*SSMO)/DETD/SH
36835 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
36836 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
36838 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
36839 C...W+W-, W pi_tc, pi_T pi_T, etc.
36840 FACA=(SH**2*BE34**2-(TH-UH)**2)
36841 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36842 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36843 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36844 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
36845 DO 370 I=MMINA,MMAXA
36846 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
36848 EI=KCHG(IABS(I),1)/3D0
36849 AI=SIGN(1D0,EI+0.1D0)
36851 VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
36852 VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
36853 C...........Eqs. (5) and (6) in LSTC-rates.pdf
36854 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
36855 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
36856 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
36857 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
36858 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
36859 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
36860 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
36861 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
36862 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
36863 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
36864 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
36865 C...........Eqs. (5) and (7) in LSTC-rates.pdf
36866 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
36867 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
36868 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
36869 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
36870 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
36871 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
36872 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
36874 C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
36876 c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36877 c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36878 c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36879 c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36880 F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36881 F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36882 HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
36884 IF(IA.LE.10) HI=HI/3D0
36889 IF(KFA.EQ.KFB) THEN
36890 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
36891 ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
36892 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
36897 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
36899 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
36903 ELSEIF(ISUB.EQ.370) THEN
36904 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
36905 C...f + fbar' -> gamma pi_tc, etc.
36906 FACA=(SH**2*BE34**2-(TH-UH)**2)
36907 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36908 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36909 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36910 ALPRHT=2.16D0*(3D0/ITCM(1))
36911 FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
36912 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36913 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36915 CALL PYWIDT(24,SH,WDTP,WDTE)
36916 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36917 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36918 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36919 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36920 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36921 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36922 & DCMPLX(FWX**2,0D0)*SSMR
36923 DWW=SSMR*SSMX/DETD/SH
36924 DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
36925 DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
36926 HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
36927 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
36929 C...........Eq. (25) in PRD67-115011 with DWW term dropped.
36931 c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
36932 HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
36933 C...Add in W_L Z_T axial and vector contributions.
36934 IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
36935 $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
36936 $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
36937 $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
36938 DO 410 I=MMIN1,MMAX1
36939 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
36941 DO 400 J=MMIN2,MMAX2
36942 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
36944 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
36945 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36947 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36949 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36954 IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
36955 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
36957 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
36958 & WIDS(PYCOMP(KFB),2)
36964 ELSEIF(ISUB.LE.390) THEN
36965 IF(ISUB.EQ.381) THEN
36966 C...f + f' -> f + f' (g exchange)
36967 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
36968 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
36969 & MSTP(34)*2D0/3D0*UH2*REDQST)
36970 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
36971 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
36972 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
36973 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
36974 C...Modifications from contact interactions (compositeness)
36975 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
36976 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36977 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
36978 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36979 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
36980 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
36981 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
36982 ELSEIF(ITCM(5).EQ.5) THEN
36987 CSM.......Check this change from
36991 DO 430 I=MMIN1,MMAX1
36993 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36994 DO 420 J=MMIN2,MMAX2
36996 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
37001 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
37004 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
37007 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
37008 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
37015 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
37016 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
37017 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
37019 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
37020 SIGH(NCHN)=0.5D0*FACCI2*RATCII
37026 ELSEIF(ISUB.EQ.382) THEN
37027 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
37028 CALL PYWIDT(21,SH,WDTP,WDTE)
37029 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
37030 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37031 IF(ITCM(5).EQ.1) THEN
37032 C...Modifications from contact interactions (compositeness)
37035 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
37036 & WDTE(I,2)+WDTE(I,4))
37038 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
37039 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
37040 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37041 ELSEIF(ITCM(5).EQ.5) THEN
37042 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
37043 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
37044 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
37046 DO 450 I=MMINA,MMAXA
37047 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37048 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
37053 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
37055 ELSEIF(ITCM(5).EQ.5) THEN
37067 ELSEIF(ISUB.EQ.383) THEN
37068 C...f + fbar -> g + g (q + qbar -> g + g only)
37069 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37070 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37071 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37072 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37073 IF(ITCM(5).EQ.5) THEN
37074 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37075 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37076 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37077 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37079 DO 460 I=MMINA,MMAXA
37080 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37081 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
37086 SIGH(NCHN)=0.5D0*FACGG1
37087 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
37092 SIGH(NCHN)=0.5D0*FACGG2
37093 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
37096 ELSEIF(ISUB.EQ.384) THEN
37097 C...f + g -> f + g (q + g -> q + g only)
37098 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
37099 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
37100 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
37101 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
37102 DO 480 I=MMINA,MMAXA
37103 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
37105 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
37106 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
37109 ISIG(NCHN,3-ISDE)=21
37114 ISIG(NCHN,3-ISDE)=21
37120 ELSEIF(ISUB.EQ.385) THEN
37121 C...g + g -> f + fbar (g + g -> q + qbar only)
37122 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
37124 C...Begin by d, u, s flavours.
37126 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
37127 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
37128 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
37129 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
37130 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
37131 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
37132 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37133 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37134 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37135 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37146 C...Next c and b flavours: modified that and uhat for fixed
37147 C...cos(theta-hat).
37149 SQMAVG=PMAS(IFL,1)**2
37150 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
37151 BE34=SQRT(1D0-4D0*SQMAVG/SH)
37152 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37153 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37154 THUHQ=THQ*UHQ-SQMAVG*SH
37155 IF(MSTP(34).EQ.0) THEN
37156 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37157 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37159 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37160 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37161 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37162 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37164 IF(ITCM(5).GE.5) THEN
37166 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37167 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37168 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37169 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37171 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37172 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37173 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37174 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37177 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
37178 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
37182 ISIG(NCHN,3)=1+2*(IFL-3)
37187 ISIG(NCHN,3)=2+2*(IFL-3)
37193 ELSEIF(ISUB.EQ.386) THEN
37195 IF(ITCM(5).LE.4) THEN
37196 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
37197 & 2D0*TH/SH+TH2/SH2)*FACA
37198 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
37199 & 2D0*SH/UH+SH2/UH2)*FACA
37200 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
37201 & 2D0*UH/TH+UH2/TH2)
37203 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
37204 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
37205 & 4D0*REDGST*(SH + 2D0*TH)*
37206 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
37207 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
37208 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
37209 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
37210 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
37211 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
37212 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
37213 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
37214 & 4D0*REDGSU*(SH + 2D0*UH)*
37215 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
37216 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
37217 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
37218 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
37219 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
37220 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
37221 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
37222 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
37223 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
37224 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
37225 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
37226 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
37227 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
37228 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
37229 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
37230 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
37231 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
37232 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
37233 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
37234 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
37235 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
37236 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
37238 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
37243 SIGH(NCHN)=0.5D0*FACGG1
37248 SIGH(NCHN)=0.5D0*FACGG2
37253 SIGH(NCHN)=0.5D0*FACGG3
37256 ELSEIF(ISUB.EQ.387) THEN
37257 C...q + qbar -> Q + Qbar
37258 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37259 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37260 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37261 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
37263 IF(ITCM(5).GE.5) THEN
37264 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37265 FACQQB=FACQQB*SH2*SQDQTS
37267 FACQQB=FACQQB*SH2*SQDQQS
37270 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
37272 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37273 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37275 DO 520 I=MMINA,MMAXA
37276 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37277 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
37285 ELSEIF(ISUB.EQ.388) THEN
37286 C...g + g -> Q + Qbar
37287 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37288 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37289 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37290 THUHQ=THQ*UHQ-SQMAVG*SH
37291 IF(MSTP(34).EQ.0) THEN
37292 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37293 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37295 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37296 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37297 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37298 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37300 IF(ITCM(5).GE.5) THEN
37301 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37302 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37303 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37304 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37305 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37307 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37308 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37309 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37310 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37313 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
37314 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
37315 IF(MSTP(35).GE.1) THEN
37316 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
37317 FACQQ1=FACQQ1*FATRE
37318 FACQQ2=FACQQ2*FATRE
37321 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37322 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37325 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
37345 C*********************************************************************
37348 C...Subprocess cross sections for assorted exotic processes,
37349 C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
37350 C...Auxiliary to PYSIGH.
37352 SUBROUTINE PYSGEX(NCHN,SIGS)
37354 C...Double precision and integer declarations
37355 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37356 IMPLICIT INTEGER(I-N)
37357 INTEGER PYK,PYCHGE,PYCOMP
37358 C...Parameter statement to help give large particle numbers.
37359 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37360 &KEXCIT=4000000,KDIMEN=5000000)
37362 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37363 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37364 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
37365 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37366 COMMON/PYINT1/MINT(400),VINT(400)
37367 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
37368 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
37369 COMMON/PYINT4/MWID(500),WIDS(500,5)
37370 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
37371 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
37372 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
37373 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
37374 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
37375 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
37376 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
37378 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
37380 C...Differential cross section expressions.
37382 IF(ISUB.LE.160) THEN
37383 IF(ISUB.EQ.141) THEN
37384 C...f + fbar -> gamma*/Z0/Z'0
37385 SQMZP=PMAS(32,1)**2
37387 CALL PYWIDT(32,SH,WDTP,WDTE)
37393 FACZP=4D0*COMFAC*3D0
37394 DO 100 I=MMINA,MMAXA
37395 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
37396 EI=KCHG(IABS(I),1)/3D0
37402 VPI=PARU(123-2*MOD(IABS(I),2))
37403 API=PARU(124-2*MOD(IABS(I),2))
37404 ELSEIF(IA.LE.4) THEN
37405 VPI=PARJ(182-2*MOD(IABS(I),2))
37406 API=PARJ(183-2*MOD(IABS(I),2))
37408 VPI=PARJ(190-2*MOD(IABS(I),2))
37409 API=PARJ(191-2*MOD(IABS(I),2))
37413 VPI=PARU(127-2*MOD(IABS(I),2))
37414 API=PARU(128-2*MOD(IABS(I),2))
37415 ELSEIF(IA.LE.14) THEN
37416 VPI=PARJ(186-2*MOD(IABS(I),2))
37417 API=PARJ(187-2*MOD(IABS(I),2))
37419 VPI=PARJ(194-2*MOD(IABS(I),2))
37420 API=PARJ(195-2*MOD(IABS(I),2))
37424 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
37426 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
37428 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
37433 C...Special case: if only branching ratios known then use them.
37434 IF(MWID(32).EQ.2.AND.MSTP(44).EQ.3) THEN
37437 HI=SHR*WDTP(IA)*FACA/9D0
37438 ELSEIF(IA.LT.20) THEN
37441 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37442 SIGH(NCHN)=HI*FACZP*HF/((SH-SQMZP)**2+HSP**2)
37444 C...Normal cross section.
37445 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
37446 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
37447 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
37448 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
37449 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
37450 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
37451 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
37452 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
37456 ELSEIF(ISUB.EQ.142) THEN
37457 C...f + fbar' -> W'+/-
37458 SQMWP=PMAS(34,1)**2
37459 CALL PYWIDT(34,SH,WDTP,WDTE)
37461 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
37462 HP=AEM/(24D0*XW)*SH
37463 DO 120 I=MMIN1,MMAX1
37464 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
37466 DO 110 J=MMIN2,MMAX2
37467 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
37469 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
37470 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37472 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37473 C...Special case: if only branching ratios known then use them.
37474 IF(MWID(34).EQ.2) THEN
37476 DO 105 IDC=MDCY(34,2),MDCY(34,2)+MDCY(34,3)-1
37477 IF((IA.EQ.IABS(KFDP(IDC,1)).AND.JA.EQ.
37478 & IABS(KFDP(IDC,2))).OR.(IA.EQ.IABS(KFDP(IDC,2))
37479 & .AND.JA.EQ.IABS(KFDP(IDC,1))))
37480 & HI=SHR*WDTP(IDC+1-MDCY(34,2))
37482 IF(IA.LT.10) HI=HI*FACA/9D0
37484 C...Normal cross section.
37485 HI=HP*(PARU(133)**2+PARU(134)**2)
37486 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
37487 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37493 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
37494 SIGH(NCHN)=HI*FACBW*HF
37498 ELSEIF(ISUB.EQ.144) THEN
37501 CALL PYWIDT(41,SH,WDTP,WDTE)
37503 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
37504 HP=AEM/(12D0*XW)*SH
37505 DO 140 I=MMIN1,MMAX1
37506 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
37508 DO 130 J=MMIN2,MMAX2
37509 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
37511 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
37513 IF(IA.LE.10) HI=HI*FACA/3D0
37514 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
37519 SIGH(NCHN)=HI*FACBW*HF
37523 ELSEIF(ISUB.EQ.145) THEN
37524 C...q + l -> LQ (leptoquark)
37525 SQMLQ=PMAS(42,1)**2
37526 CALL PYWIDT(42,SH,WDTP,WDTE)
37528 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
37529 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
37531 KFLQQ=KFDP(MDCY(42,2),1)
37532 KFLQL=KFDP(MDCY(42,2),2)
37533 DO 160 I=MMIN1,MMAX1
37534 IF(KFAC(1,I).EQ.0) GOTO 160
37536 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
37537 DO 150 J=MMIN2,MMAX2
37538 IF(KFAC(2,J).EQ.0) GOTO 150
37540 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
37541 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
37542 IF(JA.EQ.IA) GOTO 150
37543 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
37544 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
37546 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
37551 SIGH(NCHN)=HI*FACBW*HF
37555 ELSEIF(ISUB.EQ.146) THEN
37556 C...e + gamma* -> e* (excited lepton)
37557 KFQSTR=KFPR(ISUB,1)
37558 KCQSTR=PYCOMP(KFQSTR)
37559 KFQEXC=MOD(KFQSTR,KEXCIT)
37560 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
37562 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
37563 QF=-RTCM(43)/2D0-RTCM(44)/2D0
37564 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
37565 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
37568 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
37570 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
37571 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
37573 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37574 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
37577 ISIG(NCHN,3-ISDE)=22
37579 SIGH(NCHN)=HI*FACBW*HF
37583 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
37584 C...d + g -> d* and u + g -> u* (excited quarks)
37585 KFQSTR=KFPR(ISUB,1)
37586 KCQSTR=PYCOMP(KFQSTR)
37587 KFQEXC=MOD(KFQSTR,KEXCIT)
37588 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
37590 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
37591 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
37592 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
37595 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
37597 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
37598 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
37600 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37601 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
37604 ISIG(NCHN,3-ISDE)=21
37606 SIGH(NCHN)=HI*FACBW*HF
37611 ELSEIF(ISUB.LE.190) THEN
37612 IF(ISUB.EQ.162) THEN
37613 C...q + g -> LQ + lbar; LQ=leptoquark
37614 SQMLQ=PMAS(42,1)**2
37615 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
37616 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
37617 KFLQQ=KFDP(MDCY(42,2),1)
37618 DO 220 I=MMINA,MMAXA
37619 IF(IABS(I).NE.KFLQQ) GOTO 220
37622 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
37623 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
37626 ISIG(NCHN,3-ISDE)=21
37628 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
37632 ELSEIF(ISUB.EQ.163) THEN
37633 C...g + g -> LQ + LQbar; LQ=leptoquark
37634 SQMLQ=PMAS(42,1)**2
37635 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
37636 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
37637 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
37638 & ((TH-SQMLQ)*(UH-SQMLQ)))
37639 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
37643 C...Since don't know proper colour flow, randomize between alternatives
37644 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
37648 ELSEIF(ISUB.EQ.164) THEN
37649 C...q + qbar -> LQ + LQbar; LQ=leptoquark
37650 DELTA=0.25D0*(SQM3-SQM4)**2/SH
37651 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
37654 C SQMLQ=PMAS(42,1)**2
37655 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
37656 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
37657 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
37658 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
37659 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
37660 KFLQQ=KFDP(MDCY(42,2),1)
37661 DO 240 I=MMINA,MMAXA
37662 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37663 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
37669 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
37672 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
37673 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
37674 KFQSTR=KFPR(ISUB,2)
37675 KCQSTR=PYCOMP(KFQSTR)
37676 KFQEXC=MOD(KFQSTR,KEXCIT)
37677 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
37678 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
37679 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
37680 C...Propagators: as simulated in PYOFSH and as desired
37681 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
37682 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
37683 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
37684 GMMQC=SQRT(SQM4)*WDTP(0)
37685 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
37686 FACQSA=FACQSA*HBW4C/HBW4
37687 FACQSB=FACQSB*HBW4C/HBW4
37688 C...Branching ratios.
37689 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
37690 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
37691 DO 260 I=MMIN1,MMAX1
37693 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
37694 DO 250 J=MMIN2,MMAX2
37696 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
37697 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
37702 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
37703 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
37708 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
37709 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
37710 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
37715 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
37716 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
37717 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
37718 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
37723 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
37724 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
37729 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
37730 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
37731 ELSEIF(I.EQ.-J) THEN
37736 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37737 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37742 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37743 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37744 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
37749 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
37750 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
37751 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
37756 ELSEIF(ISUB.EQ.169) THEN
37757 C...q + qbar -> e + e* (excited lepton)
37758 KFQSTR=KFPR(ISUB,2)
37759 KCQSTR=PYCOMP(KFQSTR)
37760 KFQEXC=MOD(KFQSTR,KEXCIT)
37761 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
37762 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
37763 C...Propagators: as simulated in PYOFSH and as desired
37764 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
37765 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
37766 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
37767 GMMQC=SQRT(SQM4)*WDTP(0)
37768 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
37769 FACQSB=FACQSB*HBW4C/HBW4
37770 C...Branching ratios.
37771 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
37772 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
37773 DO 270 I=MMIN1,MMAX1
37775 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
37778 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
37783 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37784 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37789 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37790 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37794 ELSEIF(ISUB.LE.360) THEN
37795 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
37796 C...l + l -> H_L++/-- or H_R++/--.
37798 KFREC=PYCOMP(KFRES)
37799 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37801 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
37802 DO 290 I=MMIN1,MMAX1
37804 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
37806 DO 280 J=MMIN2,MMAX2
37808 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
37810 IF(I*J.LT.0) GOTO 280
37811 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37816 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
37817 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37818 SIGH(NCHN)=HI*FACBW*HF
37822 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
37823 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
37825 KFREC=PYCOMP(KFRES)
37826 C...Propagators: as simulated in PYOFSH and as desired
37827 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
37828 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
37829 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
37830 GMMC=SQRT(SQM3)*WDTP(0)
37831 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
37832 FHCC=COMFAC*AEM*HBW3C/HBW3
37833 DO 310 I=MMINA,MMAXA
37835 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
37837 J=ISIGN(KFPR(ISUB,2),-I)
37838 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
37839 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
37840 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
37842 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
37843 & (TH-SQM4)*SH)/(TH-SQM4)**2
37844 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
37846 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
37847 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
37848 & ((UH-SQM3)*(TH-SQM4))
37849 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
37850 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
37851 & ((UH-SQM3)*(SH-SQML))
37852 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
37853 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
37854 & ((SH-SQML)*(TH-SQM4))
37855 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
37856 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
37858 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
37859 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
37862 ISIG(NCHN,3-ISDE)=22
37864 SIGH(NCHN)=FHCC*SMM*WIDSC
37868 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
37869 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
37871 KFREC=PYCOMP(KFRES)
37872 SQMH=PMAS(KFREC,1)**2
37873 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
37874 C...Propagators: H++/-- as simulated in PYOFSH and as desired
37875 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
37876 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
37877 GMMH3=SQRT(SQM3)*WDTP(0)
37878 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
37879 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
37880 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
37881 GMMH4=SQRT(SQM4)*WDTP(0)
37882 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
37883 C...Kinematical and coupling functions
37884 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
37885 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
37886 C...Loop over allowed flavours
37887 DO 320 I=MMINA,MMAXA
37888 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
37889 EI=KCHG(IABS(I),1)/3D0
37890 AI=SIGN(1D0,EI+0.1D0)
37893 IF(IABS(I).LE.10) FCOI=FACA/3D0
37894 IF(ISUB.EQ.349) THEN
37895 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
37896 IF(IABS(I).LT.10) THEN
37897 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37898 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37899 & (VI**2+AI**2)*XWHH**2*HBWZ)
37901 IAOFF=181+3*((IABS(I)-11)/2)
37902 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37904 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37905 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37906 & (VI**2+AI**2)*XWHH**2*HBWZ)+
37907 & 8D0*AEM*(EI*HSUM/(SH*TH)+
37908 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
37912 IF(IABS(I).LT.10) THEN
37913 DSIGHH=8D0*AEM**2*EI**2/SH2
37915 IAOFF=181+3*((IABS(I)-11)/2)
37916 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37918 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
37926 SIGH(NCHN)=FACHH*FCOI*DSIGHH
37929 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
37930 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
37932 KFREC=PYCOMP(KFRES)
37933 SQMH=PMAS(KFREC,1)**2
37934 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
37935 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
37936 & PMAS(PYCOMP(9900024),1)**2
37937 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
37938 FACPRT=1D0/((VINT(204)**2-VINT(215))*
37939 & (VINT(209)**2-VINT(216)))
37940 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
37941 & (VINT(209)**2+2D0*VINT(218)))
37942 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37944 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
37945 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
37947 DO 340 I=MMIN1,MMAX1
37948 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
37949 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
37950 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
37951 DO 330 J=MMIN2,MMAX2
37952 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
37953 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
37954 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
37956 IF(IABS(KCHH).NE.2) GOTO 330
37957 FACLR=VINT(180+I)*VINT(180+J)
37958 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37959 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
37960 FACPRP=0.5D0*(FACPRT+FACPRU)**2
37968 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
37972 ELSEIF(ISUB.EQ.353) THEN
37973 C...f + fbar -> Z_R0
37974 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37975 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37977 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
37978 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37979 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
37980 DO 350 I=MMINA,MMAXA
37981 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
37982 IF(IABS(I).LE.8) THEN
37983 EI=KCHG(IABS(I),1)/3D0
37984 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
37985 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
37990 HI=HP*(VI**2+AI**2)
37991 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37996 SIGH(NCHN)=HI*FACBW*HF
37999 ELSEIF(ISUB.EQ.354) THEN
38000 C...f + fbar' -> W_R+/-
38001 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
38002 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
38004 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
38005 HP=AEM/(24D0*XW)*SH
38006 DO 370 I=MMIN1,MMAX1
38007 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
38009 DO 360 J=MMIN2,MMAX2
38010 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
38012 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
38013 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
38015 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38017 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
38022 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
38023 SIGH(NCHN)=HI*FACBW*HF
38028 ELSEIF(ISUB.LE.400) THEN
38029 IF(ISUB.EQ.391) THEN
38030 C...f + fbar -> G*.
38031 KFGSTR=KFPR(ISUB,1)
38032 KCGSTR=PYCOMP(KFGSTR)
38033 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38035 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38036 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
38037 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38038 C...Modify cross section in wings of peak.
38039 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38040 DO 380 I=MMINA,MMAXA
38041 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
38043 IF(IABS(I).LE.10) HI=HI*FACA/3D0
38051 ELSEIF(ISUB.EQ.392) THEN
38053 KFGSTR=KFPR(ISUB,1)
38054 KCGSTR=PYCOMP(KFGSTR)
38055 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38057 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38058 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
38059 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38060 C...Modify cross section in wings of peak.
38061 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38062 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
38070 ELSEIF(ISUB.EQ.393) THEN
38071 C...q + qbar -> g + G*.
38072 KFGSTR=KFPR(ISUB,2)
38073 KCGSTR=PYCOMP(KFGSTR)
38074 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
38075 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
38076 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
38078 C...Propagators: as simulated in PYOFSH and as desired
38079 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38080 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38081 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38082 HS=SQRT(SQM4)*WDTP(0)
38083 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38084 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38085 FACG=FACG*HBW4C/HBW4
38086 DO 400 I=MMINA,MMAXA
38087 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
38088 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
38096 ELSEIF(ISUB.EQ.394) THEN
38097 C...q + g -> q + G*.
38098 KFGSTR=KFPR(ISUB,2)
38099 KCGSTR=PYCOMP(KFGSTR)
38100 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
38101 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
38102 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
38103 & 2D0*TH2*TH/(UH*SH2))
38104 C...Propagators: as simulated in PYOFSH and as desired
38105 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38106 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38107 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38108 HS=SQRT(SQM4)*WDTP(0)
38109 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38110 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38111 FACG=FACG*HBW4C/HBW4
38112 DO 420 I=MMINA,MMAXA
38113 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
38115 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
38116 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
38119 ISIG(NCHN,3-ISDE)=21
38125 ELSEIF(ISUB.EQ.395) THEN
38126 C...g + g -> g + G*.
38127 KFGSTR=KFPR(ISUB,2)
38128 KCGSTR=PYCOMP(KFGSTR)
38129 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
38130 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
38131 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
38132 C...Propagators: as simulated in PYOFSH and as desired
38133 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38134 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38135 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38136 HS=SQRT(SQM4)*WDTP(0)
38137 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38138 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38139 FACG=FACG*HBW4C/HBW4
38140 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
38153 C*********************************************************************
38156 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
38157 C...parton distributions according to a few different parametrizations.
38158 C...Note that what is coded is x times the probability distribution,
38159 C...i.e. xq(x,Q2) etc.
38161 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
38163 C...Double precision and integer declarations.
38164 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38165 IMPLICIT INTEGER(I-N)
38166 INTEGER PYK,PYCHGE,PYCOMP
38168 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38169 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38170 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38171 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38172 COMMON/PYINT1/MINT(400),VINT(400)
38173 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38175 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38176 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
38177 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
38178 & XMI(2,240),PT2MI(240),IMISEP(0:240)
38179 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
38182 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
38183 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
38186 C...Interface to PDFLIB.
38187 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
38189 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38190 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38191 CHARACTER*20 PARM(20)
38192 DATA VALUE/20*0D0/,PARM/20*' '/
38194 C...Data related to Schuler-Sjostrand photon distributions.
38195 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
38197 C...Valence PDF momentum integral parametrizations PER PARTON!
38198 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
38199 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
38200 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
38201 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
38203 C...Reset parton distributions.
38212 C...Check x and particle species.
38213 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38214 WRITE(MSTU(11),5000) X
38218 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
38219 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
38220 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
38221 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
38222 &KFA.NE.310.AND.KFA.NE.130) THEN
38223 WRITE(MSTU(11),5100) KF
38227 C...Electron (or muon or tau) parton distribution call.
38228 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
38229 CALL PYPDEL(KFA,X,Q2,XPEL)
38234 C...Photon parton distribution call (VDM+anomalous).
38235 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
38236 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
38237 CALL PYPDGA(X,Q2,XPGA)
38241 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
38244 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
38245 XPVAL(4)=MIN(XPQ(4),XPVU)
38246 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
38252 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
38255 IF(MSTP(55).GE.7) P2MX=4.0D0
38256 IF(MSTP(57).EQ.0) Q2MX=P2MX
38258 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38259 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38262 XPVAL(KFL)=VXPDGM(KFL)
38265 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
38268 IF(MSTP(55).GE.11) P2MX=4.0D0
38269 IF(MSTP(57).EQ.0) Q2MX=P2MX
38271 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38272 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38274 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38275 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38278 ELSEIF(MSTP(56).EQ.2) THEN
38279 C...Call PDFLIB parton distributions.
38283 VALUE(2)=MSTP(55)/1000
38285 VALUE(3)=MOD(MSTP(55),1000)
38286 IF(MINT(93).NE.3000000+MSTP(55)) THEN
38287 CALL PDFSET_ALICE(PARM,VALUE)
38288 MINT(93)=3000000+MSTP(55)
38291 QQ2=MAX(0D0,Q2MIN,Q2)
38292 IF(MSTP(57).EQ.0) QQ2=Q2MIN
38294 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38296 IF(MSTP(55).EQ.5004) THEN
38297 IF(5D0*P2.LT.QQ2.AND.
38298 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
38299 & P2.GE.0D0.AND.P2.LT.10D0.AND.
38300 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
38301 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
38316 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
38344 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
38347 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
38348 XPVAL(4)=MIN(XPQ(4),XPVU)
38349 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
38356 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
38359 C...Pion/gammaVDM parton distribution call.
38360 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
38361 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
38362 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
38363 & MSTP(55).LE.12) THEN
38364 ISET=1+MOD(MSTP(55)-1,4)
38367 IF(ISET.GE.3) P2MX=4.0D0
38368 IF(MSTP(57).EQ.0) Q2MX=P2MX
38370 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38371 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38373 XPQ(KFL)=XPVMD(KFL)
38374 XPVAL(KFL)=VXPVMD(KFL)
38377 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
38378 CALL PYPDPI(X,Q2,XPPI)
38382 XPVAL(2)=XPQ(2)-XPQ(-2)
38383 XPVAL(-1)=XPQ(-1)-XPQ(1)
38384 ELSEIF(MSTP(54).EQ.2) THEN
38385 C...Call PDFLIB parton distributions.
38389 VALUE(2)=MSTP(53)/1000
38391 VALUE(3)=MOD(MSTP(53),1000)
38392 IF(MINT(93).NE.2000000+MSTP(53)) THEN
38393 CALL PDFSET_ALICE(PARM,VALUE)
38394 MINT(93)=2000000+MSTP(53)
38397 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38398 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38400 & (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38418 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
38421 C...Anomalous photon parton distribution call.
38422 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
38425 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
38426 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
38427 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
38428 IF(MSTP(57).EQ.0) Q2MX=P2MX
38430 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38431 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
38433 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
38434 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
38437 ELSEIF(MSTP(56).EQ.1) THEN
38438 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
38439 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
38440 IF(MSTP(57).EQ.0) Q2MX=P2MX
38442 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38443 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
38445 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
38446 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
38449 ELSEIF(MSTP(56).EQ.2) THEN
38450 IF(MSTP(57).EQ.0) Q2MX=P2MX
38451 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
38454 XPVAL(KFL)=VXPGA(KFL)
38457 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
38458 IF(MSTP(57).EQ.0) Q2MX=P2MX
38459 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
38462 XPVAL(KFL)=VXPGA(KFL)
38466 220 RKF=11D0*PYR(0)
38468 IF(RKF.GT.1D0) KFR=2
38469 IF(RKF.GT.5D0) KFR=3
38470 IF(RKF.GT.6D0) KFR=4
38471 IF(RKF.GT.10D0) KFR=5
38472 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
38473 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
38474 IF(MSTP(57).EQ.0) Q2MX=P2MX
38475 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
38478 XPVAL(KFL)=VXPGA(KFL)
38483 C...Proton parton distribution call.
38485 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
38486 CALL PYPDPR(X,Q2,XPPR)
38490 C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
38491 XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1))
38492 XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2))
38493 ELSEIF(MSTP(52).EQ.2) THEN
38494 C...Call PDFLIB parton distributions.
38498 VALUE(2)=MSTP(51)/1000
38500 VALUE(3)=MOD(MSTP(51),1000)
38501 IF(MINT(93).NE.1000000+MSTP(51)) THEN
38502 CALL PDFSET_ALICE(PARM,VALUE)
38503 MINT(93)=1000000+MSTP(51)
38506 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38507 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38508 CALL STRUCTM_ALICE(
38509 & XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38527 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
38531 C...Isospin average for pi0/gammaVDM.
38532 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
38533 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
38538 XPS=0.5D0*(XPQ(1)+XPQ(-2))
38539 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
38543 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
38544 & XPVAL(3)+XPVAL(4)+XPVAL(5)
38548 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
38549 XPQ(1)=XPQ(1)+0.2D0*XPV
38550 XPQ(2)=XPQ(2)+0.8D0*XPV
38551 XPVAL(1)=0.2D0*XPVL
38552 XPVAL(2)=0.8D0*XPVL
38553 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
38556 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
38559 IF(MSTP(55).GE.9) THEN
38565 XPQ(1)=XPQ(1)+0.5D0*XPV
38566 XPQ(2)=XPQ(2)+0.5D0*XPV
38567 XPVAL(1)=0.5D0*XPVL
38568 XPVAL(2)=0.5D0*XPVL
38572 XPVAL(-KFL)=XPVAL(KFL)
38575 C...Rescale for gammaVDM by effective gamma -> rho coupling.
38576 C+++Do not rescale?
38577 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
38578 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
38580 XPQ(KFL)=VINT(281)*XPQ(KFL)
38581 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
38583 VINT(232)=VINT(281)*XPV
38586 C...Simple recipes for kaons.
38587 ELSEIF(KFA.EQ.321) THEN
38588 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
38590 XPVAL(-3)=XPVAL(-1)
38592 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
38593 XPS=0.5D0*(XPQ(1)+XPQ(-2))
38594 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
38597 XPQ(1)=XPQ(1)+0.5D0*XPV
38598 XPQ(-1)=XPQ(-1)+0.5D0*XPV
38599 XPQ(3)=XPQ(3)+0.5D0*XPV
38600 XPQ(-3)=XPQ(-3)+0.5D0*XPV
38601 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
38605 XPVAL(-1)=0.5D0*XPV
38607 XPVAL(-3)=0.5D0*XPV
38609 C...Isospin conjugation for neutron.
38610 ELSEIF(KFA.EQ.2112) THEN
38621 C...Simple recipes for hyperon (average valence parton distribution).
38622 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
38623 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
38624 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
38625 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
38630 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
38631 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
38632 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
38633 XPV=(XPVAL(1)+XPVAL(2))/3D0
38636 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
38637 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
38638 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
38641 C...Charge conjugation for antiparticle.
38644 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
38651 XPVAL(KFL)=XPVAL(-KFL)
38656 C...MULTIPLE INTERACTIONS - PDF RESHAPING.
38659 C...Only reshape PDFs for the non-first interactions;
38660 C...But need valence/sea separation already from first interaction.
38661 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
38662 KFVSEL=KFIVAL(JS,1)
38663 C...If valence quark kicked out of pi0 or gamma then that decides
38664 C...whether we should consider state as d dbar, u ubar, s sbar, etc.
38665 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
38668 XPVL=XPVL+XPVAL(KFL)
38669 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
38672 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
38673 XPVAL(IABS(KFVSEL))=XPVL
38676 XPVAL(-KFL)=XPVAL(KFL)
38679 C...If valence quark kicked out of K0S or K0S then that decides whether
38680 C...we should consider state as d sbar or s dbar.
38681 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
38683 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
38684 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
38685 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
38686 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
38689 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
38690 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
38691 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
38695 C...XPQ distributions are nominal for a (signed) beam particle
38696 C...of KF type, with 1-Sum(x_prev) rescaled to 1.
38704 IF(IFL.EQ.0) GOTO 350
38706 C...Count up number of original IFL valence quarks.
38708 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
38709 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
38710 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
38711 C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
38712 C...bookkeep as if d dbar (for total momentum sum in valence sector).
38713 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
38714 C...Count down number of remaining IFL valence quarks. Skip current
38715 C...interaction initiator.
38717 DO 330 I1=1,NMI(JS)
38718 IF (I1.EQ.MINT(36)) GOTO 330
38719 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
38723 C...Separate out original VALENCE and SEA content.
38725 SEA=MAX(0D0,XPQ(IFL)-VAL)
38729 C...Rescale valence content if changed.
38730 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
38731 & (VAL*IVREM)/IVORG
38733 C...Momentum integrals of original and removed valence quarks.
38734 IF(IVORG.NE.0) THEN
38735 C...For p/n/pbar/nbar beams can split into d_val and u_val.
38736 C...Isospin conjugation for neutrons
38737 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
38739 IF (KFA.EQ.2112) IAFLP=3-IAFLP
38740 VPAVG=PAVG(IAFLP,Q2)
38741 C...For other baryons average d_val and u_val, like for PDFs.
38742 ELSEIF(KFA.GT.1000) THEN
38743 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
38744 C...For mesons and photon average d_val and u_val and scale by 3/2.
38745 C...Very crude, especially for photon.
38747 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
38749 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
38750 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
38753 C...Now add companions (at X with partner having been at Z=XASSOC).
38754 C...NOTE: due to the assumed simple x scaling, the partner was at what
38755 C...corresponds to a higher Z than XASSOC, if there were intermediate
38756 C...scatterings. Nothing done about that for the moment.
38757 DO 340 IVC=1,NVC(JS,IFL)
38758 C...Skip companions that have been kicked out
38759 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
38763 C...Momentum fraction of the partner quark.
38764 C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
38765 XS=XASSOC(JS,IFL,IVC)
38768 C...Momentum fraction of the companion quark.
38769 C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
38771 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
38772 C...Add to momentum sum, with rescaling compensation factor.
38773 XCFAC=(XREM+XS)/XREM*CMPFAC
38774 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
38779 C...Wait until all flavours treated, then rescale seas and gluon.
38782 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
38783 IF (RSFAC.LE.0D0) THEN
38784 C...First calculate factor needed to exactly restore pz cons.
38785 IF (NRESC.EQ.1) CMPFAC =
38786 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
38787 C...Add a bit of headroom
38789 C...Try a few times if more headroom is needed, then print error message.
38790 IF (NRESC.LE.10) GOTO 345
38792 & '(PYPDFU:) Negative reshaping factor persists!')
38793 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
38797 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
38798 C...Also store resulting distributions in XPQ
38800 DO 360 ISVC=-1,NVC(JS,IFL)
38801 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
38804 C...Save companion reweighting factor for PYPTIS.
38809 C...Allow gluon also in position 21.
38812 C...Check positivity and reset above maximum allowed flavour.
38814 XPQ(KFL)=MAX(0D0,XPQ(KFL))
38815 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
38818 C...Formats for error printouts.
38819 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
38820 5100 FORMAT(' Error: illegal particle code for parton distribution;',
38822 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
38824 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
38825 & ' Removed valence momentum fraction : ',F6.3/
38826 & ' Added companion momentum fraction : ',F6.3/
38827 & ' Resulting rescale factor : ',F6.3)
38829 C...Reset side pointer and return
38835 C*********************************************************************
38838 C...Gives proton parton distribution at small x and/or Q^2 according to
38839 C...correct limiting behaviour.
38841 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
38843 C...Double precision and integer declarations.
38844 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38845 IMPLICIT INTEGER(I-N)
38846 INTEGER PYK,PYCHGE,PYCOMP
38848 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38849 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38850 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38851 COMMON/PYINT1/MINT(400),VINT(400)
38852 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
38854 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
38855 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
38857 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
38861 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
38862 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
38863 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
38865 CALL PYPDFU(KF,X,Q2,XPQ)
38869 C...Reset. Check x.
38873 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38874 WRITE(MSTU(11),5000) X
38878 C...Define valence content.
38882 IF(KF.EQ.2212) THEN
38885 ELSEIF(KF.EQ.-2212) THEN
38888 ELSEIF(KF.EQ.2112) THEN
38891 ELSEIF(KF.EQ.-2112) THEN
38894 ELSEIF(KF.EQ.211) THEN
38898 ELSEIF(KF.EQ.-211) THEN
38902 ELSEIF(MINT(105).LE.223) THEN
38907 ELSEIF(MINT(105).EQ.333) THEN
38912 ELSEIF(MINT(105).EQ.443) THEN
38919 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
38921 CALL PYPDFU(KFC,X,Q2,XPA)
38922 Q2MN=MAX(3D0,VINT(231))
38923 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
38924 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
38926 C...Large Q2 and large x: naive call is enough.
38927 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
38933 C...Small Q2 and large x: dampen boundary value.
38934 ELSEIF(X.GT.XMN) THEN
38936 C...Evaluate at boundary and define dampening factors.
38938 CALL PYPDFU(KFC,X,Q2MN,XPA)
38939 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
38940 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
38942 C...Separate valence and sea parts of parton distribution.
38944 XFV1=XPA(KFV1)-XPA(-KFV1)
38945 XPA(KFV1)=XPA(-KFV1)
38946 XFV2=XPA(KFV2)-XPA(-KFV2)
38947 XPA(KFV2)=XPA(-KFV2)
38949 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38950 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38951 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38952 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38955 C...Dampen valence and sea separately. Put back together.
38957 XPQ(KFL)=FS*XPA(KFL)
38960 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
38961 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
38963 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
38964 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
38965 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
38966 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
38970 C...Large Q2 and small x: interpolate behaviour.
38971 ELSEIF(Q2.GT.Q2MN) THEN
38973 C...Evaluate at extremes and define coefficients for interpolation.
38975 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38978 CALL PYPDFU(KFC,X,Q2B,XPB)
38980 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
38981 FVA=(X/XMN)**0.45D0*FLA
38982 FSA=(X/XMN)**(-0.08D0)*FLA
38985 C...Separate valence and sea parts of parton distribution.
38987 XFVA1=XPA(KFV1)-XPA(-KFV1)
38988 XPA(KFV1)=XPA(-KFV1)
38989 XFVA2=XPA(KFV2)-XPA(-KFV2)
38990 XPA(KFV2)=XPA(-KFV2)
38991 XFVB1=XPB(KFV1)-XPB(-KFV1)
38992 XPB(KFV1)=XPB(-KFV1)
38993 XFVB2=XPB(KFV2)-XPB(-KFV2)
38994 XPB(KFV2)=XPB(-KFV2)
38996 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
38997 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
38998 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
38999 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
39000 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
39001 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
39002 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
39003 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
39006 C...Interpolate for valence and sea. Put back together.
39008 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
39011 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
39012 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
39014 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39015 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39016 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39017 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39021 C...Small Q2 and small x: dampen boundary value and add term.
39024 C...Evaluate at boundary and define dampening factors.
39026 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
39027 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
39029 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
39030 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
39031 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
39032 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
39033 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
39034 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
39036 C...Separate valence and sea parts of parton distribution.
39038 XFV1=XPA(KFV1)-XPA(-KFV1)
39039 XPA(KFV1)=XPA(-KFV1)
39040 XFV2=XPA(KFV2)-XPA(-KFV2)
39041 XPA(KFV2)=XPA(-KFV2)
39043 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
39044 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
39045 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
39046 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
39049 C...Dampen valence and sea separately. Add constant terms.
39050 C...Put back together.
39052 XPQ(KFL)=FSA*XPA(KFL)
39056 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
39058 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
39059 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
39062 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
39064 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39065 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39066 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39067 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39073 C...Format for error printout.
39074 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
39079 C*********************************************************************
39082 C...Gives electron (or muon, or tau) parton distribution.
39084 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
39086 C...Double precision and integer declarations.
39087 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39088 IMPLICIT INTEGER(I-N)
39089 INTEGER PYK,PYCHGE,PYCOMP
39091 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39092 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39093 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39094 COMMON/PYINT1/MINT(400),VINT(400)
39095 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39097 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
39099 C...Interface to PDFLIB.
39100 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
39102 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
39103 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
39104 CHARACTER*20 PARM(20)
39105 DATA VALUE/20*0D0/,PARM/20*' '/
39107 C...Some common constants.
39113 IF(KFA.EQ.13) PME=PMAS(13,1)
39114 IF(KFA.EQ.15) PME=PMAS(15,1)
39115 XL=LOG(MAX(1D-10,X))
39116 X1L=LOG(MAX(1D-10,1D0-X))
39117 HLE=LOG(MAX(3D0,Q2/PME**2))
39118 HBE2=(AEM/PARU(1))*(HLE-1D0)
39120 C...Electron inside electron, see R. Kleiss et al., in Z physics at
39121 C...LEP 1, CERN 89-08, p. 34
39122 IF(MSTP(59).LE.1) THEN
39123 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
39124 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
39125 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
39126 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
39127 & 4D0*XL/(1D0-X)-5D0-X)
39129 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
39130 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
39131 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
39133 C...Zero distribution for very large x and rescale it for intermediate.
39134 IF(X.GT.1D0-1D-10) THEN
39136 ELSEIF(X.GT.1D0-1D-7) THEN
39137 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
39141 C...Photon and (transverse) W- inside electron.
39142 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
39143 IF(MSTP(13).LE.1) THEN
39146 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
39148 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
39149 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
39150 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
39152 C...Electron or positron inside photon inside electron.
39153 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
39154 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
39155 & 2D0*X*(1D0+X)*XL)
39156 XPEL(11)=XPEL(11)+XFSEA
39159 C...Initialize PDFLIB photon parton distributions.
39160 IF(MSTP(56).EQ.2) THEN
39164 VALUE(2)=MSTP(55)/1000
39166 VALUE(3)=MOD(MSTP(55),1000)
39167 IF(MINT(93).NE.3000000+MSTP(55)) THEN
39168 CALL PDFSET_ALICE(PARM,VALUE)
39169 MINT(93)=3000000+MSTP(55)
39173 C...Quarks and gluons inside photon inside electron:
39174 C...numerical convolution required.
39183 IF(ITER.EQ.0) NSTP=2
39185 SXP(KFL)=0.5D0*SXP(KFL)
39188 IF(ITER.EQ.0) WTSTP=0.5D0
39189 C...Pick grid of x_{gamma} values logarithmically even.
39194 XLE=XL*(ISTP-0.5D0)/NSTP
39196 XE=MIN(1D0-1D-10,EXP(XLE))
39197 XG=MIN(1D0-1D-10,X/XE)
39198 C...Evaluate photon inside electron parton distribution for convolution.
39199 XPGP=1D0+(1D0-XE)**2
39200 IF(MSTP(13).LE.1) THEN
39203 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
39205 C...Evaluate photon parton distributions for convolution.
39206 IF(MSTP(56).EQ.1) THEN
39207 IF(MSTP(55).EQ.1) THEN
39208 CALL PYPDGA(XG,Q2,XPGA)
39209 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
39212 IF(MSTP(55).GE.7) P2MX=4.0D0
39213 IF(MSTP(57).EQ.0) Q2MX=P2MX
39215 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39216 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39218 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
39221 IF(MSTP(55).GE.11) P2MX=4.0D0
39222 IF(MSTP(57).EQ.0) Q2MX=P2MX
39224 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39225 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39229 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
39231 ELSEIF(MSTP(56).EQ.2) THEN
39232 C...Call PDFLIB parton distributions.
39234 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39235 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39237 & (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
39238 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
39239 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
39240 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
39241 SXP(3)=SXP(3)+WTSTP*XPGP*STR
39242 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
39243 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
39244 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
39247 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
39248 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
39249 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
39251 C...Put convolution into output arrays.
39253 XPEL(0)=FCONV*SXP(0)
39255 XPEL(KFL)=FCONV*SXP(KFL)
39256 XPEL(-KFL)=XPEL(KFL)
39263 C*********************************************************************
39266 C...Gives photon parton distribution.
39268 SUBROUTINE PYPDGA(X,Q2,XPGA)
39270 C...Double precision and integer declarations.
39271 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39272 IMPLICIT INTEGER(I-N)
39273 INTEGER PYK,PYCHGE,PYCOMP
39275 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39276 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39277 COMMON/PYINT1/MINT(400),VINT(400)
39278 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
39280 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
39281 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
39282 &DGCS(4,3),DGDS(4,3),DGES(4,3)
39284 C...The following data lines are coefficients needed in the
39285 C...Drees and Grassie photon parton distribution parametrization.
39286 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
39287 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
39288 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
39289 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
39290 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
39291 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
39292 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
39293 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
39294 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
39295 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
39296 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
39297 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
39298 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
39299 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
39300 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
39301 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
39302 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
39303 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
39304 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
39305 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
39306 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
39307 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
39308 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
39309 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
39310 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
39311 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
39313 C...Photon parton distribution from Drees and Grassie.
39314 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
39319 IF(MSTP(57).LE.0) THEN
39322 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
39326 IF(Q2.GT.25D0) NF=4
39327 IF(Q2.GT.300D0) NF=5
39331 C...Evaluate gluon content.
39332 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
39333 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
39334 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
39335 XPGL=DGA*X**DGB*X1**DGC
39337 C...Evaluate up- and down-type quark content.
39338 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
39339 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
39340 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
39341 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
39342 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
39343 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
39344 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
39345 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
39346 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
39347 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
39348 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
39350 IF(NF.EQ.4) DGF=10D0
39351 IF(NF.EQ.5) DGF=55D0/6D0
39352 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
39354 XPQU=(XPQS+9D0*XPQN)/6D0
39355 XPQD=(XPQS-4.5D0*XPQN)/6D0
39356 ELSEIF(NF.EQ.4) THEN
39357 XPQU=(XPQS+6D0*XPQN)/8D0
39358 XPQD=(XPQS-6D0*XPQN)/8D0
39360 XPQU=(XPQS+7.5D0*XPQN)/10D0
39361 XPQD=(XPQS-5D0*XPQN)/10D0
39364 C...Put into output arrays.
39369 IF(NF.GE.4) XPGA(4)=AEM*XPQU
39370 IF(NF.GE.5) XPGA(5)=AEM*XPQD
39372 XPGA(-KFL)=XPGA(KFL)
39378 C*********************************************************************
39381 C...Constructs the F2 and parton distributions of the photon
39382 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
39383 C...For F2, c and b are included by the Bethe-Heitler formula;
39384 C...in the 'MSbar' scheme additionally a Cgamma term is added.
39385 C...Contains the SaS sets 1D, 1M, 2D and 2M.
39386 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39388 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
39390 C...Double precision and integer declarations.
39391 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39392 IMPLICIT INTEGER(I-N)
39393 INTEGER PYK,PYCHGE,PYCOMP
39395 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
39397 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
39398 SAVE /PYINT8/,/PYINT9/
39400 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
39401 C...Charm and bottom masses (low to compensate for J/psi etc.).
39402 DATA PMC/1.3D0/, PMB/4.6D0/
39403 C...alpha_em and alpha_em/(2*pi).
39404 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
39405 C...Lambda value for 4 flavours.
39407 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
39409 C...VMD couplings f_V**2/(4*pi).
39410 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
39411 C...Masses for rho (=omega) and phi.
39412 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
39413 C...Number of points in integration for IP2=1.
39431 C...Set Q0 cut-off parameter as function of set used.
39439 C...Scale choice for off-shell photon; common factors.
39444 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
39445 FACNOR=LOG(Q2/Q02)/NSTEP
39446 ELSEIF(IP2.EQ.2) THEN
39448 ELSEIF(IP2.EQ.3) THEN
39450 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
39451 ELSEIF(IP2.EQ.4) THEN
39452 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39453 & ((Q2+P2)*(Q02+P2)))
39454 ELSEIF(IP2.EQ.5) THEN
39455 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39456 & ((Q2+P2)*(Q02+P2)))
39457 P2MX=Q0*SQRT(P2MXA)
39458 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
39459 ELSEIF(IP2.EQ.6) THEN
39460 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39461 & ((Q2+P2)*(Q02+P2)))
39462 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
39464 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39465 & ((Q2+P2)*(Q02+P2)))
39466 P2MX=Q0*SQRT(P2MXA)
39468 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
39469 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
39470 IF(ABS(Q2-Q02).GT.1D-6) THEN
39471 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
39472 ELSEIF(P2.LT.Q02) THEN
39473 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
39479 C...Call VMD parametrization for d quark and use to give rho, omega,
39480 C...phi. Note dipole dampening for off-shell photon.
39481 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39485 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
39486 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
39488 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
39490 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
39491 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
39492 XPVMD(3)=XPVMD(3)+FACS*XFVAL
39493 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
39494 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
39495 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
39496 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
39497 VXPVMD(2)=FRACU*FACUD*XFVAL
39498 VXPVMD(3)=FACS*XFVAL
39499 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
39500 VXPVMD(-2)=FRACU*FACUD*XFVAL
39501 VXPVMD(-3)=FACS*XFVAL
39504 C...Anomalous parametrizations for different strategies
39505 C...for off-shell photons; except full integration.
39507 C...Call anomalous parametrization for d + u + s.
39508 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39510 XPANL(KFL)=FACNOR*XPGA(KFL)
39511 VXPANL(KFL)=FACNOR*VXPGA(KFL)
39514 C...Call anomalous parametrization for c and b.
39515 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39517 XPANH(KFL)=FACNOR*XPGA(KFL)
39518 VXPANH(KFL)=FACNOR*VXPGA(KFL)
39520 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39522 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
39523 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
39527 C...Special option: loop over flavours and integrate over k2.
39529 DO 160 ISTEP=1,NSTEP
39530 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
39531 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
39532 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
39533 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
39534 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
39535 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
39536 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
39538 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
39539 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
39540 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
39541 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
39547 C...Call Bethe-Heitler term expression for charm and bottom.
39548 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
39551 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
39555 C...For MSbar subtraction call C^gamma term expression for d, u, s.
39556 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
39557 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
39559 XPDIR(KFL)=XPGA(KFL)
39563 C...Store result in output array.
39566 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
39567 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
39568 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
39569 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
39570 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
39576 C*********************************************************************
39579 C...Evaluates the VMD parton distributions of a photon,
39580 C...evolved homogeneously from an initial scale P2 to Q2.
39581 C...Does not include dipole suppression factor.
39582 C...ISET is parton distribution set, see above;
39583 C...additionally ISET=0 is used for the evolution of an anomalous photon
39584 C...which branched at a scale P2 and then evolved homogeneously to Q2.
39585 C...ALAM is the 4-flavour Lambda, which is automatically converted
39586 C...to 3- and 5-flavour equivalents as needed.
39587 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39589 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39591 C...Double precision and integer declarations.
39592 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39593 IMPLICIT INTEGER(I-N)
39594 INTEGER PYK,PYCHGE,PYCOMP
39595 C...Local arrays and data.
39596 DIMENSION XPGA(-6:6), VXPGA(-6:6)
39597 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
39606 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39607 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
39608 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
39609 P2EFF=MAX(P2,1.2D0*ALAM3**2)
39610 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
39611 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
39612 Q2EFF=MAX(Q2,P2EFF)
39614 C...Find number of flavours at lower and upper scale.
39616 IF(P2EFF.LT.PMC**2) NFP=3
39617 IF(P2EFF.GT.PMB**2) NFP=5
39619 IF(Q2EFF.LT.PMC**2) NFQ=3
39620 IF(Q2EFF.GT.PMB**2) NFQ=5
39622 C...Find s as sum of 3-, 4- and 5-flavour parts.
39626 IF(NFQ.EQ.3) Q2DIV=Q2EFF
39627 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
39629 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
39631 IF(NFP.EQ.3) P2DIV=PMC**2
39633 IF(NFQ.EQ.5) Q2DIV=PMB**2
39634 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
39638 IF(NFP.EQ.5) P2DIV=P2EFF
39639 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
39642 C...Calculate frequent combinations of x and s.
39649 C...Evaluate homogeneous anomalous parton distributions below or
39650 C...above threshold.
39652 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39653 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39654 XVAL = X * 1.5D0 * (X**2+X1**2)
39658 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
39659 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
39660 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
39661 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
39662 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
39663 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
39664 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
39665 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
39666 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
39667 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
39668 & (2D0*X-1D0)*X*XL**2)
39671 C...Evaluate set 1D parton distributions below or above threshold.
39672 ELSEIF(ISET.EQ.1) THEN
39673 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39674 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39675 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
39676 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
39677 XSEA = 0.100D0 * X1**3.76D0
39679 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
39680 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
39681 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
39682 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
39683 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
39684 & X**0.40D0 * X1**(1.76D0+3D0*S)
39685 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
39686 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
39687 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
39688 XSEA0 = 0.100D0 * X1**3.76D0
39691 C...Evaluate set 1M parton distributions below or above threshold.
39692 ELSEIF(ISET.EQ.2) THEN
39693 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39694 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39695 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
39696 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
39699 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
39700 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
39701 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
39702 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
39703 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
39704 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
39705 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
39706 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
39711 C...Evaluate set 2D parton distributions below or above threshold.
39712 ELSEIF(ISET.EQ.3) THEN
39713 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39714 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39715 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
39716 XGLU = 1.925D0 * X1**2
39717 XSEA = 0.242D0 * X1**4
39719 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
39720 & X**(0.46D0+0.25D0*S) *
39721 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
39722 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
39723 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
39724 & EXP(-18.67D0*S) *
39725 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
39726 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
39727 & XL**(9.3D0*S/(1D0+1.7D0*S))
39728 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
39729 & (1D0-0.607D0*S+21.95D0*S2) *
39730 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
39731 XSEA0 = 0.242D0 * X1**4
39734 C...Evaluate set 2M parton distributions below or above threshold.
39735 ELSEIF(ISET.EQ.4) THEN
39736 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39737 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39738 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
39739 XGLU = 1.808D0 * X1**2
39740 XSEA = 0.209D0 * X1**4
39742 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
39743 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
39744 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
39745 & XL**(5.15D0*S/(1D0+2D0*S)) +
39746 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
39747 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
39748 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
39749 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
39750 & XL**(10.9D0*S/(1D0+2.5D0*S))
39751 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
39752 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
39753 & X1**(4D0+S) * XL**(0.45D0*S)
39754 XSEA0 = 0.209D0 * X1**4
39758 C...Threshold factors for c and b sea.
39759 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39761 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39762 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39764 XCHM=XSEA*(1D0-(SCH/SLL)**2)
39766 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
39770 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39771 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39773 XBOT=XSEA*(1D0-(SBT/SLL)**2)
39775 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
39779 C...Fill parton distributions.
39786 XPGA(KFA)=XPGA(KFA)+XVAL
39788 XPGA(-KFL)=XPGA(KFL)
39796 C*********************************************************************
39799 C...Evaluates the parton distributions of the anomalous photon,
39800 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
39801 C...KF=0 gives the sum over (up to) 5 flavours,
39802 C...KF<0 limits to flavours up to abs(KF),
39803 C...KF>0 is for flavour KF only.
39804 C...ALAM is the 4-flavour Lambda, which is automatically converted
39805 C...to 3- and 5-flavour equivalents as needed.
39806 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39808 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39810 C...Double precision and integer declarations.
39811 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39812 IMPLICIT INTEGER(I-N)
39813 INTEGER PYK,PYCHGE,PYCOMP
39814 C...Local arrays and data.
39815 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
39816 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
39823 IF(Q2.LE.P2) RETURN
39826 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39827 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
39829 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
39830 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
39831 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
39832 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
39833 Q2EFF=MAX(Q2,P2EFF)
39836 C...Find number of flavours at lower and upper scale.
39838 IF(P2EFF.LT.PMC**2) NFP=3
39839 IF(P2EFF.GT.PMB**2) NFP=5
39841 IF(Q2EFF.LT.PMC**2) NFQ=3
39842 IF(Q2EFF.GT.PMB**2) NFQ=5
39844 C...Define range of flavour loop.
39848 ELSEIF(KF.LT.0) THEN
39856 C...Loop over flavours the photon can branch into.
39857 DO 110 KFL=KFLMN,KFLMX
39859 C...Light flavours: calculate t range and (approximate) s range.
39860 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
39861 TDIFF=LOG(Q2EFF/P2EFF)
39862 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39863 & LOG(P2EFF/ALAMSQ(NFQ)))
39864 IF(NFQ.GT.NFP) THEN
39866 IF(NFQ.EQ.4) Q2DIV=PMC**2
39867 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
39868 & LOG(P2EFF/ALAMSQ(NFQ)))
39869 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
39870 & LOG(P2EFF/ALAMSQ(NFQ-1)))
39871 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
39873 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
39875 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
39876 & LOG(P2EFF/ALAMSQ(4)))
39877 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
39878 & LOG(P2EFF/ALAMSQ(3)))
39879 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
39882 C...u and s quark do not need a separate treatment when d has been done.
39883 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
39885 C...Charm: as above, but only include range above c threshold.
39886 ELSEIF(KFL.EQ.4) THEN
39887 IF(Q2.LE.PMC**2) GOTO 110
39888 P2EFF=MAX(P2EFF,PMC**2)
39889 Q2EFF=MAX(Q2EFF,P2EFF)
39890 TDIFF=LOG(Q2EFF/P2EFF)
39891 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39892 & LOG(P2EFF/ALAMSQ(NFQ)))
39893 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
39895 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
39896 & LOG(P2EFF/ALAMSQ(NFQ)))
39897 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
39898 & LOG(P2EFF/ALAMSQ(NFQ-1)))
39899 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
39902 C...Bottom: as above, but only include range above b threshold.
39903 ELSEIF(KFL.EQ.5) THEN
39904 IF(Q2.LE.PMB**2) GOTO 110
39905 P2EFF=MAX(P2EFF,PMB**2)
39906 Q2EFF=MAX(Q2,P2EFF)
39907 TDIFF=LOG(Q2EFF/P2EFF)
39908 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39909 & LOG(P2EFF/ALAMSQ(NFQ)))
39912 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
39914 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
39915 FAC=AEM2PI*2D0*CHSQ*TDIFF
39917 C...Evaluate parton distributions (normalized to unit momentum sum).
39918 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
39919 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
39920 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
39921 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
39922 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
39923 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
39924 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
39925 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
39926 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
39927 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
39928 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
39929 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
39931 C...Threshold factors for c and b sea.
39932 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39934 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39935 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39936 XCHM=XSEA*(1D0-(SCH/SLL)**3)
39939 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39940 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39941 XBOT=XSEA*(1D0-(SBT/SLL)**3)
39945 C...Add contribution of each valence flavour.
39946 XPGA(0)=XPGA(0)+FAC*XGLU
39947 XPGA(1)=XPGA(1)+FAC*XSEA
39948 XPGA(2)=XPGA(2)+FAC*XSEA
39949 XPGA(3)=XPGA(3)+FAC*XSEA
39950 XPGA(4)=XPGA(4)+FAC*XCHM
39951 XPGA(5)=XPGA(5)+FAC*XBOT
39952 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
39953 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
39956 XPGA(-KFL)=XPGA(KFL)
39957 VXPGA(-KFL)=VXPGA(KFL)
39964 C*********************************************************************
39967 C...Evaluates the Bethe-Heitler cross section for heavy flavour
39969 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39971 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
39973 C...Double precision and integer declarations.
39974 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39975 IMPLICIT INTEGER(I-N)
39976 INTEGER PYK,PYCHGE,PYCOMP
39979 DATA AEM2PI/0.0011614D0/
39985 C...Check kinematics limits.
39986 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
39988 BETA2=1D0-4D0*PM2/W2
39989 IF(BETA2.LT.1D-10) RETURN
39993 C...Simple case: P2 = 0.
39994 IF(P2.LT.1D-4) THEN
39995 IF(BETA.LT.0.99D0) THEN
39996 XBL=LOG((1D0+BETA)/(1D0-BETA))
39998 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
40000 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
40001 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
40003 C...Complicated case: P2 > 0, based on approximation of
40004 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
40006 RPQ=1D0-4D0*X**2*P2/Q2
40007 IF(RPQ.GT.1D-10) THEN
40008 RPBE=SQRT(RPQ*BETA2)
40009 IF(RPBE.LT.0.99D0) THEN
40010 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
40011 XBI=2D0*RPBE/(1D0-RPBE**2)
40013 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
40014 XBL=LOG((1D0+RPBE)**2/RPBESN)
40015 XBI=2D0*RPBE/RPBESN
40017 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
40018 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
40019 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
40023 C...Multiply by charge-squared etc. to get parton distribution.
40025 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
40026 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
40031 C*********************************************************************
40034 C...Evaluates the direct contribution, i.e. the C^gamma term,
40035 C...as needed in MSbar parametrizations.
40036 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40038 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
40040 C...Double precision and integer declarations.
40041 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40042 IMPLICIT INTEGER(I-N)
40043 INTEGER PYK,PYCHGE,PYCOMP
40044 C...Local array and data.
40045 DIMENSION XPGA(-6:6)
40046 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
40053 C...Evaluate common x-dependent expression.
40054 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
40055 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
40057 C...d, u, s part by simple charge factor.
40058 XPGA(1)=(1D0/9D0)*CGAM
40059 XPGA(2)=(4D0/9D0)*CGAM
40060 XPGA(3)=(1D0/9D0)*CGAM
40062 C...Also fill for antiquarks.
40070 C*********************************************************************
40073 C...Gives pi+ parton distribution according to two different
40074 C...parametrizations.
40076 SUBROUTINE PYPDPI(X,Q2,XPPI)
40078 C...Double precision and integer declarations.
40079 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40080 IMPLICIT INTEGER(I-N)
40081 INTEGER PYK,PYCHGE,PYCOMP
40083 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40084 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40085 COMMON/PYINT1/MINT(400),VINT(400)
40086 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40088 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
40090 C...The following data lines are coefficients needed in the
40091 C...Owens pion parton distribution parametrizations, see below.
40092 C...Expansion coefficients for up and down valence quark distributions.
40093 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
40094 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40095 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40096 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40097 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
40098 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40099 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40100 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40101 C...Expansion coefficients for gluon distribution.
40102 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
40103 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
40104 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
40105 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
40106 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
40107 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
40108 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
40109 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
40110 C...Expansion coefficients for (up+down+strange) quark sea distribution.
40111 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
40112 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40113 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
40114 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
40115 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
40116 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40117 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
40118 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
40119 C...Expansion coefficients for charm quark sea distribution.
40120 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
40121 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
40122 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
40123 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
40124 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
40125 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
40126 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
40127 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
40129 C...Euler's beta function, requires ordinary Gamma function
40130 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
40132 C...Reset output array.
40137 IF(MSTP(53).LE.2) THEN
40138 C...Pion parton distributions from Owens.
40139 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
40141 C...Determine set, Lambda and s expansion variable.
40143 IF(NSET.EQ.1) ALAM=0.2D0
40144 IF(NSET.EQ.2) ALAM=0.4D0
40146 IF(MSTP(57).LE.0) THEN
40149 Q2IN=MIN(2D3,MAX(4D0,Q2))
40150 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
40153 C...Calculate parton distributions.
40156 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
40157 & COW(3,IS,KFL,NSET)*SD**2
40160 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
40162 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
40167 C...Put into output array.
40170 XPPI(2)=XQ(1)+XQ(3)/6D0
40173 XPPI(-1)=XQ(1)+XQ(3)/6D0
40178 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
40179 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40183 C...Determine s expansion variable and some x expressions.
40185 IF(MSTP(57).LE.0) THEN
40188 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
40189 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
40195 C...Evaluate valence, gluon and sea distributions.
40196 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
40197 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
40198 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
40200 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
40201 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
40203 & (1D0-X)**(0.390D0+1.053D0*SD)
40204 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
40206 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
40208 & XL**(2.538D0-0.763D0*SD)
40209 IF(SD.LE.0.888D0) THEN
40212 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
40214 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
40217 IF(SD.LE.1.351D0) THEN
40220 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
40221 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
40225 C...Put into output array.
40233 XPPI(-KFL)=XPPI(KFL)
40235 XPPI(2)=XPPI(2)+XFVAL
40236 XPPI(-1)=XPPI(-1)+XFVAL
40242 C*********************************************************************
40245 C...Gives proton parton distributions according to a few different
40246 C...parametrizations.
40248 SUBROUTINE PYPDPR(X,Q2,XPPR)
40250 C...Double precision and integer declarations.
40251 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40252 IMPLICIT INTEGER(I-N)
40253 INTEGER PYK,PYCHGE,PYCOMP
40255 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40256 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40257 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40258 COMMON/PYINT1/MINT(400),VINT(400)
40259 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
40260 C...Arrays and data.
40261 DIMENSION XPPR(-6:6),Q2MIN(16)
40262 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
40263 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
40265 C...Reset output array.
40270 C...Common preliminaries.
40271 NSET=MAX(1,MIN(16,MSTP(51)))
40272 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
40273 VINT(231)=Q2MIN(NSET)
40274 IF(MSTP(57).EQ.0) THEN
40277 Q2L=MAX(Q2MIN(NSET),Q2)
40280 IF(NSET.GE.1.AND.NSET.LE.3) THEN
40281 C...Interface to the CTEQ 3 parton distributions.
40282 QRT=SQRT(MAX(1D0,Q2L))
40284 C...Loop over flavours.
40287 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
40288 ELSEIF(I.LE.2) THEN
40289 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
40295 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
40296 C...Interface to the GRV 94 distributions.
40298 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40299 ELSEIF(NSET.EQ.5) THEN
40300 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40302 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40305 C...Put into output array.
40307 XPPR(-1)=0.5D0*(UDB+DEL)
40308 XPPR(-2)=0.5D0*(UDB-DEL)
40312 XPPR(1)=DV+XPPR(-1)
40313 XPPR(2)=UV+XPPR(-2)
40318 ELSEIF(NSET.EQ.7) THEN
40319 C...Interface to the CTEQ 5L parton distributions.
40320 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
40321 C...freezing x*f(x,Q2) at borders.
40322 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
40323 XIN=MAX(1D-6,MIN(1D0,X))
40325 C...Loop over flavours (with u <-> d notation mismatch).
40326 SUMUDB=PYCT5L(-1,XIN,QRT)
40327 RATUDB=PYCT5L(-2,XIN,QRT)
40330 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
40331 ELSEIF(I.EQ.2) THEN
40332 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
40333 ELSEIF(I.EQ.-1) THEN
40334 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
40335 ELSEIF(I.EQ.-2) THEN
40336 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
40338 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
40339 IF(I.LT.0) XPPR(-I)=XPPR(I)
40343 ELSEIF(NSET.EQ.8) THEN
40344 C...Interface to the CTEQ 5M1 parton distributions.
40345 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
40346 XIN=MAX(1D-6,MIN(1D0,X))
40348 C...Loop over flavours (with u <-> d notation mismatch).
40349 SUMUDB=PYCT5M(-1,XIN,QRT)
40350 RATUDB=PYCT5M(-2,XIN,QRT)
40353 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
40354 ELSEIF(I.EQ.2) THEN
40355 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
40356 ELSEIF(I.EQ.-1) THEN
40357 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
40358 ELSEIF(I.EQ.-2) THEN
40359 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
40361 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
40362 IF(I.LT.0) XPPR(-I)=XPPR(I)
40366 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
40367 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
40368 C...obsolete but offers backwards compatibility.
40369 CALL PYPDPO(X,Q2L,XPPR)
40371 C...Symmetric choice for debugging only
40372 ELSEIF(NSET.EQ.16) THEN
40390 C*********************************************************************
40393 C...Gives the CTEQ 3 parton distribution function sets in
40394 C...parametrized form, of October 24, 1994.
40395 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
40396 C...J. Qiu, W.K. Tung and H. Weerts.
40398 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
40400 C...Double precision declaration.
40401 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40402 IMPLICIT INTEGER(I-N)
40404 C...Data on Lambda values of fits, minimum Q and quark masses.
40405 DIMENSION ALM(3), QMS(4:6)
40406 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
40407 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
40409 C....Check flavour thresholds. Set up QI for SB.
40412 IF(Q .LE. QMS(IP)) THEN
40421 C...Use "standard lambda" of parametrization program for expansion.
40423 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
40428 C...Expansion for CTEQ3L.
40429 IF(ISET .EQ. 1) THEN
40430 IF(IPRT .EQ. 2) THEN
40431 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
40433 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
40434 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
40435 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
40436 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
40437 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
40438 ELSEIF(IPRT .EQ. 1) THEN
40439 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
40441 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
40442 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
40443 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
40444 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
40445 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
40446 ELSEIF(IPRT .EQ. 0) THEN
40447 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
40449 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
40450 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
40451 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
40452 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
40453 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
40454 ELSEIF(IPRT .EQ. -1) THEN
40455 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
40457 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
40458 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
40459 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
40460 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
40461 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
40462 ELSEIF(IPRT .EQ. -2) THEN
40463 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
40465 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
40466 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
40467 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
40468 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
40469 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
40470 ELSEIF(IPRT .EQ. -3) THEN
40471 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
40473 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
40474 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
40475 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
40476 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
40477 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
40478 ELSEIF(IPRT .EQ. -4) THEN
40479 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
40481 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
40482 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
40483 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
40484 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
40485 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
40486 ELSEIF(IPRT .EQ. -5) THEN
40487 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
40489 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
40490 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
40491 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
40492 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
40493 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
40494 ELSEIF(IPRT .EQ. -6) THEN
40495 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
40497 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
40498 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
40499 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
40500 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
40501 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
40504 C...Expansion for CTEQ3M.
40505 ELSEIF(ISET .EQ. 2) THEN
40506 IF(IPRT .EQ. 2) THEN
40507 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
40509 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
40510 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
40511 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
40512 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
40513 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
40514 ELSEIF(IPRT .EQ. 1) THEN
40515 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
40517 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
40518 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
40519 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
40520 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
40521 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
40522 ELSEIF(IPRT .EQ. 0) THEN
40523 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
40525 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
40526 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
40527 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
40528 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
40529 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
40530 ELSEIF(IPRT .EQ. -1) THEN
40531 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
40533 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
40534 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
40535 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
40536 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
40537 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
40538 ELSEIF(IPRT .EQ. -2) THEN
40539 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
40541 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
40542 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
40543 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
40544 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
40545 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
40546 ELSEIF(IPRT .EQ. -3) THEN
40547 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
40549 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
40550 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
40551 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
40552 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
40553 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
40554 ELSEIF(IPRT .EQ. -4) THEN
40555 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
40557 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
40558 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
40559 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
40560 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
40561 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
40562 ELSEIF(IPRT .EQ. -5) THEN
40563 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
40565 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
40566 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
40567 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
40568 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
40569 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
40570 ELSEIF(IPRT .EQ. -6) THEN
40571 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
40573 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
40574 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
40575 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
40576 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
40577 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
40580 C...Expansion for CTEQ3D.
40581 ELSEIF(ISET .EQ. 3) THEN
40582 IF(IPRT .EQ. 2) THEN
40583 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
40585 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
40586 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
40587 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
40588 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
40589 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
40590 ELSEIF(IPRT .EQ. 1) THEN
40591 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
40593 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
40594 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
40595 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
40596 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
40597 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
40598 ELSEIF(IPRT .EQ. 0) THEN
40599 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
40601 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
40602 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
40603 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
40604 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
40605 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
40606 ELSEIF(IPRT .EQ. -1) THEN
40607 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
40609 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
40610 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
40611 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
40612 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
40613 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
40614 ELSEIF(IPRT .EQ. -2) THEN
40615 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
40617 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
40618 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
40619 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
40620 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
40621 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
40622 ELSEIF(IPRT .EQ. -3) THEN
40623 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
40625 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
40626 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
40627 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
40628 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
40629 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
40630 ELSEIF(IPRT .EQ. -4) THEN
40631 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
40633 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
40634 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
40635 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
40636 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
40637 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
40638 ELSEIF(IPRT .EQ. -5) THEN
40639 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
40641 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
40642 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
40643 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
40644 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
40645 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
40646 ELSEIF(IPRT .EQ. -6) THEN
40647 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
40649 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
40650 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
40651 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
40652 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
40653 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
40657 C...Calculation of x * f(x, Q).
40658 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
40659 & *(LOG(1D0+1D0/X))**A5 )
40664 C*********************************************************************
40667 C...Gives the GRV 94 L (leading order) parton distribution function set
40668 C...in parametrized form.
40669 C...Authors: M. Glueck, E. Reya and A. Vogt.
40671 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40673 C...Double precision declaration.
40674 IMPLICIT DOUBLE PRECISION (A - Z)
40676 C...Common expressions.
40678 LAM2 = 0.2322D0 * 0.2322D0
40679 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40685 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
40686 AKU = 0.590D0 - 0.024D0 * S
40687 BKU = 0.131D0 + 0.063D0 * S
40688 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
40689 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
40690 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
40691 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
40692 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40695 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
40697 BKD = 0.486D0 + 0.062D0 * S
40698 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
40699 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
40700 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
40701 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
40702 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40705 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
40706 AKE = 0.409D0 - 0.005D0 * S
40707 BKE = 0.799D0 + 0.071D0 * S
40708 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
40709 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
40711 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
40712 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40717 AKX = 0.410D0 - 0.232D0 * S
40718 BKX = 0.534D0 - 0.457D0 * S
40719 AGX = 0.890D0 - 0.140D0 * S
40721 CX = 0.320D0 + 0.683D0 * S
40722 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
40723 EX = 4.119D0 + 1.713D0 * S
40724 ESX = 0.682D0 + 2.978D0 * S
40725 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40732 AKS = 1.798D0 - 0.596D0 * S
40733 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
40734 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
40735 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
40736 EST = 3.981D0 + 1.638D0 * S
40738 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40746 BC = 4.24D0 - 0.804D0 * S
40747 DCT = 3.46D0 - 1.076D0 * S
40748 ECT = 4.61D0 + 1.49D0 * S
40749 ESC = 2.555D0 + 1.961D0 * S
40750 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40759 DBT = 2.929D0 + 1.396D0 * S
40760 EBT = 4.71D0 + 1.514D0 * S
40761 ESB = 4.02D0 + 1.239D0 * S
40762 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40767 AKG = 1.742D0 - 0.930D0 * S
40768 BKG = - 0.399D0 * S2
40769 AG = 7.486D0 - 2.185D0 * S
40770 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
40771 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
40772 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
40773 EG = 0.807D0 + 2.005D0 * S
40774 ESG = 3.841D0 + 0.316D0 * S
40775 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
40781 C*********************************************************************
40784 C...Gives the GRV 94 M (MSbar) parton distribution function set
40785 C...in parametrized form.
40786 C...Authors: M. Glueck, E. Reya and A. Vogt.
40788 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40790 C...Double precision declaration.
40791 IMPLICIT DOUBLE PRECISION (A - Z)
40793 C...Common expressions.
40795 LAM2 = 0.248D0 * 0.248D0
40796 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40802 NU = 1.304D0 + 0.863D0 * S
40803 AKU = 0.558D0 - 0.020D0 * S
40805 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
40806 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
40807 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
40808 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
40809 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40812 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
40813 AKD = 0.270D0 - 0.019D0 * S
40815 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
40816 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
40817 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
40818 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
40819 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40822 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
40823 AKE = 0.409D0 - 0.007D0 * S
40824 BKE = 0.782D0 + 0.082D0 * S
40825 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
40826 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
40828 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
40829 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40837 BGX = 3.210D0 - 1.866D0 * S
40839 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
40840 EX = 3.077D0 + 1.446D0 * S
40841 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
40842 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40849 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
40850 AS = -4.329D0 + 1.131D0 * S
40851 BS = 9.568D0 - 1.744D0 * S
40852 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
40853 EST = 3.031D0 + 1.639D0 * S
40854 ESS = 5.837D0 + 0.815D0 * S
40855 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40861 AKC = -0.625D0 - 0.523D0 * S
40863 BC = 1.896D0 + 1.616D0 * S
40864 DCT = 4.12D0 + 0.683D0 * S
40865 ECT = 4.36D0 + 1.328D0 * S
40866 ESC = 0.677D0 + 0.679D0 * S
40867 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40873 AKB = - 0.193D0 * S
40876 DBT = 3.447D0 + 0.927D0 * S
40877 EBT = 4.68D0 + 1.259D0 * S
40878 ESB = 1.892D0 + 2.199D0 * S
40879 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40884 AKG = 1.724D0 + 0.157D0 * S
40885 BKG = 0.800D0 + 1.016D0 * S
40886 AG = 7.517D0 - 2.547D0 * S
40887 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
40888 CG = 4.039D0 + 1.491D0 * S
40889 DG = 3.404D0 + 0.830D0 * S
40890 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
40891 ESG = 3.256D0 - 0.436D0 * S
40892 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
40897 C*********************************************************************
40900 C...Gives the GRV 94 D (DIS) parton distribution function set
40901 C...in parametrized form.
40902 C...Authors: M. Glueck, E. Reya and A. Vogt.
40904 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40906 C...Double precision declaration.
40907 IMPLICIT DOUBLE PRECISION (A - Z)
40909 C...Common expressions.
40911 LAM2 = 0.248D0 * 0.248D0
40912 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40918 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
40919 AKU = 0.563D0 - 0.025D0 * S
40920 BKU = 0.054D0 + 0.154D0 * S
40921 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
40922 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
40923 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
40924 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
40925 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40928 ND = 0.156D0 - 0.017D0 * S
40929 AKD = 0.299D0 - 0.022D0 * S
40930 BKD = 0.259D0 - 0.015D0 * S
40931 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
40932 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
40933 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
40934 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
40935 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40938 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
40939 AKE = 0.419D0 - 0.013D0 * S
40940 BKE = 1.064D0 - 0.038D0 * S
40941 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
40942 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
40943 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
40944 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
40945 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40950 AKX = 0.326D0 + 0.150D0 * S
40951 BKX = 0.956D0 + 0.405D0 * S
40953 BGX = 3.794D0 - 2.359D0 * DS
40955 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
40956 EX = 3.049D0 + 1.597D0 * S
40957 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
40958 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40965 AKS = 1.415D0 - 0.641D0 * DS
40966 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
40967 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
40968 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
40969 EST = 4.546D0 + 0.372D0 * S2
40970 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
40971 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40977 AKC = -0.625D0 - 0.523D0 * S
40979 BC = 1.896D0 + 1.616D0 * S
40980 DCT = 4.12D0 + 0.683D0 * S
40981 ECT = 4.36D0 + 1.328D0 * S
40982 ESC = 0.677D0 + 0.679D0 * S
40983 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40989 AKB = - 0.193D0 * S
40992 DBT = 3.447D0 + 0.927D0 * S
40993 EBT = 4.68D0 + 1.259D0 * S
40994 ESB = 1.892D0 + 2.199D0 * S
40995 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
41001 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
41002 AG = 25.09D0 - 7.935D0 * S
41003 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
41004 CG = 590.3D0 - 173.8D0 * S
41005 DG = 5.196D0 + 1.857D0 * S
41006 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
41007 ESG = 3.232D0 - 0.542D0 * S
41008 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
41013 C*********************************************************************
41016 C...Auxiliary for the GRV 94 parton distribution functions
41017 C...for u and d valence and d-u sea.
41018 C...Authors: M. Glueck, E. Reya and A. Vogt.
41020 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
41022 C...Double precision declaration.
41023 IMPLICIT DOUBLE PRECISION (A - Z)
41027 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
41033 C*********************************************************************
41036 C...Auxiliary for the GRV 94 parton distribution functions
41037 C...for d+u sea and gluon.
41038 C...Authors: M. Glueck, E. Reya and A. Vogt.
41040 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
41042 C...Double precision declaration.
41043 IMPLICIT DOUBLE PRECISION (A - Z)
41047 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
41048 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
41053 C*********************************************************************
41056 C...Auxiliary for the GRV 94 parton distribution functions
41057 C...for s, c and b sea.
41058 C...Authors: M. Glueck, E. Reya and A. Vogt.
41060 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
41062 C...Double precision declaration.
41063 IMPLICIT DOUBLE PRECISION (A - Z)
41071 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
41072 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
41078 C*********************************************************************
41081 C...Auxiliary function for parametrization of CTEQ5L.
41082 C...Author: J. Pumplin 9/99.
41084 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
41085 C...in Parametrized Form
41086 C... September 15, 1999
41088 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
41089 C... CTEQ5 PPARTON DISTRIBUTIONS"
41092 C...The CTEQ5M1 set given here is an updated version of the original
41093 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
41094 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
41095 C...almost all applications.
41096 C...The improvement is in the QCD evolution which is now more
41097 C...accurate, and which agrees completely with the benchmark work
41098 C...of the HERA 96/97 Workshop.
41099 C...The differences between the parametrized and the corresponding
41100 C...table versions (on which it is based) are of similar order as
41101 C...between the two version.
41103 C...!! Because accurate parametrizations over a wide range of (x,Q)
41104 C...is hard to obtain, only the most widely used sets CTEQ5M and
41105 C...CTEQ5L are available in parametrized form for now.
41107 C...These parametrizations were obtained by Jon Pumplin.
41109 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
41110 C -------------------------------------------------------------------
41111 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
41112 C 3 CTEQ5L Leading Order 0.127 192 146
41113 C -------------------------------------------------------------------
41114 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
41115 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
41118 C...The two Iset value are adopted to agree with the standard table
41121 C...Range of validity:
41122 C...The range of (x, Q) covered by this parametrization of the QCD
41123 C...evolved parton distributions is 1E-6 < x < 1 ;
41124 C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
41125 C...data only in a subset of that region; and the assumed DGLAP
41126 C...evolution is unlikely to be valid for all of it either.
41128 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
41129 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
41130 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
41131 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
41133 FUNCTION PYCT5L(IFL,X,Q)
41135 C...Double precision declaration.
41136 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41137 IMPLICIT INTEGER(I-N)
41139 PARAMETER (NEX=8, NLF=2)
41140 DIMENSION AM(0:NEX,0:NLF,-5:2)
41141 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41142 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41143 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41144 DIMENSION AF(0:NEX)
41146 DATA MEXVEC( 2) / 8 /
41147 DATA MLFVEC( 2) / 2 /
41148 DATA UT1VEC( 2) / 0.4971265E+01 /
41149 DATA UT2VEC( 2) / -0.1105128E+01 /
41150 DATA ALFVEC( 2) / 0.2987216E+00 /
41151 DATA QMAVEC( 2) / 0.0000000E+00 /
41152 DATA (AM( 0,K, 2),K=0, 2)
41153 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
41154 DATA (AM( 1,K, 2),K=0, 2)
41155 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
41156 DATA (AM( 2,K, 2),K=0, 2)
41157 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
41158 DATA (AM( 3,K, 2),K=0, 2)
41159 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
41160 DATA (AM( 4,K, 2),K=0, 2)
41161 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
41162 DATA (AM( 5,K, 2),K=0, 2)
41163 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
41164 DATA (AM( 6,K, 2),K=0, 2)
41165 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
41166 DATA (AM( 7,K, 2),K=0, 2)
41167 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
41168 DATA (AM( 8,K, 2),K=0, 2)
41169 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
41171 DATA MEXVEC( 1) / 8 /
41172 DATA MLFVEC( 1) / 2 /
41173 DATA UT1VEC( 1) / 0.2612618E+01 /
41174 DATA UT2VEC( 1) / -0.1258304E+06 /
41175 DATA ALFVEC( 1) / 0.3407552E+00 /
41176 DATA QMAVEC( 1) / 0.0000000E+00 /
41177 DATA (AM( 0,K, 1),K=0, 2)
41178 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
41179 DATA (AM( 1,K, 1),K=0, 2)
41180 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
41181 DATA (AM( 2,K, 1),K=0, 2)
41182 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
41183 DATA (AM( 3,K, 1),K=0, 2)
41184 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
41185 DATA (AM( 4,K, 1),K=0, 2)
41186 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
41187 DATA (AM( 5,K, 1),K=0, 2)
41188 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
41189 DATA (AM( 6,K, 1),K=0, 2)
41190 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
41191 DATA (AM( 7,K, 1),K=0, 2)
41192 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
41193 DATA (AM( 8,K, 1),K=0, 2)
41194 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
41196 DATA MEXVEC( 0) / 8 /
41197 DATA MLFVEC( 0) / 2 /
41198 DATA UT1VEC( 0) / -0.4656819E+00 /
41199 DATA UT2VEC( 0) / -0.2742390E+03 /
41200 DATA ALFVEC( 0) / 0.4491863E+00 /
41201 DATA QMAVEC( 0) / 0.0000000E+00 /
41202 DATA (AM( 0,K, 0),K=0, 2)
41203 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
41204 DATA (AM( 1,K, 0),K=0, 2)
41205 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
41206 DATA (AM( 2,K, 0),K=0, 2)
41207 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
41208 DATA (AM( 3,K, 0),K=0, 2)
41209 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
41210 DATA (AM( 4,K, 0),K=0, 2)
41211 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
41212 DATA (AM( 5,K, 0),K=0, 2)
41213 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
41214 DATA (AM( 6,K, 0),K=0, 2)
41215 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
41216 DATA (AM( 7,K, 0),K=0, 2)
41217 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
41218 DATA (AM( 8,K, 0),K=0, 2)
41219 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
41221 DATA MEXVEC(-1) / 8 /
41222 DATA MLFVEC(-1) / 2 /
41223 DATA UT1VEC(-1) / 0.3862583E+01 /
41224 DATA UT2VEC(-1) / -0.1265969E+01 /
41225 DATA ALFVEC(-1) / 0.2457668E+00 /
41226 DATA QMAVEC(-1) / 0.0000000E+00 /
41227 DATA (AM( 0,K,-1),K=0, 2)
41228 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
41229 DATA (AM( 1,K,-1),K=0, 2)
41230 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
41231 DATA (AM( 2,K,-1),K=0, 2)
41232 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
41233 DATA (AM( 3,K,-1),K=0, 2)
41234 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
41235 DATA (AM( 4,K,-1),K=0, 2)
41236 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
41237 DATA (AM( 5,K,-1),K=0, 2)
41238 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
41239 DATA (AM( 6,K,-1),K=0, 2)
41240 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
41241 DATA (AM( 7,K,-1),K=0, 2)
41242 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
41243 DATA (AM( 8,K,-1),K=0, 2)
41244 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
41246 DATA MEXVEC(-2) / 7 /
41247 DATA MLFVEC(-2) / 2 /
41248 DATA UT1VEC(-2) / 0.1895615E+00 /
41249 DATA UT2VEC(-2) / -0.3069097E+01 /
41250 DATA ALFVEC(-2) / 0.5293999E+00 /
41251 DATA QMAVEC(-2) / 0.0000000E+00 /
41252 DATA (AM( 0,K,-2),K=0, 2)
41253 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
41254 DATA (AM( 1,K,-2),K=0, 2)
41255 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
41256 DATA (AM( 2,K,-2),K=0, 2)
41257 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
41258 DATA (AM( 3,K,-2),K=0, 2)
41259 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
41260 DATA (AM( 4,K,-2),K=0, 2)
41261 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
41262 DATA (AM( 5,K,-2),K=0, 2)
41263 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
41264 DATA (AM( 6,K,-2),K=0, 2)
41265 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
41266 DATA (AM( 7,K,-2),K=0, 2)
41267 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
41269 DATA MEXVEC(-3) / 7 /
41270 DATA MLFVEC(-3) / 2 /
41271 DATA UT1VEC(-3) / 0.3753257E+01 /
41272 DATA UT2VEC(-3) / -0.1113085E+01 /
41273 DATA ALFVEC(-3) / 0.3713141E+00 /
41274 DATA QMAVEC(-3) / 0.0000000E+00 /
41275 DATA (AM( 0,K,-3),K=0, 2)
41276 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
41277 DATA (AM( 1,K,-3),K=0, 2)
41278 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
41279 DATA (AM( 2,K,-3),K=0, 2)
41280 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
41281 DATA (AM( 3,K,-3),K=0, 2)
41282 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
41283 DATA (AM( 4,K,-3),K=0, 2)
41284 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
41285 DATA (AM( 5,K,-3),K=0, 2)
41286 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
41287 DATA (AM( 6,K,-3),K=0, 2)
41288 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
41289 DATA (AM( 7,K,-3),K=0, 2)
41290 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
41292 DATA MEXVEC(-4) / 7 /
41293 DATA MLFVEC(-4) / 2 /
41294 DATA UT1VEC(-4) / 0.4400772E+01 /
41295 DATA UT2VEC(-4) / -0.1356116E+01 /
41296 DATA ALFVEC(-4) / 0.3712017E-01 /
41297 DATA QMAVEC(-4) / 0.1300000E+01 /
41298 DATA (AM( 0,K,-4),K=0, 2)
41299 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
41300 DATA (AM( 1,K,-4),K=0, 2)
41301 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
41302 DATA (AM( 2,K,-4),K=0, 2)
41303 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
41304 DATA (AM( 3,K,-4),K=0, 2)
41305 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
41306 DATA (AM( 4,K,-4),K=0, 2)
41307 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
41308 DATA (AM( 5,K,-4),K=0, 2)
41309 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
41310 DATA (AM( 6,K,-4),K=0, 2)
41311 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
41312 DATA (AM( 7,K,-4),K=0, 2)
41313 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
41315 DATA MEXVEC(-5) / 6 /
41316 DATA MLFVEC(-5) / 2 /
41317 DATA UT1VEC(-5) / 0.5562568E+01 /
41318 DATA UT2VEC(-5) / -0.1801317E+01 /
41319 DATA ALFVEC(-5) / 0.4952010E-02 /
41320 DATA QMAVEC(-5) / 0.4500000E+01 /
41321 DATA (AM( 0,K,-5),K=0, 2)
41322 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
41323 DATA (AM( 1,K,-5),K=0, 2)
41324 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
41325 DATA (AM( 2,K,-5),K=0, 2)
41326 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
41327 DATA (AM( 3,K,-5),K=0, 2)
41328 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
41329 DATA (AM( 4,K,-5),K=0, 2)
41330 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
41331 DATA (AM( 5,K,-5),K=0, 2)
41332 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
41333 DATA (AM( 6,K,-5),K=0, 2)
41334 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
41336 IF(Q .LE. QMAVEC(IFL)) THEN
41341 IF(X .GE. 1.D0) THEN
41346 TMP = LOG(Q/ALFVEC(IFL))
41347 IF(TMP .LE. 0.D0) THEN
41359 DO 100 K = 0, MLFVEC(IFL)
41360 AF(I) = AF(I) + SBX*AM(I,K,IFL)
41366 U = LOG(X/0.00001D0)
41368 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
41369 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
41370 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
41371 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
41372 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
41374 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
41376 C...Include threshold factor.
41377 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
41382 C*********************************************************************
41385 C...Auxiliary function for parametrization of CTEQ5M1.
41386 C...Author: J. Pumplin 9/99.
41388 FUNCTION PYCT5M(IFL,X,Q)
41390 C...Double precision declaration.
41391 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41392 IMPLICIT INTEGER(I-N)
41394 PARAMETER (NEX=8, NLF=2)
41395 DIMENSION AM(0:NEX,0:NLF,-5:2)
41396 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41397 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41398 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41399 DIMENSION AF(0:NEX)
41401 DATA MEXVEC( 2) / 8 /
41402 DATA MLFVEC( 2) / 2 /
41403 DATA UT1VEC( 2) / 0.5141718E+01 /
41404 DATA UT2VEC( 2) / -0.1346944E+01 /
41405 DATA ALFVEC( 2) / 0.5260555E+00 /
41406 DATA QMAVEC( 2) / 0.0000000E+00 /
41407 DATA (AM( 0,K, 2),K=0, 2)
41408 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
41409 DATA (AM( 1,K, 2),K=0, 2)
41410 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
41411 DATA (AM( 2,K, 2),K=0, 2)
41412 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
41413 DATA (AM( 3,K, 2),K=0, 2)
41414 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
41415 DATA (AM( 4,K, 2),K=0, 2)
41416 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
41417 DATA (AM( 5,K, 2),K=0, 2)
41418 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
41419 DATA (AM( 6,K, 2),K=0, 2)
41420 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
41421 DATA (AM( 7,K, 2),K=0, 2)
41422 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
41423 DATA (AM( 8,K, 2),K=0, 2)
41424 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
41426 DATA MEXVEC( 1) / 8 /
41427 DATA MLFVEC( 1) / 2 /
41428 DATA UT1VEC( 1) / 0.4138426E+01 /
41429 DATA UT2VEC( 1) / -0.3221374E+01 /
41430 DATA ALFVEC( 1) / 0.4960962E+00 /
41431 DATA QMAVEC( 1) / 0.0000000E+00 /
41432 DATA (AM( 0,K, 1),K=0, 2)
41433 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
41434 DATA (AM( 1,K, 1),K=0, 2)
41435 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
41436 DATA (AM( 2,K, 1),K=0, 2)
41437 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
41438 DATA (AM( 3,K, 1),K=0, 2)
41439 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
41440 DATA (AM( 4,K, 1),K=0, 2)
41441 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
41442 DATA (AM( 5,K, 1),K=0, 2)
41443 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
41444 DATA (AM( 6,K, 1),K=0, 2)
41445 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
41446 DATA (AM( 7,K, 1),K=0, 2)
41447 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
41448 DATA (AM( 8,K, 1),K=0, 2)
41449 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
41451 DATA MEXVEC( 0) / 8 /
41452 DATA MLFVEC( 0) / 2 /
41453 DATA UT1VEC( 0) / -0.1026789E+01 /
41454 DATA UT2VEC( 0) / -0.9051707E+01 /
41455 DATA ALFVEC( 0) / 0.9462977E+00 /
41456 DATA QMAVEC( 0) / 0.0000000E+00 /
41457 DATA (AM( 0,K, 0),K=0, 2)
41458 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
41459 DATA (AM( 1,K, 0),K=0, 2)
41460 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
41461 DATA (AM( 2,K, 0),K=0, 2)
41462 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
41463 DATA (AM( 3,K, 0),K=0, 2)
41464 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
41465 DATA (AM( 4,K, 0),K=0, 2)
41466 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
41467 DATA (AM( 5,K, 0),K=0, 2)
41468 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
41469 DATA (AM( 6,K, 0),K=0, 2)
41470 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
41471 DATA (AM( 7,K, 0),K=0, 2)
41472 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
41473 DATA (AM( 8,K, 0),K=0, 2)
41474 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
41476 DATA MEXVEC(-1) / 8 /
41477 DATA MLFVEC(-1) / 2 /
41478 DATA UT1VEC(-1) / 0.5243571E+01 /
41479 DATA UT2VEC(-1) / -0.2870513E+01 /
41480 DATA ALFVEC(-1) / 0.6701448E+00 /
41481 DATA QMAVEC(-1) / 0.0000000E+00 /
41482 DATA (AM( 0,K,-1),K=0, 2)
41483 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
41484 DATA (AM( 1,K,-1),K=0, 2)
41485 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
41486 DATA (AM( 2,K,-1),K=0, 2)
41487 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
41488 DATA (AM( 3,K,-1),K=0, 2)
41489 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
41490 DATA (AM( 4,K,-1),K=0, 2)
41491 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
41492 DATA (AM( 5,K,-1),K=0, 2)
41493 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
41494 DATA (AM( 6,K,-1),K=0, 2)
41495 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
41496 DATA (AM( 7,K,-1),K=0, 2)
41497 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
41498 DATA (AM( 8,K,-1),K=0, 2)
41499 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
41501 DATA MEXVEC(-2) / 7 /
41502 DATA MLFVEC(-2) / 2 /
41503 DATA UT1VEC(-2) / 0.4782210E+01 /
41504 DATA UT2VEC(-2) / -0.1976856E+02 /
41505 DATA ALFVEC(-2) / 0.7558374E+00 /
41506 DATA QMAVEC(-2) / 0.0000000E+00 /
41507 DATA (AM( 0,K,-2),K=0, 2)
41508 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
41509 DATA (AM( 1,K,-2),K=0, 2)
41510 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
41511 DATA (AM( 2,K,-2),K=0, 2)
41512 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
41513 DATA (AM( 3,K,-2),K=0, 2)
41514 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
41515 DATA (AM( 4,K,-2),K=0, 2)
41516 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
41517 DATA (AM( 5,K,-2),K=0, 2)
41518 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
41519 DATA (AM( 6,K,-2),K=0, 2)
41520 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
41521 DATA (AM( 7,K,-2),K=0, 2)
41522 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
41524 DATA MEXVEC(-3) / 7 /
41525 DATA MLFVEC(-3) / 2 /
41526 DATA UT1VEC(-3) / 0.4518239E+01 /
41527 DATA UT2VEC(-3) / -0.2690590E+01 /
41528 DATA ALFVEC(-3) / 0.6124079E+00 /
41529 DATA QMAVEC(-3) / 0.0000000E+00 /
41530 DATA (AM( 0,K,-3),K=0, 2)
41531 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
41532 DATA (AM( 1,K,-3),K=0, 2)
41533 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
41534 DATA (AM( 2,K,-3),K=0, 2)
41535 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
41536 DATA (AM( 3,K,-3),K=0, 2)
41537 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
41538 DATA (AM( 4,K,-3),K=0, 2)
41539 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
41540 DATA (AM( 5,K,-3),K=0, 2)
41541 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
41542 DATA (AM( 6,K,-3),K=0, 2)
41543 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
41544 DATA (AM( 7,K,-3),K=0, 2)
41545 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
41547 DATA MEXVEC(-4) / 7 /
41548 DATA MLFVEC(-4) / 2 /
41549 DATA UT1VEC(-4) / 0.2783230E+01 /
41550 DATA UT2VEC(-4) / -0.1746328E+01 /
41551 DATA ALFVEC(-4) / 0.1115653E+01 /
41552 DATA QMAVEC(-4) / 0.1300000E+01 /
41553 DATA (AM( 0,K,-4),K=0, 2)
41554 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
41555 DATA (AM( 1,K,-4),K=0, 2)
41556 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
41557 DATA (AM( 2,K,-4),K=0, 2)
41558 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
41559 DATA (AM( 3,K,-4),K=0, 2)
41560 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
41561 DATA (AM( 4,K,-4),K=0, 2)
41562 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
41563 DATA (AM( 5,K,-4),K=0, 2)
41564 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
41565 DATA (AM( 6,K,-4),K=0, 2)
41566 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
41567 DATA (AM( 7,K,-4),K=0, 2)
41568 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
41570 DATA MEXVEC(-5) / 6 /
41571 DATA MLFVEC(-5) / 2 /
41572 DATA UT1VEC(-5) / 0.1619654E+02 /
41573 DATA UT2VEC(-5) / -0.3367346E+01 /
41574 DATA ALFVEC(-5) / 0.5109891E-02 /
41575 DATA QMAVEC(-5) / 0.4500000E+01 /
41576 DATA (AM( 0,K,-5),K=0, 2)
41577 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
41578 DATA (AM( 1,K,-5),K=0, 2)
41579 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
41580 DATA (AM( 2,K,-5),K=0, 2)
41581 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
41582 DATA (AM( 3,K,-5),K=0, 2)
41583 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
41584 DATA (AM( 4,K,-5),K=0, 2)
41585 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
41586 DATA (AM( 5,K,-5),K=0, 2)
41587 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
41588 DATA (AM( 6,K,-5),K=0, 2)
41589 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
41591 IF(Q .LE. QMAVEC(IFL)) THEN
41596 IF(X .GE. 1.D0) THEN
41601 TMP = LOG(Q/ALFVEC(IFL))
41602 IF(TMP .LE. 0.D0) THEN
41614 DO 100 K = 0, MLFVEC(IFL)
41615 AF(I) = AF(I) + SBX*AM(I,K,IFL)
41621 U = LOG(X/0.00001D0)
41623 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
41624 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
41625 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
41626 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
41627 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
41629 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
41631 C...Include threshold factor.
41632 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
41637 C*********************************************************************
41640 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
41641 C...a few older parametrizations, now obsolete but convenient for
41642 C...backwards checks.
41644 SUBROUTINE PYPDPO(X,Q2,XPPR)
41646 C...Double precision and integer declarations.
41647 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41648 IMPLICIT INTEGER(I-N)
41649 INTEGER PYK,PYCHGE,PYCOMP
41651 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41652 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41653 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41654 COMMON/PYINT1/MINT(400),VINT(400)
41655 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
41656 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
41657 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
41660 C...The following data lines are coefficients needed in the
41661 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
41662 C...parametrizations, see below.
41663 C...Powers of 1-x in different cases.
41664 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
41665 C...Expansion coefficients for up valence quark distribution.
41666 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
41667 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
41668 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
41669 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
41670 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
41671 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
41672 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
41673 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
41674 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
41675 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
41676 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
41677 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
41678 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
41679 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
41680 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
41681 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
41682 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
41683 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
41684 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
41685 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
41686 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
41687 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
41688 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
41689 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
41690 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
41691 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
41692 C...Expansion coefficients for down valence quark distribution.
41693 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
41694 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
41695 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
41696 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
41697 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
41698 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
41699 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
41700 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
41701 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
41702 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
41703 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
41704 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
41705 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
41706 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
41707 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
41708 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
41709 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
41710 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
41711 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
41712 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
41713 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
41714 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
41715 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
41716 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
41717 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
41718 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
41719 C...Expansion coefficients for up and down sea quark distributions.
41720 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
41721 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
41722 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
41723 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
41724 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
41725 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
41726 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
41727 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
41728 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
41729 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
41730 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
41731 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
41732 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
41733 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
41734 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
41735 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
41736 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
41737 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
41738 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
41739 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
41740 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
41741 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
41742 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
41743 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
41744 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
41745 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
41746 C...Expansion coefficients for gluon distribution.
41747 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
41748 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
41749 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
41750 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
41751 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
41752 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
41753 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
41754 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
41755 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
41756 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
41757 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
41758 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
41759 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
41760 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
41761 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
41762 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
41763 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
41764 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
41765 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
41766 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
41767 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
41768 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
41769 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
41770 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
41771 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
41772 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
41773 C...Expansion coefficients for strange sea quark distribution.
41774 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
41775 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
41776 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
41777 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
41778 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
41779 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
41780 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
41781 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
41782 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
41783 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
41784 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
41785 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
41786 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
41787 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
41788 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
41789 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
41790 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
41791 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
41792 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
41793 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
41794 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
41795 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
41796 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
41797 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
41798 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
41799 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
41800 C...Expansion coefficients for charm sea quark distribution.
41801 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
41802 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
41803 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
41804 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
41805 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
41806 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
41807 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
41808 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
41809 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
41810 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
41811 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
41812 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
41813 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
41814 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
41815 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
41816 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
41817 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
41818 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
41819 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
41820 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
41821 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
41822 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
41823 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
41824 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
41825 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
41826 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
41827 C...Expansion coefficients for bottom sea quark distribution.
41828 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
41829 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
41830 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
41831 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
41832 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
41833 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
41834 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
41835 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
41836 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
41837 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
41838 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
41839 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
41840 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
41841 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
41842 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
41843 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
41844 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
41845 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
41846 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
41847 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
41848 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
41849 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
41850 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
41851 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
41852 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
41853 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
41854 C...Expansion coefficients for top sea quark distribution.
41855 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
41856 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
41857 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
41858 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
41859 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
41860 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
41861 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
41862 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
41863 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
41864 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
41865 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
41866 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
41867 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
41868 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
41869 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
41870 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
41871 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
41872 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
41873 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
41874 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
41875 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
41876 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
41877 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
41878 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
41879 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
41880 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
41882 C...The following data lines are coefficients needed in the
41883 C...Duke, Owens proton structure function parametrizations, see below.
41884 C...Expansion coefficients for (up+down) valence quark distribution.
41885 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
41886 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41887 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41888 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
41889 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
41890 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41891 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41892 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
41893 C...Expansion coefficients for down valence quark distribution.
41894 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
41895 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41896 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
41897 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
41898 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
41899 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41900 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
41901 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
41902 C...Expansion coefficients for (up+down+strange) sea quark distribution.
41903 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
41904 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41905 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
41906 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
41907 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
41908 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41909 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
41910 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
41911 C...Expansion coefficients for charm sea quark distribution.
41912 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
41913 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41914 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
41915 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
41916 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
41917 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41918 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
41919 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
41920 C...Expansion coefficients for gluon distribution.
41921 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
41922 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41923 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
41924 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
41925 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
41926 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41927 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
41928 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
41930 C...Euler's beta function, requires ordinary Gamma function
41931 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
41933 C...Leading order proton parton distributions from Glueck, Reya and
41934 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
41936 IF(MSTP(51).EQ.11) THEN
41938 C...Determine s expansion variable and some x expressions.
41939 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
41940 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
41945 C...Evaluate valence, gluon and sea distributions.
41946 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
41947 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
41948 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
41949 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
41950 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
41951 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
41952 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
41953 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
41954 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
41955 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
41956 & SQRT(4.066D0*SD**1.218D0*XL)))*
41957 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
41958 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
41959 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
41960 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
41961 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
41962 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
41963 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
41964 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
41965 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
41966 IF(SD.LE.0.888D0) THEN
41969 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
41970 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
41971 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
41973 IF(SD.LE.1.351D0) THEN
41976 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
41977 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
41978 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
41981 C...Put into output array.
41983 XPPR(1)=XFVDD+XFSEA
41984 XPPR(2)=XFVUD-XFVDD+XFSEA
41994 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
41995 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
41996 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
41998 C...Determine set, Lambda and x and t expansion variables.
42000 IF(NSET.EQ.1) ALAM=0.2D0
42001 IF(NSET.EQ.2) ALAM=0.29D0
42002 TMIN=LOG(5D0/ALAM**2)
42003 TMAX=LOG(1D8/ALAM**2)
42004 T=LOG(MAX(1D0,Q2/ALAM**2))
42005 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42007 IF(X.LE.0.1D0) NX=2
42008 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
42009 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
42011 C...Chebyshev polynomials for x and t expansion.
42014 TX(3)=2D0*VX**2-1D0
42015 TX(4)=4D0*VX**3-3D0*VX
42016 TX(5)=8D0*VX**4-8D0*VX**2+1D0
42017 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
42020 TT(3)=2D0*VT**2-1D0
42021 TT(4)=4D0*VT**3-3D0*VT
42022 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42023 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42025 C...Calculate structure functions.
42030 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
42033 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
42036 C...Put into output array.
42038 XPPR(1)=XQ(2)+XQ(3)
42039 XPPR(2)=XQ(1)+XQ(3)
42047 C...Special expansion for bottom (threshold effects).
42048 IF(MSTP(58).GE.5) THEN
42049 IF(NSET.EQ.1) TMIN=8.1905D0
42050 IF(NSET.EQ.2) TMIN=7.4474D0
42052 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42055 TT(3)=2D0*VT**2-1D0
42056 TT(4)=4D0*VT**3-3D0*VT
42057 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42058 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42062 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
42065 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
42070 C...Special expansion for top (threshold effects).
42071 IF(MSTP(58).GE.6) THEN
42072 IF(NSET.EQ.1) TMIN=11.5528D0
42073 IF(NSET.EQ.2) TMIN=10.8097D0
42074 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
42075 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
42077 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42080 TT(3)=2D0*VT**2-1D0
42081 TT(4)=4D0*VT**3-3D0*VT
42082 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42083 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42087 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
42090 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
42095 C...Proton parton distributions from Duke, Owens.
42096 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
42097 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
42099 C...Determine set, Lambda and s expansion parameter.
42101 IF(NSET.EQ.1) ALAM=0.2D0
42102 IF(NSET.EQ.2) ALAM=0.4D0
42103 Q2IN=MIN(1D6,MAX(4D0,Q2))
42104 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
42106 C...Calculate structure functions.
42109 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
42110 & CDO(3,IS,KFL,NSET)*SD**2
42113 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
42114 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
42116 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
42117 & TS(5)*X**2+TS(6)*X**3)
42121 C...Put into output arrays.
42123 XPPR(1)=XQ(2)+XQ(3)/6D0
42124 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
42137 C*********************************************************************
42140 C...Gives threshold attractive/repulsive factor for heavy flavour
42143 FUNCTION PYHFTH(SH,SQM,FRATT)
42145 C...Double precision and integer declarations.
42146 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42147 IMPLICIT INTEGER(I-N)
42148 INTEGER PYK,PYCHGE,PYCOMP
42150 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42151 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42152 COMMON/PYINT1/MINT(400),VINT(400)
42153 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
42155 C...Value for alpha_strong.
42156 IF(MSTP(35).LE.1) THEN
42161 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
42167 C...Evaluate attractive and repulsive factors.
42168 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42169 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
42170 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42171 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
42172 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
42178 C*********************************************************************
42181 C...Splits a hadron remnant into two (partons or hadron + parton)
42182 C...in case it is more complicated than just a quark or a diquark.
42184 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
42186 C...Double precision and integer declarations.
42187 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42188 IMPLICIT INTEGER(I-N)
42189 INTEGER PYK,PYCHGE,PYCOMP
42190 C...Commonblocks. PYDAT1 temporary
42191 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42192 COMMON/PYINT1/MINT(400),VINT(400)
42193 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42194 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
42198 C...Preliminaries. Parton composition.
42201 KFL(1)=MOD(KFA/1000,10)
42202 KFL(2)=MOD(KFA/100,10)
42203 KFL(3)=MOD(KFA/10,10)
42204 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
42205 KFL(2)=INT(1.5D0+PYR(0))
42206 IF(MINT(105).EQ.333) KFL(2)=3
42207 IF(MINT(105).EQ.443) KFL(2)=4
42209 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
42212 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
42215 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
42216 KFL(2)=MOD(KFA/10,10)
42217 KFL(3)=MOD(KFA/100,10)
42219 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
42226 C...Subdivide lepton.
42227 IF(KFA.GE.11.AND.KFA.LE.18) THEN
42228 IF(KFLR.EQ.KFA) THEN
42230 ELSEIF(KFLR.EQ.22) THEN
42232 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
42234 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
42236 ELSEIF(KFLR.EQ.21) THEN
42244 C...Subdivide photon.
42245 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
42246 IF(KFLR.NE.21) THEN
42251 IF(RAGR.GT.0.125D0) KFLSP=2
42252 IF(RAGR.GT.0.625D0) KFLSP=3
42253 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
42257 C...Subdivide Reggeon or Pomeron.
42258 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
42259 IF(KFLIN.EQ.21) THEN
42265 C...Subdivide meson.
42266 ELSEIF(KFL(1).EQ.0) THEN
42267 KFL(2)=KFL(2)*(-1)**KFL(2)
42268 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
42269 IF(KFLR.EQ.KFL(2)) THEN
42271 ELSEIF(KFLR.EQ.KFL(3)) THEN
42273 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
42276 ELSEIF(KFLR.EQ.21) THEN
42279 ELSEIF(KFLR*KFL(2).GT.0) THEN
42282 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
42283 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42285 ELSEIF(KFLCH.EQ.0) THEN
42286 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42294 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
42295 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42297 ELSEIF(KFLCH.EQ.0) THEN
42298 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42305 C...Special case for extracting photon from baryon without splitting
42306 C...the latter. (Currently only used by external programs.)
42307 ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
42311 C...Subdivide baryon.
42315 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
42318 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
42321 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
42322 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
42325 IAGR=1.00001D0+2.99998D0*PYR(0)
42328 IF(IAGR.EQ.1) ID1=2
42329 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
42332 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
42333 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
42334 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
42335 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
42336 ELSEIF(MOD(KFA,10).EQ.2) THEN
42337 IF(IAGR.EQ.1) KSP=1
42338 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
42340 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
42341 IF(KFLR.EQ.21) THEN
42343 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
42346 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
42347 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42349 ELSEIF(KFLCH.EQ.0) THEN
42350 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42354 ELSEIF(NAGR.EQ.0) THEN
42357 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
42358 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42360 ELSEIF(KFLCH.EQ.0) THEN
42361 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42369 C...Add on correct sign for result.
42376 C*********************************************************************
42379 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
42380 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
42381 C...(Dover, 1965) 6.1.36.
42385 C...Double precision and integer declarations.
42386 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42387 IMPLICIT INTEGER(I-N)
42388 INTEGER PYK,PYCHGE,PYCOMP
42389 C...Local array and data.
42391 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
42392 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
42401 PYGAMM=PYGAMM+B(I)*DXP
42407 PYGAMM=(X-IX)*PYGAMM
42414 C***********************************************************************
42417 C...Calculates real and imaginary parts of the auxiliary functions W1
42418 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
42419 C...der Bij, Nucl. Phys. B297 (1988) 221.
42421 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
42423 C...Double precision and integer declarations.
42424 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42425 IMPLICIT INTEGER(I-N)
42426 INTEGER PYK,PYCHGE,PYCOMP
42428 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42431 ASINH(X)=LOG(X+SQRT(X**2+1D0))
42432 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
42434 IF(EPS.LT.0D0) THEN
42435 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
42436 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
42438 ELSEIF(EPS.LT.1D0) THEN
42439 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
42440 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
42441 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
42442 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
42444 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
42445 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
42452 C***********************************************************************
42455 C...Calculates real and imaginary parts of the auxiliary function I3;
42456 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
42457 C...Nucl. Phys. B297 (1988) 221.
42459 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
42461 C...Double precision and integer declarations.
42462 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42463 IMPLICIT INTEGER(I-N)
42464 INTEGER PYK,PYCHGE,PYCOMP
42466 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42469 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
42470 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
42472 IF(EPS.LT.0D0) THEN
42473 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42474 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
42475 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
42476 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
42477 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
42478 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
42479 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
42480 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
42482 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
42483 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
42484 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
42485 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
42486 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
42487 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
42488 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
42489 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
42490 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42491 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
42492 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
42493 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
42494 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
42495 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
42496 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
42497 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
42499 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
42500 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
42501 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
42502 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
42503 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
42506 ELSEIF(EPS.LT.1D0) THEN
42507 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42508 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
42509 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
42510 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
42511 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
42512 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
42513 & (0.25D0*(RAT+1D0)*EPS))
42514 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
42515 & (0.25D0*(RAT+1D0)*EPS))
42516 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
42517 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
42518 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
42519 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
42520 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
42521 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
42522 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
42523 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
42524 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42525 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
42526 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
42527 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
42528 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
42529 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
42530 & (1D0+0.25D0*RAT*EPS-GA))
42531 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
42532 & (1D0+0.25D0*RAT*EPS-GA))
42534 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
42535 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
42536 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
42537 & LOG((GA+BE-1D0)/(BE-GA))
42538 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
42541 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
42542 RCTHE=RSQ*(1D0-2D0*BE/EPS)
42543 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
42544 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
42545 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
42547 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
42548 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
42549 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
42550 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
42551 & (PHI-THE)*(PHI+THE-PARU(1))
42552 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
42553 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
42556 Y3RE=2D0/(2D0*BE-1D0)*F3RE
42557 Y3IM=2D0/(2D0*BE-1D0)*F3IM
42562 C***********************************************************************
42565 C...Calculates real and imaginary part of Spence function; see
42566 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
42568 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
42570 C...Double precision and integer declarations.
42571 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42572 IMPLICIT INTEGER(I-N)
42573 INTEGER PYK,PYCHGE,PYCOMP
42575 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42577 C...Local array and data.
42580 &1.000000D+00, -5.000000D-01, 1.666667D-01,
42581 &0.000000D+00, -3.333333D-02, 0.000000D+00,
42582 &2.380952D-02, 0.000000D+00, -3.333333D-02,
42583 &0.000000D+00, 7.575757D-02, 0.000000D+00,
42584 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
42588 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
42589 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
42590 IF(IREIM.EQ.2) PYSPEN=0D0
42594 XMOD=SQRT(XRE**2+XIM**2)
42595 IF(XMOD.LT.1D-6) THEN
42596 IF(IREIM.EQ.1) PYSPEN=0D0
42597 IF(IREIM.EQ.2) PYSPEN=0D0
42601 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42605 IF(XMOD.GT.1D0) THEN
42607 ALGXIM=XARG-SIGN(PARU(1),XARG)
42608 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
42609 SP0IM=-ALGXRE*ALGXIM
42616 IF(XRE.GT.0.5D0) THEN
42621 XMOD=SQRT(XRE**2+XIM**2)
42622 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42625 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
42626 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
42632 XMOD=SQRT(XRE**2+XIM**2)
42633 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42642 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
42643 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
42644 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
42647 SPRE=SPRE+B(I)*TERMRE
42648 SPIM=SPIM+B(I)*TERMIM
42651 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
42652 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
42657 C***********************************************************************
42660 C...Calculates the matrix element for the processes
42661 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
42662 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
42663 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
42665 SUBROUTINE PYQQBH(WTQQBH)
42667 C...Double precision and integer declarations.
42668 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42669 IMPLICIT INTEGER(I-N)
42670 INTEGER PYK,PYCHGE,PYCOMP
42672 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42673 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42674 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42675 COMMON/PYINT1/MINT(400),VINT(400)
42676 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42677 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
42678 C...Local arrays and function.
42679 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
42680 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
42683 C...Mass parameters.
42686 SHPR=SQRT(VINT(26))*VINT(1)
42687 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
42688 PH=SQRT(VINT(21))*VINT(1)
42692 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
42694 PT=SQRT(MAX(0D0,VINT(197+5*I)))
42695 PP(I,1)=PT*COS(VINT(198+5*I))
42696 PP(I,2)=PT*SIN(VINT(198+5*I))
42698 PP(3,1)=-PP(1,1)-PP(2,1)
42699 PP(3,2)=-PP(1,2)-PP(2,2)
42700 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
42701 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
42702 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
42704 PP(3,3)=PMT3*SINH(VINT(211))
42705 PP(3,4)=PMT3*COSH(VINT(211))
42706 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
42707 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
42708 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
42709 PP(2,3)=-PP(1,3)-PP(3,3)
42710 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
42711 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
42713 C...Set up incoming kinematics and derived momentum combinations.
42717 PP(I,3)=-0.5D0*SHPR*(-1)**I
42718 PP(I,4)=-0.5D0*SHPR
42721 PP(6,J)=PP(1,J)+PP(2,J)
42722 PP(7,J)=PP(1,J)+PP(3,J)
42723 PP(8,J)=PP(1,J)+PP(4,J)
42724 PP(9,J)=PP(1,J)+PP(5,J)
42725 PP(10,J)=-PP(2,J)-PP(3,J)
42726 PP(11,J)=-PP(2,J)-PP(4,J)
42727 PP(12,J)=-PP(2,J)-PP(5,J)
42728 PP(13,J)=-PP(4,J)-PP(5,J)
42731 C...Derived kinematics invariants.
42760 C...Define colour coefficients for g + g -> Q + Qbar + H.
42761 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
42765 CLR(I+3,J+3)=16D0/3D0
42766 CLR(I,J+3)=-2D0/3D0
42767 CLR(I+3,J)=-2D0/3D0
42780 CLR(6+K1,6+K2)=12D0
42784 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
42785 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
42786 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
42787 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
42788 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
42789 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
42790 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
42792 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
42793 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
42794 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42795 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
42796 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
42797 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
42798 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
42799 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
42800 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
42801 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
42802 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
42803 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
42804 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
42805 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
42806 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
42807 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
42808 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
42809 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
42811 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
42812 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
42813 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
42814 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
42815 & +X4*X9*X5+X4*X5**2)
42816 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
42817 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
42818 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
42819 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
42820 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
42821 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
42822 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
42823 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
42824 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
42825 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
42826 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
42827 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
42828 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
42829 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
42830 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
42831 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
42832 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
42833 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
42834 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
42835 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
42837 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
42838 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
42839 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
42840 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
42841 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
42842 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
42843 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
42845 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
42846 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
42847 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
42848 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
42849 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
42850 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
42852 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
42853 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
42854 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
42855 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
42856 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
42857 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
42858 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
42860 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
42861 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
42862 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
42863 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
42864 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
42865 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
42866 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
42867 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
42868 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
42869 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
42870 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
42871 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
42872 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
42873 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
42874 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
42875 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
42876 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
42877 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
42878 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
42879 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
42880 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
42881 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
42882 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
42883 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
42884 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
42885 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
42886 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
42887 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
42888 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
42889 & +X3*X8*X5+X3*X5**2)
42890 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
42891 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
42892 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
42893 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
42894 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
42895 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
42896 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
42898 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
42899 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
42900 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
42901 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
42902 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
42903 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
42904 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
42905 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
42906 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
42907 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
42908 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
42909 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
42910 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
42911 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
42912 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
42913 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
42914 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
42915 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
42916 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
42917 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
42918 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
42919 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
42920 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
42921 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
42922 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
42923 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
42925 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
42926 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
42927 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42928 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
42929 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
42930 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
42931 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
42932 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
42933 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
42934 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
42935 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
42936 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
42937 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
42938 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
42939 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
42940 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
42941 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
42942 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
42943 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
42944 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
42945 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
42946 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
42947 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
42948 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
42949 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
42950 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
42952 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42953 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42954 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
42955 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
42956 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
42957 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
42958 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
42959 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
42960 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
42961 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
42962 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
42963 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42964 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42965 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
42966 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
42967 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
42968 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
42969 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
42970 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
42971 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
42972 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
42973 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
42974 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
42975 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
42976 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
42977 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
42978 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
42979 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
42980 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
42981 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
42982 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
42983 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
42984 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
42985 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
42986 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
42987 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
42988 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
42989 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
42990 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
42991 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
42992 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
42993 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
42994 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
42995 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
42997 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
42998 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
42999 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
43000 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
43001 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
43002 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
43003 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
43004 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
43005 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
43006 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
43007 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
43009 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43010 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
43011 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
43012 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43013 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
43014 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
43016 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43017 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
43018 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
43020 FM(9,10)=0.5D0*(FMXX+FM(9,10))
43021 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43022 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
43023 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
43025 C...Repackage matrix elements.
43031 RM(7,7)=FM(7,7)-2D0*FM(9,9)
43032 RM(7,8)=FM(7,8)-2D0*FM(9,10)
43033 RM(8,8)=FM(8,8)-2D0*FM(10,10)
43035 C...Produce final result: matrix elements * colours * propagators.
43040 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
43043 WTQQBH=-WTQQBH/256D0
43046 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
43047 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
43048 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
43050 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
43051 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
43052 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
43054 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
43055 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
43058 C...Produce final result: matrix elements * propagators.
43060 A12=A12/(DX(7)*DX(8))
43062 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
43068 C*********************************************************************
43070 C...PYSTBH (and auxiliaries)
43071 C.. Evaluates the matrix elements for t + b + H production.
43073 SUBROUTINE PYSTBH(WTTBH)
43075 C...DOUBLE PRECISION AND INTEGER DECLARATIONS
43076 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43077 IMPLICIT INTEGER(I-N)
43078 INTEGER PYK,PYCHGE,PYCOMP
43081 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43082 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43083 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43084 COMMON/PYINT1/MINT(400),VINT(400)
43085 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43086 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
43087 COMMON/PYINT4/MWID(500),WIDS(500,5)
43088 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
43089 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43090 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
43091 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
43092 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
43093 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
43094 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43095 DOUBLE PRECISION MW2
43096 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
43097 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
43099 C...LOCAL ARRAYS AND COMPLEX VARIABLES
43100 DIMENSION QQ(4,2),PP(4,3)
43105 C...KINEMATIC PARAMETERS.
43106 SHPR=SQRT(VINT(26))*VINT(1)
43107 PH=SQRT(VINT(21))*VINT(1)
43110 C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
43112 PT=SQRT(MAX(0D0,VINT(197+5*I)))
43113 PP(1,I)=PT*COS(VINT(198+5*I))
43114 PP(2,I)=PT*SIN(VINT(198+5*I))
43116 PP(1,3)=-PP(1,1)-PP(1,2)
43117 PP(2,3)=-PP(2,1)-PP(2,2)
43118 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
43119 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
43120 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
43122 PP(3,3)=PMT3*SINH(VINT(211))
43123 PP(4,3)=PMT3*COSH(VINT(211))
43124 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
43125 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
43126 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
43127 PP(3,2)=-PP(3,1)-PP(3,3)
43128 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
43129 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
43131 C...CM SYSTEM, INGOING QUARKS/GLUONS
43132 QQ(3,1) = SHPR/2.D0
43137 C...PARAMETERS FOR AMPLITUDE METHOD
43141 MW2 = PMAS(24,1)**2
43144 RMB=PYMRUN(5,VINT(52))
43148 IF (ISUB.EQ.401) THEN
43149 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43150 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43151 ELSE IF (ISUB.EQ.402) THEN
43152 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43153 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43158 C------------------------------------------------------------------
43159 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
43160 C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
43161 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43162 IMPLICIT INTEGER(I-N)
43163 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
43164 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43167 C TOP WIDTH CALCULATION
43174 IF (MT .LT. (MHP+MB)) THEN
43176 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43177 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43178 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43181 C T ->BW +T ->B H^+
43182 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43183 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43184 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43186 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
43187 & -4.D0*(MHP*MB/MT**2)**2 )
43188 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
43189 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
43190 GAMT = GAMTBW+GAMTBH
43197 C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
43198 C GG->TBH^+, QQBAR->TBH^+
43199 C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
43200 C (FOR INSTANCE WITH PYTHIA)
43201 C------------------------------------------------------------
43202 C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
43203 C PHYS REV. D 60 (1999) 115011
43204 C (THESE FILES PREPARED BY J.-L. KNEUR)
43205 C------------------------------------------------------------
43207 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43209 C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
43211 C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
43212 C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
43213 C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
43214 C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
43215 C "PHYSICAL PARAMETERS" INPUT:
43216 C MT,MB TOP AND BOTTOM MASSES;
43217 C MHP CHARGED HIGGS MASS
43218 C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
43220 C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
43221 C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
43222 C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
43223 C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
43224 C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
43225 C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
43226 C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
43228 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43229 IMPLICIT INTEGER(I-N)
43230 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43231 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43232 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43233 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43234 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43236 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43237 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
43238 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43239 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43240 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43241 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
43242 C (TAN BETA) VALUES
43244 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43245 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43250 C COLLECTING THE RELEVANT OVERALL FACTORS:
43251 C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
43252 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
43253 C COUPLING CONSTANT (OVERALL NORMALIZATION)
43254 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
43255 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
43256 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
43257 C ALPHAS IS ALPHA_STRONG;
43258 C SW2 IS SIN(THETA_W)**2.
43261 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
43263 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
43264 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
43265 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
43267 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
43268 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
43270 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
43272 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
43273 S = 2*PYTBHS(Q1,Q2)
43280 C TOP WIDTH CALCULATION
43281 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
43282 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
43283 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
43284 A1INV= S -2*P1Q1 -2*P1Q2
43285 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
43286 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
43287 C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
43289 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
43290 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
43291 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
43292 C NOW COMES THE AMP**2:
43293 C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
43294 C THE EXPRESSIONS BELOW
43297 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
43298 &512*A1*A2*MB*MT/3-
43299 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
43300 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
43301 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
43302 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
43303 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
43304 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
43305 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
43306 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
43307 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
43308 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
43309 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
43310 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
43311 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43312 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43313 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
43314 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
43315 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
43316 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
43317 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43318 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
43319 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
43320 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43321 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43322 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43323 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
43324 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43325 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43326 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43327 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43328 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43329 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
43330 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43331 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43332 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
43333 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
43334 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43335 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
43336 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43337 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43338 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
43339 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
43340 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43341 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
43342 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43343 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43344 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43345 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43346 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
43347 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
43348 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43349 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
43350 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43351 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
43352 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
43353 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43354 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43355 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
43356 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
43357 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
43358 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43359 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43360 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43361 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43362 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43363 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
43364 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43365 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43366 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43367 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
43368 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43369 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
43370 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43371 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43372 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
43373 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43374 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43375 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43376 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
43377 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43378 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43379 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43380 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43381 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43382 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43383 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
43384 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43385 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43386 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
43387 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43388 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43389 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43390 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43391 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43392 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43393 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
43394 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43395 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43396 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43397 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
43398 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43399 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43400 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43401 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43402 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
43403 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
43404 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
43405 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
43406 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
43407 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
43408 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
43409 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
43410 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
43411 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
43412 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
43413 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
43414 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
43415 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
43416 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
43417 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
43418 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
43419 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
43420 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
43421 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
43422 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
43423 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
43424 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
43425 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
43426 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
43427 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
43428 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
43429 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
43430 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
43431 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
43432 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
43433 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
43434 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
43435 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
43436 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
43437 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
43438 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
43439 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
43440 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
43441 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
43442 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
43443 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
43444 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
43445 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
43446 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43447 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
43448 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43449 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
43450 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
43451 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43452 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43453 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43454 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
43455 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
43456 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
43457 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43458 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43459 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
43460 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
43461 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
43462 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
43463 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43464 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43465 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
43466 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
43467 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
43468 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
43469 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
43470 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
43471 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
43472 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
43473 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43474 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
43475 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43476 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43477 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43478 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
43479 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
43480 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43481 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43482 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
43483 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43484 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43485 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
43486 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
43487 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
43488 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
43489 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
43490 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
43491 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
43492 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
43493 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
43494 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
43495 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
43496 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
43497 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
43498 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
43499 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
43500 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
43501 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43502 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43503 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
43504 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
43505 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
43506 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
43507 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
43508 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43509 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43510 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
43511 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43512 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43513 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
43514 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
43515 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
43516 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
43517 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
43518 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
43519 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
43520 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
43521 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
43522 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
43523 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
43524 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
43525 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
43526 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
43527 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
43528 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
43529 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
43530 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
43531 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
43532 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
43533 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
43534 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
43535 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
43536 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
43537 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
43538 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
43539 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
43540 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
43541 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
43542 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43543 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43544 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43545 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
43546 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
43547 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
43548 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
43549 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
43550 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
43551 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
43552 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
43553 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
43554 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
43555 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
43556 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43557 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43558 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
43559 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43560 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43561 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
43562 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
43563 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
43564 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
43565 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
43566 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
43567 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
43568 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
43569 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
43570 &384*A12*MB*MT*P1Q1**2/S**2+
43571 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
43572 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
43573 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
43574 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
43575 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
43576 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
43577 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
43578 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
43579 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
43580 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
43581 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
43582 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
43583 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
43584 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
43585 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
43586 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
43587 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
43588 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
43589 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
43590 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
43591 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
43592 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
43593 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
43594 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
43595 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
43596 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
43597 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
43598 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
43599 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
43600 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
43601 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
43602 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
43603 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
43604 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
43605 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
43606 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
43607 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
43608 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
43609 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
43610 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
43611 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
43612 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
43613 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
43614 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
43615 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
43616 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
43617 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
43618 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
43619 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
43620 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
43621 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
43622 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
43623 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
43624 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
43625 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43626 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43627 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
43628 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43629 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43630 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
43631 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
43632 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
43633 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
43634 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
43635 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
43636 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
43637 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
43638 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
43639 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
43640 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
43641 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
43642 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
43643 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
43644 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
43645 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
43646 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
43647 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43648 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43649 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
43650 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
43651 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
43652 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
43653 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
43654 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
43655 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
43656 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
43657 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
43658 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
43659 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
43660 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
43661 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
43662 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
43663 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
43664 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
43665 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
43666 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
43667 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
43668 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
43669 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43670 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43671 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
43672 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
43673 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
43674 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
43675 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
43676 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
43677 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
43678 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
43679 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
43680 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
43681 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43682 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43683 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
43684 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43685 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43686 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
43687 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
43688 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
43689 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
43690 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
43691 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
43692 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43693 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43694 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43695 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43696 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43697 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43698 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
43699 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
43700 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
43701 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
43702 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
43703 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
43704 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43705 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43706 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
43707 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
43708 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
43709 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
43710 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
43711 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
43712 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
43713 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
43714 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
43715 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
43716 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
43717 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
43718 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
43719 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
43720 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
43721 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
43722 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
43723 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
43724 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
43725 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
43726 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
43727 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
43728 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
43729 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43730 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43731 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
43732 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
43733 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
43734 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
43735 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
43736 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
43737 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43738 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43739 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
43740 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
43741 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
43742 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43743 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43744 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
43745 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
43746 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
43749 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43750 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43751 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43752 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43753 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
43754 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43755 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43756 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
43757 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
43758 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
43759 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
43760 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
43761 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
43762 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
43763 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
43764 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
43765 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
43766 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
43767 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
43768 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43769 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43770 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
43771 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
43772 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
43773 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
43774 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
43775 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
43776 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
43777 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
43778 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
43779 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
43780 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
43781 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
43782 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
43783 &272*A1*A2*P1Q1*S/(3*P1Q2)+
43784 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
43785 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
43786 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
43787 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
43788 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
43789 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
43790 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
43791 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
43792 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
43793 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
43794 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
43795 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
43796 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
43797 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
43798 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
43799 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
43800 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
43801 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
43802 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
43803 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
43804 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
43805 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
43806 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
43807 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
43808 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
43809 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
43810 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
43811 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43812 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
43813 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
43814 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
43815 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
43816 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
43817 &32*A12*P2Q1*S/(3*P1Q1)-
43818 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
43819 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
43820 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
43821 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
43822 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
43823 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
43824 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
43825 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
43826 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
43827 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
43828 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
43829 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
43830 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
43831 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
43832 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
43833 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
43834 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
43835 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
43836 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
43837 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
43838 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
43839 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
43840 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
43841 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
43842 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
43843 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
43844 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
43845 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
43846 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43847 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43848 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43849 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
43850 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
43851 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
43852 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
43853 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
43854 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
43855 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
43856 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43857 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
43858 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43859 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43860 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43861 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43862 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43863 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43864 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43865 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43866 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
43867 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
43868 &272*A1*A2*P2Q1*S/(3*P2Q2)-
43869 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
43870 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
43871 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
43872 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
43873 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
43874 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
43875 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
43876 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
43877 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
43878 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
43879 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
43880 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
43881 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
43882 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
43883 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
43884 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
43885 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
43886 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
43887 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
43888 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
43889 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
43890 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
43891 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43894 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
43895 &512*A1*A2*MB*MT/3+
43896 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
43897 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
43898 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
43899 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
43900 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
43901 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
43902 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
43903 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
43904 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
43905 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
43906 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
43907 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
43908 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43909 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43910 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
43911 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
43912 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
43913 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
43914 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43915 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
43916 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
43917 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43918 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43919 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43920 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
43921 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43922 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43923 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43924 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43925 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43926 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
43927 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43928 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43929 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
43930 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
43931 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43932 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
43933 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43934 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43935 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
43936 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
43937 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43938 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
43939 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43940 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43941 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43942 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43943 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
43944 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
43945 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43946 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
43947 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43948 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43949 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43950 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43951 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43952 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
43953 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
43954 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
43955 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43956 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43957 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43958 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
43959 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43960 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
43961 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43962 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43963 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43964 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
43965 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43966 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
43967 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43968 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43969 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43970 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43971 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43972 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43973 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
43974 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43975 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43976 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
43977 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43978 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43979 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43980 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
43981 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43982 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43983 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
43984 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43985 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43986 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
43987 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43988 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43989 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43990 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
43991 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43992 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43993 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43994 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
43995 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43996 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43997 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43998 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43999 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
44000 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
44001 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
44002 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
44003 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
44004 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
44005 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
44006 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
44007 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
44008 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
44009 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
44010 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
44011 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
44012 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
44013 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
44014 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
44015 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
44016 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
44017 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
44018 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
44019 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
44020 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
44021 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
44022 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
44023 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
44024 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
44025 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
44026 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
44027 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
44028 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
44029 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
44030 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
44031 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
44032 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
44033 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
44034 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
44035 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
44036 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
44037 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
44038 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
44039 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
44040 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44041 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44042 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
44043 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44044 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44045 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44046 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
44047 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
44048 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44049 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
44050 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44051 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
44052 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
44053 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
44054 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44055 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
44056 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
44057 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
44058 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
44059 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
44060 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44061 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
44062 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
44063 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
44064 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
44065 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
44066 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
44067 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
44068 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
44069 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
44070 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
44071 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44072 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44073 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44074 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44075 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
44076 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44077 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44078 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44079 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44080 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44081 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44082 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
44083 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
44084 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
44085 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
44086 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
44087 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
44088 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
44089 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
44090 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
44091 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
44092 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
44093 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
44094 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
44095 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
44096 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
44097 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
44098 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44099 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44100 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
44101 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
44102 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
44103 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
44104 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
44105 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44106 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
44107 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
44108 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44109 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44110 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
44111 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
44112 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
44113 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
44114 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
44115 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
44116 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
44117 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
44118 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
44119 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
44120 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
44121 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
44122 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
44123 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
44124 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
44125 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
44126 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
44127 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
44128 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
44129 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
44130 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
44131 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
44132 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
44133 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
44134 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
44135 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
44136 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
44137 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
44138 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
44139 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
44140 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44141 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44142 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
44143 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
44144 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
44145 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
44146 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
44147 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
44148 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
44149 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
44150 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
44151 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
44152 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
44153 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44154 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
44155 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
44156 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44157 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44158 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
44159 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
44160 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
44161 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
44162 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
44163 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
44164 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
44165 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
44166 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
44167 &384*A12*MB*MT*P1Q1**2/S**2+
44168 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
44169 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
44170 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
44171 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
44172 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
44173 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
44174 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
44175 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
44176 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
44177 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
44178 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
44179 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
44180 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
44181 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
44182 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
44183 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
44184 &384*A2**2*MB*MT*P2Q2**2/S**2+
44185 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
44186 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
44187 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
44188 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
44189 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
44190 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
44191 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
44192 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
44193 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
44194 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
44195 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
44196 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
44197 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
44198 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
44199 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
44200 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
44201 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
44202 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
44203 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
44204 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
44205 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
44206 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
44207 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
44208 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
44209 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
44210 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
44211 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
44212 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
44213 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
44214 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
44215 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
44216 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
44217 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
44218 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
44219 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
44220 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
44221 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
44222 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
44223 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44224 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
44225 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44226 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
44227 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
44228 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
44229 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
44230 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
44231 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
44232 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
44233 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
44234 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
44235 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
44236 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
44237 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
44238 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
44239 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
44240 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
44241 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
44242 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
44243 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44244 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44245 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
44246 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
44247 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
44248 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
44249 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
44250 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
44251 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
44252 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
44253 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
44254 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
44255 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
44256 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
44257 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
44258 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
44259 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
44260 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
44261 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
44262 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
44263 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
44264 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
44265 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
44266 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
44267 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
44268 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
44269 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
44270 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
44271 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
44272 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
44273 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
44274 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
44275 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
44276 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
44277 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44278 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44279 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
44280 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
44281 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
44282 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
44283 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
44284 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
44285 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
44286 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
44287 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
44288 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44289 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44290 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44291 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44292 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44293 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44294 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
44295 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
44296 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
44297 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
44298 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
44299 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
44300 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
44301 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
44302 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
44303 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
44304 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
44305 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
44306 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
44307 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
44308 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
44309 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
44310 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
44311 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
44312 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
44313 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
44314 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
44315 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
44316 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
44317 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
44318 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
44319 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
44320 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
44321 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
44322 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
44323 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
44324 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44325 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44326 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
44327 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
44328 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
44329 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
44330 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
44331 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
44332 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
44333 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
44334 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
44335 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
44336 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
44337 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44338 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44339 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
44340 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44341 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44342 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44343 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44344 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44345 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44346 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
44347 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
44348 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
44349 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
44350 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
44351 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
44352 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
44353 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
44354 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
44355 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
44356 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
44357 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
44358 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
44359 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
44360 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44361 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44362 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
44363 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
44364 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
44365 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
44366 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
44367 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
44368 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
44369 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
44370 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
44371 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
44372 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
44373 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
44374 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
44375 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
44376 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
44377 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
44380 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
44381 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
44382 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
44383 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
44384 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
44385 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
44386 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
44387 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
44388 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
44389 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
44390 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
44391 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
44392 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
44393 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
44394 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
44395 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
44396 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
44398 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
44399 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
44400 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
44401 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
44402 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
44403 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
44404 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44405 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44406 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
44407 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
44408 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
44409 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
44410 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
44411 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
44412 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
44413 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
44414 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
44415 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
44416 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
44417 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
44418 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
44419 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
44420 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
44421 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
44422 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
44423 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
44424 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
44425 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
44426 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
44427 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
44428 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
44429 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
44430 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
44431 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
44432 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
44433 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
44434 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
44435 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
44436 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
44437 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
44438 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
44439 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44440 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44441 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
44442 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
44443 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
44444 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
44445 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
44446 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
44447 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
44448 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
44449 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44450 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44451 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
44452 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44453 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44454 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44455 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44456 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44457 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44458 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44459 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
44460 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
44461 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
44462 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
44463 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
44464 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
44465 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
44466 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
44467 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
44468 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
44469 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
44470 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
44471 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
44472 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
44473 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
44474 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
44475 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
44476 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
44477 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
44478 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
44479 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
44480 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
44481 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
44482 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
44483 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44487 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
44488 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
44489 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44490 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44491 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
44492 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
44493 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44494 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
44495 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
44496 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
44497 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44498 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44499 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
44500 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
44501 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
44502 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
44503 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
44504 V910=V910+96*A1*A2*P1P2*P2Q1/S-
44505 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
44506 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
44507 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
44508 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
44509 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
44511 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
44512 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
44513 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44514 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44515 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
44516 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
44517 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44518 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
44519 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
44520 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
44521 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44522 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44523 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
44524 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
44525 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
44526 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
44527 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
44528 A910=A910+96*A1*A2*P1P2*P2Q1/S-
44529 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
44530 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
44531 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
44532 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
44533 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
44537 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
44540 C---------------------------------------------------------
44541 C 2) Q QBAR ->TBH^+
44542 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
44544 C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
44545 C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
44546 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44547 IMPLICIT INTEGER(I-N)
44548 DOUBLE PRECISION MW2,MT,MB,MHP,MW
44549 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
44550 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44551 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44552 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44553 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
44554 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
44555 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
44556 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
44557 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
44558 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
44560 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
44561 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
44568 C COLLECTING THE RELEVANT OVERALL FACTORS:
44569 C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
44570 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
44571 C COUPLING CONSTANT (OVERALL NORMALIZATION)
44572 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
44573 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
44574 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
44575 C ALPHAS IS ALPHA_STRONG;
44576 C SW2 IS SIN(THETA_W)**2.
44579 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
44581 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
44582 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
44583 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
44585 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
44586 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
44588 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
44590 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
44591 S = 2*PYTBHS(Q1,Q2)
44598 C TOP WIDTH CALCULATION
44599 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
44600 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
44601 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
44602 A1INV= S -2*P1Q1 -2*P1Q2
44603 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
44604 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
44605 C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
44606 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
44607 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
44608 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
44609 C NOW COMES THE AMP**2:
44610 C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
44611 C THE EXPRESSIONS BELOW
44612 YY(1, 1) = -16*A**2*A2**2*MB*MT+
44613 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
44614 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
44615 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
44616 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44617 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44618 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
44619 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
44620 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
44621 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
44622 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
44623 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
44624 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
44625 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
44626 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
44627 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
44628 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
44629 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
44630 &32*A2**2*MB**2*P1P2*V**2/S+
44631 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
44632 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
44633 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
44634 YY(1, 1)=2*YY(1, 1)
44636 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
44637 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
44638 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44639 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44640 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
44641 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
44642 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
44643 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44644 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
44645 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
44646 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
44647 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
44648 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
44649 &64*A**2*A1*A2*MB*MT*P1P2/S+
44650 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
44651 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
44652 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
44653 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
44654 &64*A**2*A1*A2*P1Q1*P2Q1/S-
44655 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
44656 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
44657 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
44658 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
44659 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
44660 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
44661 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
44662 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
44663 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
44664 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
44665 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
44666 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
44667 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
44668 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
44669 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
44670 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
44671 &32*A1*A2*P1P2*P1Q1*V**2/S+
44672 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
44673 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
44674 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
44675 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
44678 YY(2, 2) =-16*A**2*A12*MB*MT+
44679 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
44680 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
44681 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
44682 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
44683 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
44684 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
44685 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
44686 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
44687 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
44688 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
44689 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
44690 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
44691 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
44692 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
44693 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
44694 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
44695 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
44696 &32*A12*MT**2*P2Q2*V**2/S-
44697 &32*A12*P1Q2*P2Q2*V**2/S
44698 YY(2, 2)=2*YY(2, 2)
44700 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
44701 AMP2= FACT*PS*VTB**2*RES
44704 C=====================================================================
44705 C ************* FUNCTION SCALAR PRODUCTS *************************
44706 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
44707 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44708 IMPLICIT INTEGER(I-N)
44709 DIMENSION A(4),B(4)
44712 DUM=DUM-A(ID)*B(ID)
44718 C*********************************************************************
44721 C...Initializes supersymmetry: finds sparticle masses and
44722 C...branching ratios and stores this information.
44723 C...AUTHOR: STEPHEN MRENNA
44724 C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
44728 C...Double precision and integer declarations.
44729 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44730 IMPLICIT INTEGER(I-N)
44731 INTEGER PYK,PYCHGE,PYCOMP
44732 C...Parameter statement to help give large particle numbers.
44733 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44734 &KEXCIT=4000000,KDIMEN=5000000)
44736 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44737 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44738 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44739 COMMON/PYDAT4/CHAF(500,2)
44741 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44742 COMMON/PYINT4/MWID(500),WIDS(500,5)
44743 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44744 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44745 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
44746 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
44747 COMMON/PYHTRI/HHH(7)
44748 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
44749 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
44750 &/PYMSSM/,/PYMSRV/,/PYSSMT/
44752 C...Local variables.
44753 DOUBLE PRECISION ALFA,BETA
44754 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
44755 INTEGER I,J,J1,I1,K1
44756 INTEGER KC,LKNT,IDLAM(400,3)
44757 DOUBLE PRECISION XLAM(0:400)
44758 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
44759 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
44760 DOUBLE PRECISION DELM,XMDIF
44761 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
44762 DOUBLE PRECISION ARG,SGNMU,R
44765 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
44768 &1000001,2000001,1000002,2000002,1000003,2000003,
44769 &1000004,2000004,1000005,2000005,1000006,2000006,
44770 &1000011,2000011,1000012,2000012,1000013,2000013,
44771 &1000014,2000014,1000015,2000015,1000016,2000016,
44772 &1000021,1000022,1000023,1000025,1000035,1000024,
44773 &1000037,1000039, 25, 35, 36, 37,
44774 & 6, 24, 45, 46,1000045, 9*0/
44777 C...Automatically read QNUMBERS, MASS, and DECAY tables
44778 IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
44780 CALL PYSLHA(0,0,IFAIL)
44781 CALL PYSLHA(5,0,IFAIL)
44783 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
44785 C...Do nothing further if SUSY not requested
44787 IF(IMSSM.EQ.0) RETURN
44789 C...Save copy of MWID(KC) and MDCY(KC,1) values before
44790 C...they are set to zero for the LSP.
44797 MDCYSU(I)=MDCY(KC,1)
44801 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
44805 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
44807 MDCY(KC,1)=MDCYSU(I)
44811 C...First part of routine: set masses and couplings.
44813 C...Reset mixing values in sfermion sector to pure left/right.
44821 C...Add NMSSM states if NMSSM switched on, and change old names.
44822 IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
44823 C... Switch on NMSSM
44824 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
44854 DO 123 KCT=100,MSTU(6)
44855 IF(KCHG(KCT,4).GT.100) KCN=KCT
44861 C... Set stable for now
44867 CHAF(KCN,1)='~chi_50'
44871 C...Read spectrum from SLHA file.
44872 IF (IMSSM.EQ.11) THEN
44873 CALL PYSLHA(1,0,IFAIL)
44876 C...Common couplings.
44881 COS2B=COS(2D0*BETA)
44887 C...Define sparticle masses for a general MSSM simulation.
44888 IF(IMSSM.EQ.1) THEN
44889 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
44891 KC=PYCOMP(KSUSY1+I)
44892 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
44893 KC=PYCOMP(KSUSY2+I)
44894 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
44895 KC=PYCOMP(KSUSY1+I+1)
44896 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
44897 KC=PYCOMP(KSUSY2+I+1)
44898 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
44900 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
44901 IF(XARG.LT.0D0) THEN
44902 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
44903 & ' FROM THE SUM RULE. '
44904 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
44910 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
44911 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
44912 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
44913 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
44915 IF(IMSS(8).EQ.1) THEN
44920 C...Alternatively derive masses from SUGRA relations.
44921 ELSEIF(IMSSM.EQ.2) THEN
44925 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
44934 C...Add in extra D-term contributions.
44935 IF(IMSS(7).EQ.1) THEN
44940 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44941 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
44942 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
44943 WRITE(MSTU(11),*) 'C DX = ',DX
44944 WRITE(MSTU(11),*) 'C DY = ',DY
44945 WRITE(MSTU(11),*) 'C DS = ',DS
44946 WRITE(MSTU(11),*) 'C '
44947 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
44948 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
44949 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44950 DQ2=DY/6D0-DX/3D0-DS/3D0
44951 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
44952 DD2=DY/3D0+DX-2D0*DS/3D0
44953 DL2=-DY/2D0+DX-2D0*DS/3D0
44954 DE2=DY-DX/3D0-DS/3D0
44955 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
44956 DHD2=-DY/2D0-2D0*DX/3D0+DS
44957 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
44959 DMA2 = 2D0*DMU2+DHU2+DHD2
44961 KC=PYCOMP(KSUSY1+I)
44962 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44963 KC=PYCOMP(KSUSY2+I)
44964 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
44965 KC=PYCOMP(KSUSY1+I+1)
44966 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44967 KC=PYCOMP(KSUSY2+I+1)
44968 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
44971 KC=PYCOMP(KSUSY1+I)
44972 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44973 KC=PYCOMP(KSUSY2+I)
44974 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
44975 KC=PYCOMP(KSUSY1+I+1)
44976 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44978 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
44979 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
44982 SGNMU=SIGN(1D0,RMSS(4))
44983 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
44984 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
44985 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
44986 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
44987 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
44988 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
44989 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
44990 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
44991 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
44992 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
44993 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
44994 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
44995 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
44998 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
44999 RMSS(6)=SQRT(RMSS(6)**2+DL2)
45000 RMSS(7)=SQRT(RMSS(7)**2+DE2)
45001 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
45002 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
45003 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
45004 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
45005 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
45008 C...Fix the third generation sfermions.
45011 C...Fix the neutralino--chargino--gluino sector.
45014 C...Fix the Higgs sector.
45017 C...Choose the Gunion-Haber convention.
45021 C...Print information on mass parameters.
45022 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
45023 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45024 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
45025 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
45026 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
45027 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
45028 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
45029 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
45030 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
45031 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
45032 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45034 IF(IMSS(20).EQ.1) THEN
45035 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45036 WRITE(MSTU(11),*) ' DEBUG MODE '
45037 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
45038 & UMIX(2,1),UMIX(2,2)
45039 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
45040 & UMIXI(2,1),UMIXI(2,2)
45041 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
45042 & VMIX(2,1),VMIX(2,2)
45043 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
45044 & VMIXI(2,1),VMIXI(2,2)
45045 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
45046 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
45047 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
45048 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
45049 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
45050 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
45051 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
45052 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
45053 WRITE(MSTU(11),*) ' ALFA = ',ALFA
45054 WRITE(MSTU(11),*) ' BETA = ',BETA
45055 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
45056 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
45057 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45060 C...Set up the Higgs couplings - needed here since initialization
45061 C...in PYINRE did not yet occur when PYWIDT is called below.
45073 C2B=COSB**2-SINB**2
45074 C...tanb (used for H+)
45078 C...Coupling to d-type quarks
45079 PARU(161)=SINA/COSB
45080 C...Coupling to u-type quarks
45081 PARU(162)=-COSA/SINB
45082 C...Coupling to leptons
45083 PARU(163)=PARU(161)
45087 PARU(165)=PARU(164)
45090 C...Coupling to d-type quarks
45091 PARU(171)=-COSA/COSB
45092 C...Coupling to u-type quarks
45093 PARU(172)=-SINA/SINB
45094 C...Coupling to leptons
45095 PARU(173)=PARU(171)
45099 PARU(175)=PARU(174)
45101 IF(IMSS(4).GE.2) THEN
45102 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
45104 HHH(3)=HHH(3)+HHH(4)+HHH(5)
45105 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
45106 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
45107 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
45108 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
45112 IF(IMSS(4).GE.2) THEN
45113 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
45115 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
45116 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
45117 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
45118 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
45121 IF(IMSS(4).GE.2) THEN
45122 PARU(177)=COS(2D0*BE)*COS(BE+AL)
45124 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
45125 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
45126 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
45127 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
45130 IF(IMSS(4).GE.2) THEN
45131 PARU(178)=PARU(177)
45133 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
45136 C...Coupling to d-type quarks
45138 C...Coupling to u-type quarks
45139 PARU(182)=1D0/PARU(181)
45140 C...Coupling to leptons
45141 PARU(183)=PARU(181)
45144 C...Coupling to Z h
45145 PARU(186)=COS(BE-AL)
45146 C...Coupling to Z H
45147 PARU(187)=SIN(BE-AL)
45153 C...Coupling to W h
45154 PARU(195)=COS(BE-AL)
45156 C...Tell that all Higgs couplings have been set.
45159 C...Set R-Violating couplings.
45160 C...Set lambda couplings to common value or "natural values".
45161 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
45162 VIR3=1D0/(126D0)**3
45166 IF (IRI.NE.IRJ) THEN
45167 IF (IRI.LT.IRJ) THEN
45168 RVLAM(IRI,IRJ,IRK)=RMSS(51)
45169 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
45170 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
45171 & PMAS(9+2*IRK,1)*VIR3)
45173 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
45176 RVLAM(IRI,IRJ,IRK)=0D0
45182 C...Set lambda' couplings to common value or "natural values".
45183 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
45184 VIR3=1D0/(126D0)**3
45188 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
45189 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
45190 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
45191 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
45196 C...Set lambda'' couplings to common value or "natural values".
45197 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
45198 VIR3=1D0/(126D0)**3
45202 IF (IRJ.NE.IRK) THEN
45203 IF (IRJ.LT.IRK) THEN
45204 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
45205 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
45206 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
45207 & PMAS(2*IRK-1,1)*VIR3)
45209 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
45212 RVLAMB(IRI,IRJ,IRK) = 0D0
45219 C...Antisymmetrize couplings set by user
45220 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
45224 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
45225 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
45226 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
45228 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
45229 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
45230 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
45237 C...Write spectrum to SLHA file
45238 IF (IMSS(23).NE.0) THEN
45240 CALL PYSLHA(3,0,IFAIL)
45243 C...Second part of routine: set decay modes and branching ratios.
45245 C...Allow chi10 -> gravitino + gamma or not.
45246 KC=PYCOMP(KSUSY1+39)
45247 IF( IMSS(11) .NE. 0 ) THEN
45248 PMAS(KC,1)=RMSS(21)/1D9
45251 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
45252 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
45254 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
45255 & ' ALLOWING SUSY LLE DECAYS'
45256 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
45257 & ' ALLOWING SUSY LQD DECAYS'
45258 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
45259 & ' ALLOWING SUSY UDD DECAYS'
45260 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
45261 & ' --- Warning: R-Violating couplings possibly',
45262 & ' incompatible with proton decay'
45268 C...Loop over sparticle and Higgs species.
45269 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
45270 C...Find the LSP or NLSP for a gravitino LSP
45275 IF(KF.EQ.1000039) GOTO 300
45277 IF(PMAS(KC,1).LT.PMLSP) THEN
45283 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
45285 IF (KF.EQ.0) GOTO 370
45289 C...Check if there are any decays listed for this sparticle
45291 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
45293 CALL PYSLHA(2,KF,IFAIL)
45294 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
45295 ELSEIF (I.GE.37) THEN
45299 C...Sfermion decays.
45301 C...First check to see if sneutrino is lighter than chi10.
45302 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
45303 & PMAS(KC,1).LT.PMCHI1) THEN
45305 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
45309 ELSEIF(I.EQ.25) THEN
45310 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
45311 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
45313 C...Neutralino decays.
45314 ELSEIF(I.GE.26.AND.I.LE.29) THEN
45315 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
45316 C...chi10 stable or chi10 -> gravitino + gamma.
45317 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
45323 C...Chargino decays.
45324 ELSEIF(I.GE.30.AND.I.LE.31) THEN
45325 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
45327 C...Gravitino is stable.
45328 ELSEIF(I.EQ.32) THEN
45333 ELSEIF(I.GE.33.AND.I.LE.36) THEN
45334 C...Calculate decays to non-SUSY particles.
45335 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
45340 DO 330 I1=1,MDCY(KC,3)
45342 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
45343 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
45345 XLAM(0)=XLAM(0)+XLAM(I1)
45347 IDLAM(I1,J1)=KFDP(K1,J1)
45351 C...Add the decays to SUSY particles.
45352 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
45354 C...Zero the branching ratios for use in loop mode
45355 C...thanks to K. Matchev (FNAL)
45356 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45360 C...Set stable particles.
45368 C...Store branching ratios in the standard tables.
45370 IDC=MDCY(KC,2)+MDCY(KC,3)-1
45376 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
45377 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
45378 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
45379 BRAT(IDC)=XLAM(IL)/XLAM(0)
45381 IF(MDME(IDC,1).GE.1) THEN
45382 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
45383 & PMAS(PYCOMP(KFDP(IDC,2)),1)
45384 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
45385 & PMAS(PYCOMP(KFDP(IDC,3)),1)
45388 IF(XMDIF.GE.0D0) THEN
45389 DELM=MIN(DELM,XMDIF)
45391 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
45392 WRITE(MSTU(11),*) ' KF = ',KF
45393 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
45397 ELSEIF(IDC.EQ.IDCSV) THEN
45398 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
45399 & 'channel not recognized:'
45400 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
45407 C...Store width, cutoff and lifetime.
45409 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
45410 PMAS(KC,3)=PMAS(KC,2)*10D0
45412 PMAS(KC,3)=0.95D0*DELM
45414 IF(PMAS(KC,2).NE.0D0) THEN
45415 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
45417 C...Write decays to SLHA file
45418 IF (IMSS(24).NE.0) THEN
45420 CALL PYSLHA(4,KF,IFAIL)
45428 C*********************************************************************
45431 C...Read/write spectrum or decay data from SLHA standard file(s).
45434 C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
45435 C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
45436 C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
45437 C... (KFORIG=0 : read all decay tables)
45438 C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
45439 C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
45440 C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
45441 C... (KFORIG=0 : read all MASS entries)
45443 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
45445 C...Double precision and integer declarations.
45446 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45447 IMPLICIT INTEGER(I-N)
45448 INTEGER PYK,PYCHGE,PYCOMP
45449 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45450 &KEXCIT=4000000,KDIMEN=5000000)
45452 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45453 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45454 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45455 COMMON/PYDAT4/CHAF(500,2)
45457 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
45458 CHARACTER*40 ISAVER,VISAJE
45459 COMMON/PYINT4/MWID(500),WIDS(500,5)
45460 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
45462 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45463 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45464 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45465 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
45466 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
45468 C...Local arrays, character variables and data.
45469 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
45470 & AU(3,3),AD(3,3),AE(3,3)
45471 COMMON/PYLH3C/CPRO(2),CVER(2)
45472 C...The common block of new states (QNUMBERS / PARTICLE)
45473 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
45474 C...- NQNUM : Number of QNUMBERS blocks that have been read in
45475 C...- KQNUM(I,0) : KF of new state
45476 C...- KQNUM(I,1) : 3 times electric charge
45477 C...- KQNUM(I,2) : Number of spin states: (2S + 1)
45478 C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
45479 C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
45480 C...- KQNUM(I,5:9) : space available for further quantum numbers
45481 DIMENSION MMOD(100),MSPC(100),KFDEC(100)
45482 SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
45483 C...MMOD: flags to set for each block read in.
45484 C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
45485 C...MSPC: Flags to set for each block read in.
45486 C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
45487 C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
45488 C...11: AD 12: AE 13: YU 14: YD 15: YE
45489 C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
45490 CHARACTER CPRO*12,CVER*12,CHNLIN*6
45491 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
45492 CHARACTER CHINL*120,CHKF*9,CHTMP*16
45495 C...Date of last Change
45496 PARAMETER (DOC='13 Jul 2009')
45497 C...Local arrays and initial values
45498 DIMENSION IDC(5),KFSUSY(50)
45507 &1000001,1000002,1000003,1000004,1000005,1000006,
45508 &2000001,2000002,2000003,2000004,2000005,2000006,
45509 &1000011,1000012,1000013,1000014,1000015,1000016,
45510 &2000011,2000012,2000013,2000014,2000015,2000016,
45511 &1000021,1000022,1000023,1000025,1000035,1000024,
45512 &1000037,1000039, 25, 35, 36, 37,
45513 & 6, 24, 45, 46,1000045, 9*0/
45515 RMFUN(IP)=PMAS(PYCOMP(IP),1)
45517 C...Shorthand for spectrum and decay table unit numbers
45521 C...Default for LHEF input: read header information
45522 IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
45523 IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
45524 IF (IMSS21.EQ.MSTP(161).AND.IMSS21.NE.0) MLHEF=1
45525 IF (IMSS22.EQ.MSTP(161).AND.IMSS22.NE.0) MLHEFD=1
45528 IF (NHELLO.EQ.0) THEN
45529 IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
45530 WRITE(MSTU(11),5000) DOC
45535 C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
45538 IF (MUPDA.EQ.2) LFN=IMSS22
45539 IF (MUPDA.EQ.3) LFN=IMSS(23)
45540 IF (MUPDA.EQ.4) LFN=IMSS(24)
45541 C...Flag that we have not yet found whatever we were asked to find.
45543 C...Flag that we are skipping until <slha> tag found (if LHEF)
45545 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) ISKIP=1
45547 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
45549 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
45553 C...If reading LHEF header, start by rewinding file
45554 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
45556 C...If told to read spectrum, first zero all previous information.
45557 IF (MUPDA.EQ.1) THEN
45558 C...Zero all block read flags
45563 C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
45565 KC=PYCOMP(KFSUSY(ISUSY))
45568 C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
45576 IF (J.LE.2.AND.L.LE.2) THEN
45583 C...Zero signed masses.
45585 IF (J.LE.2) SMW(J)=0D0
45588 C...If reading decays, reset PYTHIA decay counters.
45589 ELSEIF (MUPDA.EQ.2) THEN
45590 C...Check if DECAY for this KF already read
45591 IF (KFORIG.NE.0) THEN
45592 DO 140 IDEC=1,NDECAY
45593 IF (KFORIG.EQ.KFDEC(IDEC)) THEN
45602 DO 150 KC=1,MSTU(6)
45603 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
45604 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
45606 ELSEIF (MUPDA.EQ.5) THEN
45607 C...Zero block read flags
45614 C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
45615 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
45616 C...Initialize program and version strings
45617 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
45622 C...Initialize read loop
45626 C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
45628 READ(LFN,'(A120)',END=400) CHINL
45629 C...Count which line number we're at.
45631 WRITE(CHNLIN,'(I6)') NLINE
45633 C...Skip comment and empty lines without processing.
45634 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
45636 C...We assume all upper case below. Rewrite CHINL to all upper case.
45640 IF (CHINL(INL:INL).NE.'#') THEN
45642 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
45644 C...Extra safety. Chek for sensible input on line
45645 IF (IGOOD.EQ.0) THEN
45647 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
45650 IF (INL.LT.120) GOTO 180
45652 IF (IGOOD.EQ.0) GOTO 170
45654 C...If reading from LHEF file, skip until <slha> begin tag found
45655 IF (ISKIP.NE.0) THEN
45657 IF (CHINL(I1:I1+4).EQ.'<SLHA') ISKIP=0
45659 IF (ISKIP.NE.0) GOTO 170
45662 C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
45664 IF (CHINL(I1:I1+5).EQ.'</SLHA'
45665 & .OR.CHINL(I1:I1+5).EQ.'<EVENT'
45666 & .OR.CHINL(I1:I1+4).EQ.'<INIT') THEN
45672 C...Check for BLOCK begin statement (spectrum).
45673 IF (CHINL(1:5).EQ.'BLOCK') THEN
45675 READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
45676 C...Check if another of this type of block was already read.
45677 C...(logarithmic interpolation not yet implemented, so duplicates always
45679 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
45680 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
45681 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
45682 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
45683 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
45684 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
45685 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
45686 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
45687 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
45688 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
45689 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
45690 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
45691 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
45692 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
45693 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
45694 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
45695 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
45696 C...Check for new particles
45697 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
45699 MSPC(19)=MSPC(19)+1
45701 READ(CHBLCK(9:60),*) KFQ
45704 IF (KQNUM(MQ,0).EQ.KFQ) THEN
45709 IF (NHELLO.EQ.0) THEN
45710 WRITE(MSTU(11),5000) DOC
45713 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45714 & ' * (PYSLHA:) Reading '//CHBLCK(1:8)//
45718 MSPC(19)=MSPC(19)+1
45720 C...Only read in new codes (also OK to overwrite if KF > 3000000)
45721 IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
45723 DO 230 KCT=100,MSTU(6)
45724 IF(KCHG(KCT,4).GT.100) KCQ=KCT
45730 C...First write PDG code as name
45732 WRITE(CHTMP,'(A)') CHTMP(2:10)
45733 C...Then look for real name
45736 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
45738 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
45741 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
45742 IF (IEND.LT.59) THEN
45743 READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
45744 IF (CHDUM.NE.' ') CHTMP=CHDUM
45746 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
45748 C...Set stable for now
45756 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
45757 & CHAF(KCQ,1), '. Entry ignored.'
45761 C...Finalize this line and read next.
45763 C...Check for DECAY begin statement (decays).
45764 ELSEIF (CHINL(1:3).EQ.'DEC') THEN
45768 C...Read KF code and WIDTH
45770 READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
45775 C...If this is not the KF we're looking for...
45776 IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
45777 C...Set block skip flag and read next line.
45781 C...Check whether decay table for this particle already read in
45782 DO 280 IDECAY=1,NDECAY
45783 IF (KFDEC(IDECAY).EQ.KF) THEN
45784 WRITE(MSTU(11),'(A,A,I9,A,A6,A)')
45785 & ' * (PYSLHA:) Ignoring DECAY table ',
45786 & 'for KF =',KF,' on line ',CHNLIN,
45794 C...Determine PYTHIA KC code of particle
45800 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
45804 IF (KCREP.NE.0) THEN
45805 C...Particle is already known. Do not overwrite low-mass SM particles,
45806 C...since this could give problems at hadronization / hadron decay stage.
45807 IF (IABS(KF).LT.1000000.AND.PMAS(KC,1).LT.20D0) THEN
45808 C...Set block skip flag and read next line
45809 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45810 & ' * (PYSLHA:) Ignoring DECAY table for KF =',
45811 & KF, ' (SLHA read-in not allowed)'
45816 C... Add new particle. Actually, this should not happen.
45817 C... New particles should be added already when reading the spectrum
45818 C... information, so go under previously stable category.
45823 IF (WIDTH.LE.0D0) THEN
45824 C...Stable (i.e. LSP)
45825 WRITE(MSTU(11),'(A,I9,A,A)')
45826 & ' * (PYSLHA:) Reading SLHA stable particle KF =',
45827 & KF,', ',CHAF(KCREP,1)(1:16)
45828 IF (WIDTH.LT.0D0) THEN
45829 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
45836 C...Ignore any decay lines that may be present for this KF
45843 C...Finalize and start reading in decay modes.
45845 ELSEIF (MOD(MERR,10).GE.6) THEN
45846 C...If ignore block flag set, skip directly to next line.
45851 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
45852 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
45854 READ(CHINL,*) INDX, IVAL
45855 IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
45856 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
45857 IF (INDX.EQ.3) KCHG(KCQ,2)=0
45858 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
45859 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
45860 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
45861 IF (INDX.EQ.4) THEN
45863 IF (IVAL.EQ.1) THEN
45865 IF (CHTMP.EQ.' ') THEN
45866 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
45867 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
45871 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
45872 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
45873 CHTMP(ILAST:ILAST)='-'
45875 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
45884 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
45885 C...MASS: Mass spectrum
45886 IF (CHBLCK(1:4).EQ.'MASS') THEN
45887 READ(CHINL,*) KF, VAL
45890 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
45891 C...Read in masses for almost anything
45895 C...Don't read in masses for special code particles
45896 IF (IABS(KF).GE.80.AND.IABS(KF).LT.100) THEN
45897 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45898 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45899 & KF, ' (KF reserved by PYTHIA)'
45902 C...Be careful with light SM particles / hadrons
45903 IF (PMAS(KC,1).LE.20D0) THEN
45904 IF (IABS(KF).LE.22) THEN
45905 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45906 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45907 & KF, ' (SLHA read-in not allowed)'
45910 ELSEIF (IABS(KF).GE.100.AND.IABS(KF).LT.1000000) THEN
45911 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45912 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45913 & KF, ' (SLHA read-in not allowed)'
45918 PMAS(KC,1) = ABS(VAL)
45919 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
45920 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45921 & ' * (PYSLHA:) Reading MASS entry for KF =',
45922 & KF, ', pole mass =', VAL
45925 C...Check Z, W and top masses
45926 IF (KF.EQ.23.AND.ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0)
45928 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45929 CALL PYERRM(9,'(PYSLHA:) Note Z boson mass, M ='
45932 IF (KF.EQ.24.AND.ABS(PMAS(PYCOMP(24),1)-80.4D0).GT.1D0)
45934 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45935 CALL PYERRM(9,'(PYSLHA:) Note W boson mass, M ='
45938 IF (KF.EQ.6.AND.ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0)
45940 WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
45941 CALL PYERRM(9,'(PYSLHA:) Note top quark mass, M ='
45945 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
45946 IF (KF.EQ.1000022) SMZ(1)=VAL
45947 IF (KF.EQ.1000023) SMZ(2)=VAL
45948 IF (KF.EQ.1000025) SMZ(3)=VAL
45949 IF (KF.EQ.1000035) SMZ(4)=VAL
45950 IF (KF.EQ.1000024) SMW(1)=VAL
45951 IF (KF.EQ.1000037) SMW(2)=VAL
45953 ELSEIF (MUPDA.EQ.5) THEN
45956 C... MODSEL: Model selection and global switches
45957 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
45958 READ(CHINL,*) INDX, IVAL
45959 IF (INDX.LE.200.AND.INDX.GT.0) THEN
45960 IF (IMSS(1).EQ.0) IMSS(1)=11
45963 IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
45964 C... Switch on NMSSM
45965 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
45966 IMSS(13)=MAX(1,IMSS(13))
45967 C... Add NMSSM states if not already done
45997 DO 310 KCT=100,MSTU(6)
45998 IF(KCHG(KCT,4).GT.100) KCN=KCT
46004 C... Set stable for now
46010 CHAF(KCN,1)='~chi_50'
46016 ELSEIF (MUPDA.EQ.5) THEN
46017 C...If MUPDA = 5, skip all except MASS, return if MODSEL
46019 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
46020 & CHBLCK(1:8).EQ.'PARTICLE') THEN
46021 C...Don't print a warning for QNUMBERS when reading spectrum
46023 C...MINPAR: Minimal model parameters
46024 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
46025 READ(CHINL,*) INDX, VAL
46026 IF (INDX.LE.100.AND.INDX.GT.0) THEN
46032 IF (MMOD(3).NE.0) THEN
46034 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
46038 IF (INDX.EQ.3) RMSS(5)=VAL
46039 C...EXTPAR: non-minimal model parameters.
46040 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
46041 IF (MMOD(1).NE.0) THEN
46042 READ(CHINL,*) INDX, VAL
46043 IF (INDX.LE.200.AND.INDX.GT.0) THEN
46051 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
46055 IF (INDX.EQ.25) RMSS(5)=VAL
46056 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
46057 READ(CHINL,*) INDX, VAL
46058 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
46060 ELSEIF (INDX.EQ.4) THEN
46061 PMAS(PYCOMP(23),1)=VAL
46062 ELSEIF (INDX.EQ.6) THEN
46063 PMAS(PYCOMP(6),1)=VAL
46065 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
46066 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
46067 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
46069 C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
46071 IF (CHBLCK(5:6).EQ.'IM') IM=1
46072 320 READ(CHINL,*) INDX1, INDX2, VAL
46073 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
46074 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
46075 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
46077 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
46078 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
46079 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
46081 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
46082 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
46083 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
46085 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
46086 $ .CHBLCK(1:4).EQ.'STAU') THEN
46087 IF (CHBLCK(1:4).EQ.'STOP') THEN
46090 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
46093 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
46097 C...Set SFMIX element
46098 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
46099 MSPC(ISPC)=MSPC(ISPC)+1
46101 C...Running parameters
46102 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
46103 READ(CHBLCK(8:25),*,ERR=620) Q
46104 READ(CHINL,*) INDX, VAL
46106 IF (INDX.EQ.1) THEN
46112 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
46113 READ(CHINL,*,ERR=630) VAL
46115 MSPC(17)=MSPC(17)+1
46116 C...Higgs parameters set manually or with FeynHiggs.
46117 IMSS(4)=MAX(2,IMSS(4))
46118 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
46119 & .CHBLCK(1:2).EQ.'AE') THEN
46120 READ(CHBLCK(9:26),*,ERR=620) Q
46121 READ(CHINL,*) INDX1, INDX2, VAL
46122 IF (CHBLCK(2:2).EQ.'U') THEN
46123 AU(INDX1,INDX2)=VAL
46124 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
46125 MSPC(11)=MSPC(11)+1
46126 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
46127 AD(INDX1,INDX2)=VAL
46128 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
46129 MSPC(10)=MSPC(10)+1
46130 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
46131 AE(INDX1,INDX2)=VAL
46132 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
46133 MSPC(12)=MSPC(12)+1
46137 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
46138 IF (MSPC(18).EQ.0) THEN
46139 READ(CHBLCK(9:25),*,ERR=620) Q
46142 READ(CHINL,*) INDX, VAL
46144 MSPC(18)=MSPC(18)+1
46145 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
46147 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
46148 & .CHBLCK(1:2).EQ.'YE') THEN
46150 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
46151 READ(CHINL(1:6),*) INDX
46155 IF (CHINL(IT:IT).EQ.' ') GOTO 330
46156 C...Don't read index
46157 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
46161 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
46162 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
46164 C... Set unrecognized block flag.
46169 C...Read in decay information
46170 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
46171 C...Read new decay chanel
46172 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
46174 C...Read in branching ratio and number of daughters for this mode.
46175 READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
46176 READ(CHINL(4:50),*,ERR=600) DUM, NDA
46178 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
46179 & '(PYSLHA:) Decay data arrays full by KF = '
46181 C...If first decay channel, set decays start point in decay table
46182 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
46183 IF (KFORIG.EQ.0) WRITE(MSTU(11),'(1x,A,I9,A,A16)')
46184 & '* (PYSLHA:) Reading DECAY table for '//
46185 & 'KF =',KF,', ',CHAF(KCREP,1)(1:16)
46186 C...Set particle parameters (mass set when reading BLOCK MASS above)
46188 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
46189 WRITE(MSTU(11),'(1x,A)')
46190 & '* Note: the Pythia gg->h/H/A cross section'//
46191 & ' is proportional to the h/H/A->gg width'
46192 ELSEIF (KF.EQ.23.OR.KF.EQ.24.OR.KF.EQ.6.OR.KF.EQ.32
46193 & .OR.KF.EQ.33.OR.KF.EQ.34) THEN
46194 WRITE(MSTU(11),'(1x,A,A16)')
46195 & '* Warning: will use DECAY table (fixed-width,'//
46196 & ' flat PS) for ',CHAF(KC,1)(1:16)
46199 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
46204 C...Add to list of DECAY blocks currently read
46210 C... Count up number of decay modes for this particle
46211 MDCY(KC,3)=MDCY(KC,3)+1
46212 C... Read in decay daughters.
46213 READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
46214 C... Flip sign if reading antiparticle decays (if antipartner exists)
46216 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
46217 & IDC(IDA)=MPSIGN*IDC(IDA)
46219 C...Switch on decay channel, with products ordered in decreasing ABS(KF)
46221 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
46222 BRSUM=BRSUM+ABS(BRAT(NDC))
46223 BRAT(NDC)=ABS(BRAT(NDC))
46226 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
46228 IDC(IDA)=IDC(IDA+1)
46233 IF (IFLIP.GT.0) GOTO 350
46234 C...Treat as ordinary decay, no fancy stuff.
46237 IF (IDA.LE.NDA) THEN
46238 KFDP(NDC,IDA)=IDC(IDA)
46243 C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
46244 C & (KFDP(NDC,J),J=1,NDA)
46246 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '//
46251 ELSEIF(CHINL(1:1).EQ.'+') THEN
46253 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
46260 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
46261 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
46264 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
46265 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
46266 & CHBLCK(1:MIN(INL,40))//'... on line '//CHNLIN
46267 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
46268 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
46269 & //CHBLCK(1:INL)//'... on line'//CHNLIN
46270 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
46271 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
46272 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
46273 & //'... on line'//CHNLIN
46274 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
46275 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
46276 & /CHBLCK(1:INL)//'... on line'//CHNLIN
46277 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
46280 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
46281 & CHTMP(1:9)//' on line'//CHNLIN
46283 C...Iterate read loop
46286 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
46287 & ', ignoring subsequent lines.'
46288 WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
46291 C...End of read loop
46293 C...Set flag that KC codes have been rearranged.
46297 C...Perform possible tests that new information is consistent.
46298 IF (MUPDA.EQ.1) THEN
46304 C...Don't complain about right-handed neutrinos
46305 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
46307 C...Only check gravitino in GMSB scenarios
46308 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
46310 IF (PMAS(KC,1).EQ.0D0) THEN
46313 & ,'(PYSLHA:) No mass information found for KF ='
46317 C...Check mixing matrices (MSSM only)
46318 IF (IMSS(13).EQ.0) THEN
46319 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
46320 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
46321 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
46322 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
46323 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
46324 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
46325 IF (MSPC(5).NE.4) CALL PYERRM(9
46326 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
46327 IF (MSPC(6).NE.4) CALL PYERRM(9
46328 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
46329 IF (MSPC(7).NE.4) CALL PYERRM(9
46330 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
46331 IF (MSPC(8).LT.1) CALL PYERRM(9
46332 & ,'(PYSLHA:) Too few elements in HMIX')
46333 IF (MSPC(10).EQ.0) CALL PYERRM(9
46334 & ,'(PYSLHA:) Missing A_b trilinear coupling')
46335 IF (MSPC(11).EQ.0) CALL PYERRM(9
46336 & ,'(PYSLHA:) Missing A_t trilinear coupling')
46337 IF (MSPC(12).EQ.0) CALL PYERRM(9
46338 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
46339 IF (MSPC(17).LT.1) CALL PYERRM(9
46340 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
46342 C...Check wavefunction normalizations.
46345 IF (MSPC(ISPC).EQ.4) THEN
46347 IF (ISPC.EQ.7) KFSM=15
46348 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
46350 IF (ABS(1D0-CHECK).GT.1D-3) THEN
46353 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
46356 C...Bug fix 30/09 2008: PS
46357 C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
46358 IF (SFMIX(KFSM,1)*SFMIX(KFSM,4).LT.0D0) THEN
46359 SFMIX(KFSM,3) = -SFMIX(KFSM,3)
46360 SFMIX(KFSM,4) = -SFMIX(KFSM,4)
46364 C...Neutralinos + charginos
46373 CN1=CN1+ZMIX(J,L)**2
46374 CN2=CN2+ZMIX(L,J)**2
46375 IF (J.LE.2.AND.L.LE.2) THEN
46376 CU1=CU1+UMIX(J,L)**2
46377 CU2=CU2+UMIX(L,J)**2
46378 CV1=CV1+VMIX(J,L)**2
46379 CV2=CV2+VMIX(L,J)**2
46382 C...NMIX normalization
46383 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
46384 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
46386 & '(PYSLHA:) NMIX: Inconsistent normalization.')
46387 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
46389 C...UMIX, VMIX normalizations
46390 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
46392 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
46394 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
46395 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
46398 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
46400 & '(PYSLHA:) VMIX: Inconsistent normalization.')
46401 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
46407 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
46408 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
46409 & '* (PYSLHA:) No spectrum inconsistencies were found.'
46411 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
46412 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
46413 & ,' Warning: one or more (serious)'//
46414 & ' inconsistencies were found in the spectrum !'
46415 & ,' Read the error messages above and check your'//
46418 C...Increase precision in Higgs sector using FeynHiggs
46419 IF (IMSS(4).EQ.3) THEN
46420 C...FeynHiggs needs MSOFT.
46422 IF (MSPC(18).EQ.0) THEN
46423 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
46424 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
46425 & ' Cannot call FeynHiggs.'
46428 WRITE(MSTU(11),'(1x,/1x,A/)')
46429 & '* (PYSLHA:) Now calling FeynHiggs.'
46431 IF (IERR.NE.0) IMSS(4)=2
46434 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
46436 IF (KFORIG.NE.0) IBEG=NDECAY
46437 DO 490 IDECAY=IBEG,NDECAY
46440 WRITE(CHKF,8300) KF
46441 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
46442 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
46443 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
46444 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
46448 DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46449 IF(MDME(IDA,2).GT.80) GOTO 460
46451 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
46455 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
46457 ELSEIF(PYCOMP(KP).EQ.0) THEN
46462 PMS=PMS-PMAS(KPC,1)
46463 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
46467 IF(KQ.NE.0) MERR=MAX(2,MERR)
46468 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
46470 IF(MERR.EQ.3) CALL PYERRM(17,
46471 & '(PYSLHA:) Unknown particle code in decay of KF ='
46473 IF(MERR.EQ.2) CALL PYERRM(17,
46474 & '(PYSLHA:) Charge not conserved in decay of KF ='
46476 IF(MERR.EQ.1) CALL PYERRM(7,
46477 & '(PYSLHA:) Kinematically unallowed decay of KF ='
46479 BRSUM=BRSUM+BRAT(IDA)
46480 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
46482 C...Check branching ratio sum.
46483 IF (BROPN.LE.0D0) THEN
46484 C...If zero, set stable.
46485 WRITE(CHTMP,8500) BROPN
46487 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
46488 & CHTMP(9:16)//'. Changed to stable.')
46491 C...If BR's > 1, rescale.
46492 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
46493 WRITE(CHTMP,8500) BRSUM
46494 IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
46495 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
46496 & ' ; sum was'//CHTMP(9:16)//'.')
46498 DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46499 IF(MDME(IDA,2).GT.80) GOTO 470
46500 BRAT(IDA)=FAC*BRAT(IDA)
46502 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
46503 C...If BR's < 1, insert dummy mode for proper cross section rescaling.
46504 WRITE(CHTMP,8500) BRSUM
46505 IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
46506 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
46507 & CHTMP(9:16)//'. Dummy mode will be inserted.')
46508 C...Move table and insert dummy mode
46509 DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46511 BRAT(NDC)=BRAT(IDA)
46512 KFDP(NDC,1)=KFDP(IDA,1)
46513 KFDP(NDC,2)=KFDP(IDA,2)
46514 KFDP(NDC,3)=KFDP(IDA,3)
46515 KFDP(NDC,4)=KFDP(IDA,4)
46516 KFDP(NDC,5)=KFDP(IDA,5)
46517 MDME(NDC,1)=MDME(IDA,1)
46520 BRAT(NDC)=1D0-BRSUM
46529 MDCY(KC,3)=MDCY(KC,3)+1
46530 MDCY(KC,2)=NDC-MDCY(KC,3)+1
46536 C...WRITE SPECTRUM ON SLHA FILE
46537 ELSEIF(MUPDA.EQ.3) THEN
46538 C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
46539 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
46544 PARMIN(4)=SIGN(1D0,RMSS(4))
46548 WRITE(LFN,7000) 'SLHA MSSM spectrum'
46549 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
46551 WRITE(LFN,7010) 'MODSEL', 'Model selection'
46552 WRITE(LFN,7110) 1, MODSEL(1)
46553 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
46554 IF (MODSEL(1).EQ.1) THEN
46555 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
46556 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
46557 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
46558 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
46559 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
46560 ELSEIF(MODSEL(2).EQ.2) THEN
46561 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
46562 WRITE(LFN,7210) 2, PARMIN(2), 'M'
46563 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
46564 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
46565 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
46566 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
46568 WRITE(LFN,7000) ' '
46569 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
46573 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
46575 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
46576 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
46577 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
46578 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
46579 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
46580 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
46581 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
46583 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
46587 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
46588 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
46589 WRITE(LFN,7210) 1, RMSS(4),'mu'
46590 WRITE(LFN,7010) 'ALPHA',' '
46591 WRITE(LFN,7210) 1, RMSS(18), 'alpha'
46592 WRITE(LFN,7020) 'AU',RMSUSY
46593 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
46594 WRITE(LFN,7020) 'AD',RMSUSY
46595 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
46596 WRITE(LFN,7020) 'AE',RMSUSY
46597 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
46598 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
46599 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
46600 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
46601 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
46602 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
46603 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
46604 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
46605 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
46606 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
46607 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
46608 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
46609 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
46610 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
46611 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
46612 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
46613 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
46616 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
46619 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
46622 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
46625 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
46628 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
46631 WRITE(LFN,7010) 'SPINFO'
46632 IF (IMSS(1).EQ.2) THEN
46635 ELSEIF (IMSS(1).EQ.12) THEN
46638 CVER(1)=ISAVER(1:12)
46640 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
46641 WRITE(LFN,7310) 2, CVER(1), 'Version number'
46644 C...Print user information about spectrum
46645 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
46646 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
46647 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
46648 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
46649 IF (MUPDA.EQ.1) THEN
46650 WRITE(MSTU(11),5020) LFN
46652 WRITE(MSTU(11),5010) LFN
46655 WRITE(MSTU(11),5400)
46656 WRITE(MSTU(11),5500) 'Pole masses'
46657 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
46658 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
46659 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
46660 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
46661 IF (IMSS(13).EQ.0) THEN
46662 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
46663 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
46664 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
46665 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
46666 & CHAF(37,1), ' ', ' ',' ',' ',
46667 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
46668 ELSEIF (IMSS(13).EQ.1) THEN
46677 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
46678 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
46679 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
46680 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
46681 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
46682 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
46683 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
46684 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
46685 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
46688 WRITE(MSTU(11),5400)
46689 WRITE(MSTU(11),5500) 'Mixing structure'
46690 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
46691 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
46692 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
46693 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
46694 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
46695 & ),(SFMIX(15,J),J=3,4)
46696 WRITE(MSTU(11),5400)
46697 WRITE(MSTU(11),5500) 'Couplings'
46698 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
46699 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
46700 WRITE(MSTU(11),5400)
46701 WRITE(MSTU(11),6500)
46705 C...Only rewind when reading
46706 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
46710 C...Serious error catching
46711 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
46712 write(*,*) CHINL(1:80)
46714 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
46715 WRITE(*,*) CHINL(1:72)
46717 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
46718 WRITE(*,*) CHINL(1:80)
46720 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
46721 WRITE(*,*) CHINL(1:80)
46722 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
46724 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
46725 WRITE(*,*) CHINL(1:80)
46731 C...Formats for user information printout.
46732 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.13: SUSY/BSM SPECTRUM '
46733 & ,'INTERFACE',1x,17('*')/1x,'*',1x
46734 & ,'(PYSLHA:) Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
46735 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
46736 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
46737 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
46738 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
46739 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
46740 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
46741 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
46742 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
46743 & ,'----------------')
46744 5400 FORMAT(1x,'*',1x,A)
46745 5500 FORMAT(1x,'*',1x,A,':')
46746 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
46747 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
46748 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
46749 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
46750 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
46751 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
46752 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
46753 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
46754 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
46755 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
46756 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
46757 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
46758 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
46759 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
46760 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
46761 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
46762 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
46763 & ,1x,F6.3,1x),'|')
46764 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
46765 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
46766 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
46767 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
46768 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
46769 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
46770 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
46771 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
46772 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
46773 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
46774 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
46775 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
46776 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
46777 & ,'A_tau = ',F8.2)
46778 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
46780 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
46782 C...Format to use for comments
46783 7000 FORMAT('# ',A)
46784 C...Format to use for block statements
46785 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
46786 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
46788 7110 FORMAT(1x,I4,1x,I4,3x,'#')
46789 C...Non-Indexed Double
46790 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
46792 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
46793 C...Long Indexed Double (PDG + double)
46794 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
46795 C...Indexed Char(12)
46796 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
46798 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
46800 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
46801 C...Write Decay Table
46802 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
46803 7510 FORMAT(4x,I5,1x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),
46809 C*********************************************************************
46812 C...Uses approximate analytical formulae to determine the full set of
46813 C...MSSM parameters from SUGRA input.
46814 C...See M. Drees and S.P. Martin, hep-ph/9504124
46818 C...Double precision and integer declarations.
46819 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46820 IMPLICIT INTEGER(I-N)
46821 INTEGER PYK,PYCHGE,PYCOMP
46822 C...Parameter statement to help give large particle numbers.
46823 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46824 &KEXCIT=4000000,KDIMEN=5000000)
46826 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46827 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46828 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46829 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
46831 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
46832 &' not intended for serious physics studies'
46845 C...Temporary sign change for AT. Others unchanged.
46849 SINB=TANB/SQRT(TANB**2+1D0)
46852 DTERM=XMZ2*COS(2D0*BETA)
46853 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
46854 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
46857 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
46858 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
46859 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
46860 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
46862 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
46863 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
46864 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
46865 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
46867 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
46868 IF(XARG.LT.0D0) THEN
46869 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
46870 & ' FROM THE SUM RULE. '
46871 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
46877 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
46878 PMAS(PYCOMP(KSUSY2+I),1)=XMER
46879 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
46880 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
46882 RMT=PYMRUN(6,PMAS(6,1)**2)
46883 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
46884 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
46885 RMB=PYMRUN(5,PMAS(6,1)**2)
46886 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
46887 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
46888 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
46889 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
46892 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
46893 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
46894 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
46895 XMU=SIGN(SQRT(XMU2),RMSS(4))
46897 IF(XMA2.GT.0D0) THEN
46898 RMSS(19)=SQRT(XMA2)
46900 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
46903 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
46904 IF(ARG.GT.0D0) THEN
46907 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
46910 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
46911 IF(ARG.GT.0D0) THEN
46914 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
46917 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
46918 IF(ARG.GT.0D0) THEN
46921 RMSS(10)=-SQRT(-ARG)
46923 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
46924 IF(ARG.GT.0D0) THEN
46927 RMSS(12)=-SQRT(-ARG)
46929 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
46930 IF(ARG.GT.0D0) THEN
46933 RMSS(11)=-SQRT(-ARG)
46939 C*********************************************************************
46942 C...Interface to ISASUSY version 7.71.
46943 C...Warning: this interface should not be used with earlier versions
46944 C...of ISASUSY, since common block incompatibilities may then arise.
46945 C...Calls SUGRA (in ISAJET) to perform RGE evolution.
46946 C...Then converts to Gunion-Haber conventions.
46949 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46951 INTEGER PYK,PYCHGE,PYCOMP
46952 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46953 &KEXCIT=4000000,KDIMEN=5000000)
46957 PARAMETER (DOC='01 May 2006')
46959 C...ISASUGRA Input:
46960 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
46961 C...XISAIN contains the MSSMi inputs in natural order.
46962 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
46964 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
46966 C...ISASUGRA Output
46967 CHARACTER*40 ISAVER,VISAJE
46969 COMMON /SSPAR/ SUPER(72)
46970 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
46971 $FBGUT,FTAGUT,FNGUT
46972 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
46973 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46974 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46975 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
46976 $VUMT,VDMT,ASMTP,ASMSS,M3Q
46977 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46978 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46979 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
46980 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
46982 SAVE /SUGMG/,/SSPAR/
46983 C SUPER: Filled by ISASUGRA.
46984 C SUPER(1) = mass of ~g
46985 C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
46986 C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
46987 C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
46989 C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
46990 C SUPER(29) = Higgsino mass = - mu
46991 C SUPER(30) = ratio v2/v1 of vev's
46992 C SUPER(31:34) = Signed neutralino masses
46993 C SUPER(35:50) = Neutralino mixing matrix
46994 C SUPER(51:52) = Signed chargino masses
46995 C SUPER(53:54) = Chargino left, right mixing angles
46996 C SUPER(55:58) = mass of h0, H0, A0, H+
46997 C SUPER(59) = Higgs mixing angle alpha
46998 C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
46999 C SUPER(66) = Gravitino mass
47000 C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
47001 C SUPER(70) = b-Yukawa at mA scale (not used)
47002 C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
47003 C GSS: Filled by ISASUGRA
47004 C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
47005 C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
47006 C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
47007 C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
47008 C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
47009 C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
47010 C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
47011 C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
47012 C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
47013 C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
47014 C GSS(31) = log(vuq)
47015 C MSS: Filled by ISASUGRA
47016 C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
47017 C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
47018 C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
47019 C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
47020 C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
47021 C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
47022 C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
47023 C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
47024 C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
47025 C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
47026 C MSS(31) = ha0 MSS(32) = h+
47027 C Unification, filled by ISASUGRA if applicable.
47028 C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
47030 C...SPYTHIA Input/Output
47032 DOUBLE PRECISION RMSS
47033 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47034 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47035 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47036 C...SLHA Input/Output
47037 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47038 & AU(3,3),AD(3,3),AE(3,3)
47039 C...PYTHIA common blocks
47040 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47041 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47042 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47044 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
47045 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47048 CHARACTER*20 CHMOD(5)
47051 COMMON /SUGNU/ XNUSUG(18)
47055 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
47056 & 'truly unified SUGRA', 'non-minimal GMSB'/
47058 C...Start by checking for incompatibilities/inconsistencies:
47060 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
47061 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
47062 & ,' option not used by PYSUGI'
47065 C...ISAJET works with REAL numbers.
47066 MZERO=REAL(RMSS(8))
47068 AZERO=REAL(RMSS(16))
47070 SGNMU=REAL(RMSS(4))
47071 MTOP=REAL(PMAS(6,1))
47073 IF (IMSS(1).EQ.12) THEN
47076 ELSEIF(IMSS(1).EQ.13) THEN
47077 C...Read from isajet par file in IMSS(20)
47079 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
47081 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
47084 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
47085 CMrenna change to allow any susy model
47086 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
47087 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
47088 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
47089 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
47090 & ' gauge couplings:'
47091 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
47093 IF (IMODEL.EQ.4) THEN
47097 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
47098 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
47099 & //' sgn(mu), M_t:'
47100 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
47101 IF (IMODEL.EQ.3) THEN
47103 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
47104 & //' 0 to continue:'
47105 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
47106 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
47107 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
47108 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
47109 & //' generation masses'
47111 & ' NUSUG5 = GUT scale 3rd generation masses'
47113 IF (INUSUG.EQ.0) THEN
47115 ELSEIF (INUSUG.EQ.1) THEN
47116 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
47117 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
47118 IF (XNUSUG(3).LE.0.) THEN
47119 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
47122 ELSEIF (INUSUG.EQ.2) THEN
47123 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
47124 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
47125 ELSEIF (INUSUG.EQ.3) THEN
47126 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
47127 READ(LFN,*) XNUSUG(7),XNUSUG(8)
47128 ELSEIF (INUSUG.EQ.4) THEN
47129 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
47130 & //' M(ur), M(el), M(er):'
47131 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
47132 & XNUSUG(10),XNUSUG(9)
47133 ELSEIF (INUSUG.EQ.5) THEN
47134 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
47135 & //' M(Ll), M(Lr):'
47136 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
47137 & XNUSUG(15),XNUSUG(14)
47141 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
47143 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
47144 & ,' sgn(mu), M_t, C_gv:'
47145 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
47148 C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
47150 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
47151 IF (IMODEL.EQ.5) THEN
47153 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
47154 & ,' masses at M_mes'
47155 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
47156 & ,' shifts at M_mes'
47157 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
47159 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
47161 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
47163 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
47164 $ XGMIN(13),XGMIN(14)
47167 WRITE(MSTU(11),*) 'Invalid model choice.'
47175 C TANB=REAL(RMSS(5))
47176 C SGNMU=REAL(RMSS(4))
47179 C...Initialize MSSM parameter array
47180 130 DO 140 IPAR=1,72
47184 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
47185 C...Check whether ISASUSY thought the model was OK.
47186 IF (NOGOOD.NE.0) THEN
47187 IF (NOGOOD.EQ.1) CALL PYERRM(26
47188 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
47189 IF (NOGOOD.EQ.2) CALL PYERRM(26
47190 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
47191 IF (NOGOOD.EQ.3) CALL PYERRM(26
47192 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
47193 IF (NOGOOD.EQ.4) CALL PYERRM(26
47194 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
47195 IF (NOGOOD.EQ.7) CALL PYERRM(26
47196 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
47197 IF (NOGOOD.EQ.8) CALL PYERRM(26
47198 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
47199 C...Give warning, but don't stop, if LSP not ~chi_10.
47200 IF (NOGOOD.EQ.5) CALL PYERRM(16
47201 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
47203 C...Warn about possible GUT scale tachyons.
47204 IF (ITACHY.NE.0) CALL PYERRM(16,
47205 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
47206 C...Finalize spectrum (last iteration)
47207 C...(Thanks to A. Raklev for pointing this out.)
47208 C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
47209 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
47210 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
47211 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
47212 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
47213 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
47217 RMSS(1)=dble(GSS(7))
47218 RMSS(2)=dble(GSS(8))
47219 RMSS(3)=dble(GSS(9))
47220 RMSOFT(1)=dble(GSS(7))
47221 RMSOFT(2)=dble(GSS(8))
47222 RMSOFT(3)=dble(GSS(9))
47223 C...Mu = - Higgsino mass.
47226 C...Slepton and squark masses. 2 first generations.
47227 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
47228 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
47229 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
47230 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
47231 C...Third generation.
47232 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
47237 C...SLHA: store exact soft spectrum in RMSOFT
47238 RMSOFT(31)=SUPER(18)
47239 RMSOFT(32)=SUPER(20)
47240 RMSOFT(33)=SUPER(22)
47241 RMSOFT(34)=SUPER(19)
47242 RMSOFT(35)=SUPER(21)
47243 RMSOFT(36)=SUPER(23)
47244 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
47245 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
47246 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
47247 RMSOFT(44)=SUPER(3)
47248 RMSOFT(45)=SUPER(9)
47249 RMSOFT(46)=SUPER(15)
47250 RMSOFT(47)=SUPER(5)
47251 RMSOFT(48)=SUPER(7)
47252 RMSOFT(49)=SUPER(11)
47254 C...~b, ~t, and ~tau trilinear couplings and mixing angles.
47261 C...SLHA trilinears
47272 C...Higgs mixing angle alpha (Gunion-Haber convention).
47273 RMSS(18)=-SUPER(59)
47276 C...GUT scale coupling
47278 C...Gravitino mass (for future compatibility)
47279 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
47281 C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
47283 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
47284 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
47285 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
47286 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
47288 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
47289 C...Squarks and Sleptons.
47292 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
47293 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
47294 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
47295 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
47296 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
47297 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
47298 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
47299 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
47300 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
47302 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
47303 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
47304 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
47306 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
47307 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
47308 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
47309 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
47310 C...Signed masses (extra minus from going to G-H convention).
47316 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
47317 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
47318 C...Signed masses (extra minus from going to G-H convention).
47322 C... Neutralino Mixing.
47324 ZMIX(IN,1)= SUPER(38+4*(IN-1))
47325 ZMIX(IN,2)= SUPER(37+4*(IN-1))
47326 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
47327 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
47329 C...Chargino Mixing (PYTHIA same angle as HERWIG).
47332 IF (SUPER(53).GT.0) THX=-1D0
47333 IF (SUPER(54).GT.0) THY=-1D0
47334 UMIX(1,1) = -SIN(SUPER(53))
47335 UMIX(1,2) = -COS(SUPER(53))
47336 UMIX(2,1) = -THX*COS(SUPER(53))
47337 UMIX(2,2) = THX*SIN(SUPER(53))
47338 VMIX(1,1) = -SIN(SUPER(54))
47339 VMIX(1,2) = -COS(SUPER(54))
47340 VMIX(2,1) = -THY*COS(SUPER(54))
47341 VMIX(2,2) = THY*SIN(SUPER(54))
47342 C...Sfermion mixing (PYTHIA same angle as ISAJET)
47343 SFMIX(5,1)=COS(SUPER(63))
47344 SFMIX(5,2)=SIN(SUPER(63))
47345 SFMIX(5,3)=-SIN(SUPER(63))
47346 SFMIX(5,4)=COS(SUPER(63))
47347 SFMIX(6,1)=COS(SUPER(61))
47348 SFMIX(6,2)=SIN(SUPER(61))
47349 SFMIX(6,3)=-SIN(SUPER(61))
47350 SFMIX(6,4)=COS(SUPER(61))
47351 SFMIX(15,1)=COS(SUPER(65))
47352 SFMIX(15,2)=SIN(SUPER(65))
47353 SFMIX(15,3)=-SIN(SUPER(65))
47354 SFMIX(15,4)=COS(SUPER(65))
47356 IF (MSTP(122).NE.0) THEN
47357 C...Print a few lines to make the user know what's happening
47359 WRITE(MSTU(11),5000) DOC, ISAVER
47360 WRITE(MSTU(11),5100)
47361 IF (IMODEL.EQ.1) THEN
47362 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
47364 WRITE(MSTU(11),5300)
47366 WRITE(MSTU(11),5500) 'Pole masses'
47367 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
47368 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
47369 & ,(SUPER(IP),IP=19,25,2)
47370 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
47372 WRITE(MSTU(11),5400)
47373 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
47374 WRITE(MSTU(11),5400)
47375 WRITE(MSTU(11),5500) 'EW scale mixing structure'
47376 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
47377 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
47378 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
47379 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
47380 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
47381 & ),(SFMIX(15,J),J=3,4)
47382 WRITE(MSTU(11),5400)
47383 WRITE(MSTU(11),6450) RMSS(18)
47384 WRITE(MSTU(11),5400)
47385 WRITE(MSTU(11),5500) 'Couplings'
47386 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
47387 WRITE(MSTU(11),5400)
47390 C...Call FeynHiggs to improve Higgs sector if requested
47391 IF (IMSS(4).EQ.3) THEN
47392 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
47393 & ' (PYSUGI:) Now calling FeynHiggs.'
47395 IF (IERR.EQ.0) THEN
47397 IF (MSTP(122).NE.0) THEN
47398 WRITE(MSTU(11),5400)
47399 WRITE(MSTU(11),5500)
47400 & 'Corrected Higgs masses and mixing'
47401 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
47403 WRITE(MSTU(11),6450) RMSS(18)
47404 WRITE(MSTU(11),5400)
47409 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
47411 C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
47412 C...output by ISASUSY.
47413 IMSS(4)=MAX(2,IMSS(4))
47415 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
47416 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
47417 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
47418 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
47419 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
47420 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
47421 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
47422 & ,'----------------')
47423 5400 FORMAT(1x,'*',1x,A)
47424 5500 FORMAT(1x,'*',1x,A,':')
47425 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
47426 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
47427 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
47428 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
47429 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
47431 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
47432 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
47433 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
47435 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
47436 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
47437 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
47438 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47439 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
47440 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47441 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
47442 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
47443 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
47444 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
47445 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
47446 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
47447 & ,1x,F6.3,1x),'|')
47448 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
47449 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
47450 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
47451 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
47452 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
47453 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
47454 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
47455 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
47456 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
47457 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
47458 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
47459 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
47460 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
47461 & ,4x,'Alpha_GUT = ',F8.2)
47462 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
47463 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
47468 C*********************************************************************
47471 C...Interface to FeynHiggs for MSSM Higgs sector.
47472 C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
47475 SUBROUTINE PYFEYN(IERR)
47477 C...Double precision and integer declarations.
47478 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47479 IMPLICIT INTEGER(I-N)
47480 INTEGER PYK,PYCHGE,PYCOMP
47482 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47483 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47485 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47486 C...FeynHiggs variables
47487 DOUBLE PRECISION RMHIGG(4)
47488 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
47489 DOUBLE COMPLEX DMU,
47490 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47492 C...SLHA Common Block
47493 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47494 & AU(3,3),AD(3,3),AE(3,3)
47495 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
47498 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
47499 IF (IERR.NE.0) THEN
47500 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
47501 & //'Will not use FeynHiggs for this run.')
47539 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
47540 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
47541 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
47542 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
47543 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47544 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
47545 IF (IERR.NE.0) THEN
47546 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
47547 & //' Will not use FeynHiggs for this run.')
47550 C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
47552 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
47553 IF (IERR.NE.0) THEN
47554 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
47555 & 'GSCORR. Will not use FeynHiggs for this run.')
47558 ALPHA = ASIN(DBLE(SAEFF))
47560 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
47561 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
47562 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
47563 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
47565 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
47566 & 1.15D0*PMAS(25,1)) THEN
47567 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
47568 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
47569 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
47572 PMAS(25,1)=RMHIGG(1)
47573 PMAS(35,1)=RMHIGG(2)
47574 PMAS(36,1)=RMHIGG(3)
47575 PMAS(37,1)=RMHIGG(4)
47580 C*********************************************************************
47583 C...Determines the running mass of Squarks.
47585 FUNCTION PYRNMQ(ID,DTERM)
47587 C...Double precision and integer declarations.
47588 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47589 IMPLICIT INTEGER(I-N)
47590 INTEGER PYK,PYCHGE,PYCOMP
47592 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47595 C...Local variables.
47596 DOUBLE PRECISION PI,R
47597 DOUBLE PRECISION TOL
47598 DOUBLE PRECISION CI(3)
47600 DOUBLE PRECISION PYALPS
47602 DATA PI,R/3.141592654D0,.61803399D0/
47603 DATA CI/0.47D0,0.07D0,0.02D0/
47607 AG=(0.71D0)**2/4D0/PI
47614 AS=PYALPS(XM02+6D0*XMG2)
47615 CG=8D0/9D0*((AS/AG)**2-1D0)
47616 BX=XM02+(CA+CG)*XMG2+DTERM
47617 AX=MIN(50D0**2,0.5D0*BX)
47618 CX=MAX(2000D0**2,2D0*BX)
47622 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
47630 CG=8D0/9D0*((AS1/AG)**2-1D0)
47631 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
47633 CG=8D0/9D0*((AS2/AG)**2-1D0)
47634 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
47635 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
47642 CG=8D0/9D0*((AS2/AG)**2-1D0)
47643 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
47650 CG=8D0/9D0*((AS1/AG)**2-1D0)
47651 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
47666 C*********************************************************************
47669 C...Calculates the mass eigenstates of the third generation sfermions.
47670 C...Created: 5-31-96
47674 C...Double precision and integer declarations.
47675 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47676 IMPLICIT INTEGER(I-N)
47677 INTEGER PYK,PYCHGE,PYCOMP
47678 C...Parameter statement to help give large particle numbers.
47679 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47680 &KEXCIT=4000000,KDIMEN=5000000)
47682 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47683 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47684 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47685 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47686 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47687 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47689 C...Local variables.
47690 DOUBLE PRECISION BETA
47691 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
47692 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
47693 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
47694 DOUBLE PRECISION ATR,AMQR,AMQL
47695 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
47696 INTEGER IF,I,J,II,JJ,IT,L
47710 COS2B=COS(2D0*BETA)
47712 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
47722 XMQL2=CTT2*XM12+STT2*XM22
47723 XMQR2=STT2*XM12+CTT2*XM22
47724 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
47725 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47727 C......SUBTRACT OUT D-TERM AND FERMION MASS
47728 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
47729 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
47730 IF(XMQL2.GE.0D0) THEN
47731 RMSS(10)=SQRT(XMQL2)
47733 RMSS(10)=-SQRT(-XMQL2)
47735 IF(XMQR2.GE.0D0) THEN
47736 RMSS(12)=SQRT(XMQR2)
47738 RMSS(12)=-SQRT(-XMQR2)
47741 C SAME FOR BOTTOM SQUARK
47747 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
47748 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
47749 IF(ABS(CTT).GE..9999D0) THEN
47752 ELSEIF(ABS(CTT).LE.1D-4) THEN
47756 XM12=(XMQL2-STT2*XM22)/CTT2
47757 XMQR2=STT2*XM12+CTT2*XM22
47758 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47761 C......SUBTRACT OUT D-TERM AND FERMION MASS
47762 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
47763 IF(XMQR2.GE.0D0) THEN
47764 RMSS(11)=SQRT(XMQR2)
47766 RMSS(11)=-SQRT(-XMQR2)
47768 C SAME FOR TAU SLEPTON
47775 XMQL2=CTT2*XM12+STT2*XM22
47776 XMQR2=STT2*XM12+CTT2*XM22
47779 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47781 C......SUBTRACT OUT D-TERM AND FERMION MASS
47782 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
47783 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
47784 IF(XMQL2.GE.0D0) THEN
47785 RMSS(13)=SQRT(XMQL2)
47787 RMSS(13)=-SQRT(-XMQL2)
47789 IF(XMQR2.GE.0D0) THEN
47790 RMSS(14)=SQRT(XMQR2)
47792 RMSS(14)=-SQRT(-XMQR2)
47797 IF(AMQL.LT.0D0) THEN
47804 IF(AMQR.LT.0D0) THEN
47810 XMF=PYMRUN(IF,PMAS(6,1)**2)
47812 AM2(1,1)=XMQL2+XMF2
47813 AM2(2,2)=XMQR2+XMF2
47814 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
47817 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
47818 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
47819 AM2(1,2)=XMF*(ATR+XMU*TANB)
47820 ELSEIF(L.EQ.2) THEN
47821 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
47822 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
47823 AM2(1,2)=XMF*(ATR+XMU/TANB)
47824 ELSEIF(L.EQ.3) THEN
47825 IF(IMSS(8).EQ.1) THEN
47826 AM2(1,1)=RMSS(6)**2
47827 AM2(2,2)=RMSS(7)**2
47832 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
47833 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
47834 AM2(1,2)=XMF*(ATR+XMU*TANB)
47839 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
47840 IF(DETM.LT.0D0) THEN
47841 WRITE(MSTU(11),*) ID2(L),DETM,AM2
47842 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
47844 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
47845 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
47849 IF(XMF22-XMF12.GT.0D0) THEN
47850 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
47852 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
47853 & AM2(1,2)/(XMF22-XMF12))
47869 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
47875 IF(DI(1,1).GT.DI(2,2)) THEN
47876 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
47877 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
47878 WRITE(MSTU(11),*) AM2
47879 WRITE(MSTU(11),*) DI
47880 WRITE(MSTU(11),*) RT
47891 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
47892 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
47893 & ' OFF DIAGONAL ELEMENTS '
47894 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
47895 WRITE(MSTU(11),*) DI
47896 WRITE(MSTU(11),*) ' ROTATION = ',RT
47898 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
47899 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
47900 & ' NEGATIVE MASSES '
47903 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
47904 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
47905 SFMIX(IF,1)=RT(1,1)
47906 SFMIX(IF,2)=RT(1,2)
47907 SFMIX(IF,3)=RT(2,1)
47908 SFMIX(IF,4)=RT(2,2)
47911 C.....TAU SNEUTRINO MASS...L=3
47913 XARG=AM2(1,1)+XMW2*COS2B
47914 IF(XARG.LT.0D0) THEN
47915 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
47916 & ' FROM THE SUM RULE. '
47917 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
47920 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
47925 C*********************************************************************
47928 C...Finds the mass eigenstates and mixing matrices for neutralinos
47933 C...Double precision and integer declarations.
47934 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47935 IMPLICIT INTEGER(I-N)
47937 C...Parameter statement to help give large particle numbers.
47938 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47939 &KEXCIT=4000000,KDIMEN=5000000)
47941 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47942 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47943 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47944 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47945 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47946 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47948 C...Local variables.
47949 DOUBLE PRECISION XMW,XMZ,XM(4)
47950 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
47951 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
47952 DOUBLE PRECISION COSW,SINW
47953 DOUBLE PRECISION XMU
47954 DOUBLE PRECISION TANB,COSB,SINB
47955 DOUBLE PRECISION XM1,XM2,XM3,BETA
47956 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
47957 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
47958 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
47959 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
47960 DOUBLE PRECISION PYALPS,PYALEM
47961 DOUBLE PRECISION PYRNM3
47962 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
47963 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
47964 DATA KFNCHI/1000022,1000023,1000025,1000035/
47967 IF(IMSS(1).EQ.2) THEN
47970 C...M1, M2, AND M3 ARE INDEPENDENT
47975 ELSEIF(IOPT.GE.1) THEN
47979 A1=AEM/(1D0-PARU(102))
47982 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
47984 XM2=XM1*A2/A1*3D0/5D0
47986 ELSEIF(IOPT.EQ.3) THEN
47987 XM1=XM2*5D0/3D0*A1/A2
47992 IF(XM3.LE.0D0) THEN
47993 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
47999 IF(IMSS(3).EQ.1) THEN
48000 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
48005 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48006 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
48007 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
48013 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48014 RM2=PMAS(I,1)**2/XM3**2
48015 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
48016 IF(ARG.GE.0D0) THEN
48017 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
48019 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
48024 ELSEIF(X0.EQ.0D0) THEN
48028 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
48029 & 0.5D0*X0**2*LOG(AX0)
48030 BT=(-1D0-2D0*X0)/4D0
48035 ELSEIF(X1.EQ.0D0) THEN
48039 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
48040 & X1**2*LOG(AX1)+AT
48041 BT=(-1D0-2D0*X1)/4D0+BT
48045 X0=0.5D0*(1D0+RM2-RM1)
48046 Y0=-0.5D0*SQRT(-ARG)
48047 AMGX0=SQRT(X0**2+Y0**2)
48048 AM1X0=SQRT((1D0-X0)**2+Y0**2)
48049 ARGX0=ATAN2(-X0,-Y0)
48050 AR1X0=ATAN2(1D0-X0,Y0)
48055 ARGX1=ATAN2(-X1,-Y1)
48056 AR1X1=ATAN2(1D0-X1,Y1)
48057 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
48058 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
48059 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
48060 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
48061 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
48062 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
48067 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
48068 & /(2D0*PARU(2))*(15D0+AQ))
48071 C...NEUTRALINO MASSES
48077 XMZ=PMAS(23,1)/100D0
48078 XMW=PMAS(24,1)/100D0
48080 SINW=SQRT(PARU(102))
48081 COSW=SQRT(1D0-PARU(102))
48092 C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
48093 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
48094 AR(1,1) = XM1*COS(RMSS(30))
48095 AI(1,1) = XM1*SIN(RMSS(30))
48096 AR(2,2) = XM2*COS(RMSS(31))
48097 AI(2,2) = XM2*SIN(RMSS(31))
48102 AR(1,3) = -XMZ*SINW*COSB
48104 AR(1,4) = XMZ*SINW*SINB
48106 AR(2,3) = XMZ*COSW*COSB
48108 AR(2,4) = -XMZ*COSW*SINB
48110 AR(3,4) = -XMU*COS(RMSS(33))
48111 AI(3,4) = -XMU*SIN(RMSS(33))
48112 AR(4,3) = -XMU*COS(RMSS(33))
48113 AI(4,3) = -XMU*SIN(RMSS(33))
48114 C CALL PYEIG4(AR,WR,ZR)
48115 CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48116 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48117 & 'PROBLEM WITH PYEICG IN PYINOM ')
48125 IF(XM(K).LT.XM(J)) THEN
48143 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
48146 S=S+ZR(J,K)**2+ZI(J,K)**2
48149 ZMIX(I,J)=ZR(J,K)/SQRT(S)
48150 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
48151 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
48152 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
48156 C...CHARGINO MASSES
48157 C.....Find eigenvectors of X X^*
48166 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
48167 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
48168 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48169 &XMU*COS(RMSS(33))*SINB)
48170 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
48171 &XMU*SIN(RMSS(33))*SINB)
48172 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48173 &XMU*COS(RMSS(33))*SINB)
48174 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
48175 &XMU*SIN(RMSS(33))*SINB)
48176 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48177 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48178 & 'PROBLEM WITH PYEICG IN PYINOM ')
48181 IF(WR(2).LT.WR(1)) THEN
48189 SMW(I)=SQRT(WR(K))*100D0
48192 S=S+ZR(J,K)**2+ZI(J,K)**2
48195 UMIX(I,J)=ZR(J,K)/SQRT(S)
48196 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
48197 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
48198 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
48201 C...Force chargino mass > neutralino mass
48203 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
48204 CALL PYERRM(8,'(PYINOM:) '//
48205 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
48206 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
48209 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
48210 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
48212 C.....Find eigenvectors of X^* X
48223 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
48224 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
48225 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
48226 &XMU*COS(RMSS(33))*COSB)
48227 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
48228 &XMU*SIN(RMSS(33))*COSB)
48229 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
48230 &XMU*COS(RMSS(33))*COSB)
48231 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
48232 &XMU*SIN(RMSS(33))*COSB)
48233 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48234 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48235 & 'PROBLEM WITH PYEICG IN PYINOM ')
48238 IF(WR(2).LT.WR(1)) THEN
48248 S=S+ZR(J,K)**2+ZI(J,K)**2
48249 SIMAG=SIMAG+ZI(J,K)**2
48252 VMIX(I,J)=ZR(J,K)/SQRT(S)
48253 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
48254 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
48255 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
48259 C.....Simplify if no phases
48260 IF(SIMAG.LT.1D-6) THEN
48261 AR(1,1) = XM2*COS(RMSS(31))
48262 AR(2,2) = XMU*COS(RMSS(33))
48263 AR(1,2) = SQRT(2D0)*XMW*SINB
48264 AR(2,1) = SQRT(2D0)*XMW*COSB
48277 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
48282 VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
48283 VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
48284 VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
48285 VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
48286 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
48287 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
48288 ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
48292 C.....Must deal with phases
48294 CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
48295 CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
48296 CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
48297 CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
48303 CAI(I,J)=CMPLX(0D0,0D0)
48311 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
48312 & CMPLX(VMIX(J,L),VMIXI(J,L))
48318 CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
48319 CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
48322 VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
48323 VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
48326 VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
48327 VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
48330 VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
48331 VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
48334 VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
48335 VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
48336 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
48337 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
48338 ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
48339 & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
48347 C*********************************************************************
48350 C...Calculates the running of M3, the SU(3) gluino mass parameter.
48352 FUNCTION PYRNM3(RGUT)
48354 C...Double precision and integer declarations.
48355 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48356 IMPLICIT INTEGER(I-N)
48357 INTEGER PYK,PYCHGE,PYCOMP
48359 C...Local variables.
48361 DOUBLE PRECISION TOL
48363 DOUBLE PRECISION PYALPS
48365 DATA R/0.61803399D0/
48369 BX=RGUT*PYALPS(RGUT**2)
48370 AX=MIN(50D0,BX*0.5D0)
48371 CX=MAX(2000D0,2D0*BX)
48375 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
48383 F1=ABS(X1-RGUT*AS1)
48385 F2=ABS(X2-RGUT*AS2)
48386 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
48393 F2=ABS(X2-RGUT*AS2)
48400 F1=ABS(X1-RGUT*AS1)
48415 C*********************************************************************
48418 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
48419 C...Specific application: mixing in neutralino sector.
48421 SUBROUTINE PYEIG4(A,W,Z)
48423 C...Double precision and integer declarations.
48424 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48425 IMPLICIT INTEGER(I-N)
48426 INTEGER PYK,PYCHGE,PYCOMP
48428 C...Arrays: in call and local.
48429 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
48431 C...Coefficients of fourth-degree equation from matrix.
48432 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
48433 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
48437 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
48446 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
48447 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
48448 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
48449 B0=B0+(-1D0)**(I+1)*A(1,I)*(
48450 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
48451 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
48452 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
48455 C...Coefficients of third-degree equation needed for
48456 C...separation into two second-degree equations.
48457 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
48460 C0=-B1**2-B0*B3**2+4D0*B0*B2
48461 CQ=C1/3D0-C2**2/9D0
48462 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
48465 C...Cases with one or three real roots.
48466 IF(CQR.GE.0D0) THEN
48467 S1=(CR+SQRT(CQR))**(1D0/3D0)
48468 S2=(CR-SQRT(CQR))**(1D0/3D0)
48472 THE=ACOS(CR/SABS**3)/3D0
48477 C...Find and solve two second-degree equations.
48478 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
48479 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
48480 Q1=U/2D0+SQRT(U**2/4D0-B0)
48481 Q2=U/2D0-SQRT(U**2/4D0-B0)
48482 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
48487 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
48488 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
48489 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
48490 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
48492 C...Order eigenvalues in asceding mass.
48495 DO 130 I2=I1-1,1,-1
48496 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
48502 C...Find equation system for eigenvectors.
48505 D(J1,J1)=A(J1,J1)-W(I)
48512 C...Find largest element in matrix.
48516 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
48519 DAMAX=ABS(D(J1,J2))
48523 C...Subtract others by multiple of row selected above.
48525 DO 210 J3=JA+1,JA+3
48527 RL=D(J1,JB)/D(JA,JB)
48529 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
48530 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
48533 DAMAX=ABS(D(J1,J2))
48537 C...Do one more subtraction of a row.
48539 DO 230 J3=JC+1,JC+3
48541 IF(J1.EQ.JA) GOTO 230
48542 RL=D(J1,JD)/D(JC,JD)
48544 IF(J2.EQ.JB) GOTO 220
48545 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
48546 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
48548 DAMAX=ABS(D(J1,J2))
48552 C...Construct unnormalized eigenvector.
48554 JF2=JD+2-4*((JD+1)/4)
48555 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
48556 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
48559 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
48560 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
48563 C...Normalize and fill in final array.
48564 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
48565 SGN=(-1D0)**INT(PYR(0)+0.5D0)
48574 C*********************************************************************
48577 C...Determines the Higgs boson mass spectrum using several inputs.
48579 SUBROUTINE PYHGGM(ALPHA)
48581 C...Double precision and integer declarations.
48582 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48583 IMPLICIT INTEGER(I-N)
48584 INTEGER PYK,PYCHGE,PYCOMP
48585 C...Parameter statement to help give large particle numbers.
48586 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48587 &KEXCIT=4000000,KDIMEN=5000000)
48589 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48590 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48591 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
48592 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48593 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
48595 C...Local variables.
48596 DOUBLE PRECISION AT,AB,XMU,TANB
48597 DOUBLE PRECISION ALPHA
48599 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
48600 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
48601 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
48602 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
48605 IF(IHOPT.EQ.2) THEN
48621 DMC=PMAS(PYCOMP(KSUSY1+37),1)
48628 IF(IHOPT.EQ.0) THEN
48629 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
48630 & DMHCH,DSA,DCA,DTANBA)
48631 ELSEIF(IHOPT.EQ.1) THEN
48632 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
48633 & DMHCH,DSA,DCA,DTANBA)
48634 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
48635 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
48636 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
48642 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
48643 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
48644 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
48645 & PMAS(PYCOMP(1000006),1),DSTOP2
48647 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
48648 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
48649 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
48650 & PMAS(PYCOMP(2000006),1),DSTOP1
48652 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
48653 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
48654 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
48655 & PMAS(PYCOMP(1000005),1),DSBOT2
48657 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
48658 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
48659 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
48660 & PMAS(PYCOMP(2000005),1),DSBOT1
48663 ELSEIF (IHOPT.EQ.3) THEN
48664 c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
48665 C...Currently only available for SLHA spectrum read-in.
48666 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
48667 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
48668 & //' spectrum, change IMSS(1) or IMSS(4) option.')
48684 C*********************************************************************
48687 C...This routine computes the renormalization group improved
48688 C...values of Higgs masses and couplings in the MSSM.
48690 C...Program based on the work by M. Carena, J.R. Espinosa,
48691 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
48693 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
48694 C...All masses in GeV units. MA is the CP-odd Higgs mass,
48695 C...MTOP is the physical top mass, MQ and MUR are the soft
48696 C...supersymmetry breaking mass parameters of left handed
48697 C...and right handed stops respectively, AU and AD are the
48698 C...stop and sbottom trilinear soft breaking terms,
48699 C...respectively, and MU is the supersymmetric
48700 C...Higgs mass parameter. We use the conventions from
48701 C...the physics report of Haber and Kane: left right
48702 C...stop mixing term proportional to (AU - MU/TANB)
48703 C...We use as input TANB defined at the scale MTOP
48705 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
48706 C...where MH and HM are the lightest and heaviest CP-even
48707 C...Higgs masses, MHCH is the charged Higgs mass and
48708 C...ALPHA is the Higgs mixing angle
48709 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
48711 C...Range of validity:
48712 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
48713 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
48714 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
48715 C...are the sbottom mass eigenvalues, respectively. This
48716 C...range automatically excludes the existence of tachyons.
48717 C...For the charged Higgs mass computation, the method is
48719 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
48720 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
48721 C...where M_SUSY**2 is the average of the squared stop mass
48722 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
48723 C...masses have been assumed to be of order of the stop ones
48724 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
48726 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
48727 &XMHCH,SA,CA,TANBA)
48729 C...Double precision and integer declarations.
48730 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48731 IMPLICIT INTEGER(I-N)
48732 INTEGER PYK,PYCHGE,PYCOMP
48733 C...Parameter statement to help give large particle numbers.
48734 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48735 &KEXCIT=4000000,KDIMEN=5000000)
48737 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48738 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48739 COMMON/PYHTRI/HHH(7)
48740 SAVE /PYDAT1/,/PYDAT2/
48742 C...Local variables.
48743 DOUBLE PRECISION PYALEM,PYALPS
48744 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
48745 DOUBLE PRECISION XMHCH,SA,CA
48746 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
48747 DOUBLE PRECISION Q02
48748 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
48749 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
48750 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
48751 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
48752 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
48753 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
48754 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
48755 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
48760 ALP1=AEM/(1D0-PARU(102))
48773 C...MBOTTOM(MTOP) = 3. GEV
48774 XMB = PYMRUN(5,XMTOP**2)
48775 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
48776 &LOG(XMTOP**2/XMZ**2))
48778 C...RMTOP= RUNNING TOP QUARK MASS
48779 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
48780 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
48781 T = LOG(XMS**2/XMTOP**2)
48782 SINB = TANB/((1D0 + TANB**2)**0.5D0)
48784 C...IF(MA.LE.XMTOP) TANBA = TANBT
48786 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
48787 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
48788 &LOG(XMA**2/XMTOP**2))
48790 SINBT = TANBT/SQRT(1D0 + TANBT**2)
48791 COSBT = 1D0/SQRT(1D0 + TANBT**2)
48792 C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
48793 G1 = SQRT(ALP1*4D0*PI)
48794 G2 = SQRT(ALP2*4D0*PI)
48795 G3 = SQRT(ALP3*4D0*PI)
48810 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
48811 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
48812 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
48813 &+ 3D0*(AU + AD)**2/XMS2)/6D0
48814 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
48815 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
48816 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
48817 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
48818 &- 16D0*G3**2) *T/16D0/PI2)
48819 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
48820 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
48821 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
48822 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
48823 &- 16D0*G3**2) *T/16D0/PI2)
48824 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
48825 &(HU2 + HD2)*T/16D0/PI2)
48826 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
48827 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
48828 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
48829 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
48830 &- 16D0*G3**2) *T/16D0/PI2)
48831 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
48832 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
48833 &- 16D0*G3**2) *T/16D0/PI2)
48834 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
48835 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
48836 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
48837 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
48839 &(1+ (6D0*HU2 -2D0* HD2
48840 &- 16D0*G3**2) *T/16D0/PI2)
48841 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
48843 &(1+ (6D0*HD2 -2D0* HU2/2D0
48844 &- 16D0*G3**2) *T/16D0/PI2)
48845 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
48846 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
48847 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
48848 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
48849 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
48850 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48851 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
48852 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48853 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
48854 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48855 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
48856 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48864 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
48865 &2D0* XLAM6*SINBT*COSBT
48866 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
48868 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
48870 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
48871 &2D0* XLAM6* COSBT*SINBT
48872 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48873 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
48874 &((XLAM1* COSBT**2 +2D0*
48875 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
48876 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
48878 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
48879 &+ XLAM4) + XLAM6*COSBT**2
48880 &+ XLAM7* SINBT**2))
48882 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
48883 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
48886 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
48887 XMHCH = SQRT(XMHCH2)
48889 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
48890 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
48891 &XLAM6* COSBT*SINBT
48892 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
48893 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48894 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
48895 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
48897 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
48898 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
48899 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
48900 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
48901 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
48902 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
48903 &XLAM6* COSBT*SINBT
48904 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
48905 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48906 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
48916 C*********************************************************************
48919 C...This subroutine computes the CP-even higgs and CP-odd pole
48920 c...Higgs masses and mixing angles.
48922 C...Program based on the work by M. Carena, M. Quiros
48923 C...and C.E.M. Wagner, "Effective potential methods and
48924 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
48926 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
48928 C...where MCHI is the largest chargino mass, MA is the running
48929 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
48930 C...expectaion values at the scale MTOP, MQ is the third generation
48931 C...left handed squark mass parameter, MUR is the third generation
48932 C...right handed stop mass parameter, MDR is the third generation
48933 C...right handed sbottom mass parameter, MTOP is the pole top quark
48934 C...mass; AT,AB are the soft supersymmetry breaking trilinear
48935 C...couplings of the stop and sbottoms, respectively, and MU is the
48936 C...supersymmetric mass parameter
48938 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
48939 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
48940 C...masses are given, what makes the running of the program
48941 c...much faster and it is quite generally a good approximation
48942 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
48943 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
48944 c...and if IHIGGS=3, then h,H,A polarizations are computed
48946 C...Output: MH and MHP which are the lightest CP-even Higgs running
48947 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
48948 C...Higgs running and pole masses, repectively; SA and CA are the
48949 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
48950 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
48951 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
48952 C...the value of TANB at the CP-odd Higgs mass scale
48954 C...This subroutine makes use of CERN library subroutine
48955 C...integration package, which makes the computation of the
48956 C...pole Higgs masses somewhat faster. We thank P. Janot for this
48957 C...improvement. Those who are not able to call the CERN
48958 C...libraries, please use the subroutine SUBHPOLE2.F, which
48959 C...although somewhat slower, gives identical results
48961 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
48962 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
48964 C...Double precision and integer declarations.
48965 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48966 IMPLICIT INTEGER(I-N)
48969 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48971 INTEGER PYK,PYCHGE,PYCOMP
48973 C...Local variables.
48974 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
48975 &SSBOT2(2),B(2,2),COUPB(2,2),
48976 &HCOUPT(2,2),HCOUPB(2,2),
48977 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
48986 RXMT=PYMRUN(6,XMT**2)
48987 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
48988 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
48990 SINB = TANB/(TANB**2+1D0)**0.5D0
48991 COSB = 1D0/(TANB**2+1D0)**0.5D0
48992 COS2B = SINB**2 - COSB**2
48993 SINBPA = SINB*CA + COSB*SA
48994 COSBPA = COSB*CA - SINB*SA
48995 RMBOT = PYMRUN(5,XMT**2)
48998 IF(XMUR.LT.0D0) XMUR2=-XMUR2
49000 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
49001 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
49002 IF(XMST11.LT.0D0) GOTO 500
49003 IF(XMST22.LT.0D0) GOTO 500
49004 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
49005 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
49006 IF(XMSB11.LT.0D0) GOTO 500
49007 IF(XMSB22.LT.0D0) GOTO 500
49008 C WMST11 = RXMT**2 + XMQ2
49009 C WMST22 = RXMT**2 + XMUR2
49010 XMST12 = RXMT*(AT - XMU/TANB)
49011 XMSB12 = RMBOT*(AB - XMU*TANB)
49013 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49014 C...STOP EIGENVALUES CALCULATION
49015 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49017 STOP12 = 0.5D0*(XMST11+XMST22) +
49018 &0.5D0*((XMST11+XMST22)**2 -
49019 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
49020 STOP22 = 0.5D0*(XMST11+XMST22) -
49021 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
49022 &XMST12**2))**0.5D0
49024 IF(STOP22.LT.0D0) GOTO 500
49027 STOP1 = STOP12**0.5D0
49028 STOP2 = STOP22**0.5D0
49032 IF(XMST12.EQ.0D0) XST11 = 1D0
49033 IF(XMST12.EQ.0D0) XST12 = 0D0
49034 IF(XMST12.EQ.0D0) XST21 = 0D0
49035 IF(XMST12.EQ.0D0) XST22 = 1D0
49037 IF(XMST12.EQ.0D0) GOTO 110
49039 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49040 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49041 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49042 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49049 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
49050 &0.5D0*((XMSB11+XMSB22)**2 -
49051 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
49052 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
49053 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
49054 &XMSB12**2))**0.5D0
49055 IF(SBOT22.LT.0D0) GOTO 500
49056 SBOT1 = SBOT12**0.5D0
49057 SBOT2 = SBOT22**0.5D0
49062 IF(XMSB12.EQ.0D0) XSB11 = 1D0
49063 IF(XMSB12.EQ.0D0) XSB12 = 0D0
49064 IF(XMSB12.EQ.0D0) XSB21 = 0D0
49065 IF(XMSB12.EQ.0D0) XSB22 = 1D0
49067 IF(XMSB12.EQ.0D0) GOTO 130
49069 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49070 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49071 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49072 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49084 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49085 C...STARTING OF LIGHT HIGGS
49086 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49088 IF(IHIGGS.EQ.0) GOTO 490
49093 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
49094 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49095 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
49096 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
49105 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
49106 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49107 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
49108 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
49116 180 ITER = ITER + 1
49119 PR(I3)=PRUN+(I3-2)*EPS/2
49124 POLT = POLT + COUPT(I,J)**2*3D0*
49125 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49132 POLB = POLB + COUPB(I,J)**2*3D0*
49133 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49140 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49142 & (-2D0*XMT**2+0.5D0*P2)*
49143 & PYFINT(P2,XMT2,XMT2)
49145 POL = POLT + POLB + POLTT
49146 POLAR(I3) = P2 - XMH**2 - POL
49148 DERIV = (POLAR(3)-POLAR(1))/EPS
49149 DRUN = - POLAR(2)/DERIV
49152 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
49158 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49159 C...END OF LIGHT HIGGS
49160 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49162 250 IF(IHIGGS.EQ.1) GOTO 490
49164 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49165 C... STARTING OF HEAVY HIGGS
49166 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49171 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
49172 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49173 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
49174 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
49182 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
49183 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49184 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
49185 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
49194 300 ITER = ITER + 1
49196 PR(I3)=PRUN+(I3-2)*EPS/2
49202 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
49203 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49210 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
49211 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49219 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49221 & (-2D0*XMT**2+0.5D0*HP2)*
49222 & PYFINT(HP2,XMT2,XMT2)
49224 HPOL = HPOLT + HPOLB + HPOLTT
49225 POLAR(I3) =HP2-HM**2-HPOL
49227 DERIV = (POLAR(3)-POLAR(1))/EPS
49228 DRUN = - POLAR(2)/DERIV
49231 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
49239 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49240 C... END OF HEAVY HIGGS
49241 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49243 IF(IHIGGS.EQ.2) GOTO 490
49245 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49246 C...BEGINNING OF PSEUDOSCALAR HIGGS
49247 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49252 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
49253 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
49259 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
49260 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
49267 420 ITER = ITER + 1
49269 PR(I3)=PRUN+(I3-2)*EPS/2
49274 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
49275 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49281 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
49282 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49288 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49289 & COSB**2/SINB**2 *
49291 & PYFINT(AP2,XMT2,XMT2)
49292 APOL = APOLT + APOLB + APOLTT
49293 POLAR(I3) = AP2 - XMA**2 -APOL
49295 DERIV = (POLAR(3)-POLAR(1))/EPS
49296 DRUN = - POLAR(2)/DERIV
49299 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
49305 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49306 C...END OF PSEUDOSCALAR HIGGS
49307 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49309 IF(IHIGGS.EQ.3) GOTO 490
49314 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
49315 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
49316 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
49317 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
49321 C*********************************************************************
49324 C...Auxiliary to PYPOLE.
49326 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
49327 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
49328 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
49329 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
49332 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49343 C MBOTTOM(MTOP) = 3. GEV
49344 MB = PYMRUN(5,MTOP**2)
49345 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
49346 *LOG(MTOP**2/MZ**2))
49347 C RMTOP= RUNNING TOP QUARK MASS
49348 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
49349 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
49350 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
49351 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
49352 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49354 C NEW DEFINITION, TGLU.
49356 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49357 TGLU = LOG(MGLU**2/MTOP**2)
49358 SINB = TANB/DSQRT(1D0 + TANB**2)
49361 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
49362 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
49363 *LOG(MA**2/MTOP**2))
49364 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
49365 SINB = TANBT/SQRT(1D0 + TANBT**2)
49366 COSB = 1D0/DSQRT(1D0 + TANBT**2)
49367 G1 = SQRT(ALPHA1*4D0*PI)
49368 G2 = SQRT(ALPHA2*4D0*PI)
49369 G3 = SQRT(ALPHA3*4D0*PI)
49372 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
49373 *SBOT1,SBOT2,DELTAMT,DELTAMB)
49374 IF(MQ.GT.MUR) TP = TQ - TU
49375 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
49376 IF(MQ.GT.MUR) TDP = TU
49377 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
49378 IF(MQ.GT.MD) TPD = TQ - TD
49379 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
49380 IF(MQ.GT.MD) TDPD = TD
49381 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
49383 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
49384 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
49385 * HD**2*(G1**2/3D0+G2**2)*TPD
49387 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
49388 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
49389 * HU**2*(-G1**2/3D0+G2**2)*TP
49391 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49393 C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
49394 C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
49395 C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
49399 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49402 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
49403 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
49404 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
49407 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
49408 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
49411 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
49412 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
49415 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
49416 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
49419 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
49420 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
49423 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
49424 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
49429 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
49430 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
49431 *(G2**2-G1**2/3D0)*TPD
49432 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
49433 *1D0/16D0/PI**2*G1**2*HU**2*TP
49434 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
49435 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
49436 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
49437 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
49439 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
49440 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
49441 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
49442 *+ (3D0*HD**2/2D0 + HU**2/2D0
49443 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
49444 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
49445 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
49446 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
49447 *(TP + TDP)/8D0/PI**2)
49448 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
49449 *+ (3D0*HU**2/2D0 + HD**2/2D0
49450 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
49451 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
49452 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
49453 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
49454 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
49455 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
49456 LAMBDA4 = (- G2**2/2D0)*(1D0
49457 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
49458 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
49464 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
49465 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
49467 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
49468 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
49469 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
49470 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
49473 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49474 CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
49475 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49477 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
49479 IF(MCHI.GT.MSSUSY) GOTO 100
49480 IF(MCHI.LT.MTOP) MCHI=MTOP
49482 TCHAR=LOG(MSSUSY**2/MCHI**2)
49484 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
49485 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
49486 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
49488 DELTAM112=2D0*DELTAL12*V**2*COSB**2
49489 DELTAM222=2D0*DELTAL12*V**2*SINB**2
49490 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
49492 M2(1,1)=M2(1,1)+DELTAM112
49493 M2(2,2)=M2(2,2)+DELTAM222
49494 M2(1,2)=M2(1,2)+DELTAM122
49495 M2(2,1)=M2(2,1)+DELTAM122
49499 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49500 CCC END OF CHARGINOS/NEUTRALINOS
49501 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49505 M2P(I,J) = M2(I,J) + VH(I,J)
49508 TRM2P = M2P(1,1) + M2P(2,2)
49509 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
49510 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
49511 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
49513 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
49515 IF(MH2P.LT.0.) GOTO 130
49517 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
49518 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
49519 IF(COS2ALPHA.GE.0.) THEN
49520 ALPHA = ASIN(SIN2ALPHA)/2D0
49522 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
49526 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49528 C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
49529 C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
49530 C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
49533 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49534 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
49535 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
49540 C*********************************************************************
49543 C...Auxiliary to PYRGHM.
49545 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
49546 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
49547 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
49548 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
49550 INTEGER MSTU,MSTJ,KCHG
49551 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49552 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49553 SAVE /PYDAT1/,/PYDAT2/
49555 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
49557 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
49558 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
49560 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
49565 SINBA = TANBA/DSQRT(TANBA**2+1D0)
49566 COSBA = SINBA/TANBA
49568 SINB = TANB/DSQRT(TANB**2+1D0)
49574 SW = 1D0-MW**2/MZ**2
49577 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
49578 G2 = DSQRT(0.0336D0*4D0*PI)
49579 G1 = DSQRT(0.0101D0*4D0*PI)
49581 IF(MQ.GT.MUR) MST = MQ
49582 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
49584 MSUSYT = DSQRT(MST**2 + MTOP**2)
49586 IF(MQ.GT.MD) MSB = MQ
49587 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
49589 MB = PYMRUN(5,MSB**2)
49590 MSUSYB = DSQRT(MSB**2 + MB**2)
49591 TT = LOG(MSUSYT**2/MTOP**2)
49592 TB = LOG(MSUSYB**2/MTOP**2)
49594 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
49595 HT = RMTOP/(V*SINB)
49598 G32 = ALPHA3*4D0*PI
49599 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
49600 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
49601 AL2 = 3D0/8D0/PI**2*HT**2
49602 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
49603 C ALST = 3./8./PI**2*HTST**2
49604 AL1 = 3D0/8D0/PI**2*HB**2
49607 AL(1,2) = (AL2+AL1)/2D0
49608 AL(2,1) = (AL2+AL1)/2D0
49611 IF(MA.GT.MTOP) THEN
49612 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
49613 * LOG(MTOP**2/MA**2))
49616 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
49617 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
49618 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
49619 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
49624 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
49625 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
49626 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
49627 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
49631 SINBT = TANBST/DSQRT(1D0+TANBST**2)
49634 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
49635 COSBB = SINBB/TANBSB
49640 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
49641 MTOP2 = DSQRT(MTOP4)
49642 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
49643 * /(1D0+DELTAMB)**4
49644 MBOT2 = DSQRT(MBOT4)
49646 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
49647 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49648 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49649 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
49650 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
49651 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49652 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49653 * MQ2 - MUR2)**2*0.25D0
49654 * + MTOP2*(AT-XMU/TANBST)**2)
49655 IF(STOP22.LT.0.) GOTO 120
49656 SBOT12 = (MQ2 + MD2)*.5D0
49657 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49658 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49659 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49660 SBOT22 = (MQ2 + MD2)*.5D0
49661 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49662 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49663 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49664 IF(SBOT22.LT.0.) SBOT22 = 10000D0
49666 STOP1 = DSQRT(STOP12)
49667 STOP2 = DSQRT(STOP22)
49668 SBOT1 = DSQRT(SBOT12)
49669 SBOT2 = DSQRT(SBOT22)
49671 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49673 C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
49674 C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
49675 C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
49676 C INDUCED CORRECTIONS.
49678 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49683 IF(X.EQ.Y) X = X - 0.00001D0
49684 IF(X.EQ.Z) X = X - 0.00002D0
49685 IF(Y.EQ.Z) Y = Y - 0.00003D0
49691 IF(X.EQ.Y) X = X - 0.00001D0
49692 IF(X.EQ.Z) X = X - 0.00002D0
49693 IF(Y.EQ.Z) Y = Y - 0.00003D0
49695 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
49696 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
49700 IF(X.EQ.Y) X = X - 0.00001D0
49701 IF(X.EQ.Z) X = X - 0.00002D0
49702 IF(Y.EQ.Z) Y = Y - 0.00003D0
49704 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
49706 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49708 C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
49709 C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
49710 C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
49711 C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
49712 C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
49713 C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
49714 C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
49715 C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
49716 C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
49717 C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
49718 C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
49721 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49723 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
49724 MTOP2 = DSQRT(MTOP4)
49725 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
49726 * /(1D0+DELTAMB)**4
49727 MBOT2 = DSQRT(MBOT4)
49729 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
49730 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49731 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49732 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
49733 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
49734 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49735 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49736 * MQ2 - MUR2)**2*0.25D0
49737 * + MTOP2*(AT-XMU/TANBST)**2)
49739 IF(STOP22.LT.0.) GOTO 120
49740 SBOT12 = (MQ2 + MD2)*.5D0
49741 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49742 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49743 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49744 SBOT22 = (MQ2 + MD2)*.5D0
49745 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49746 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49747 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49748 IF(SBOT22.LT.0.) GOTO 120
49751 STOP1 = DSQRT(STOP12)
49752 STOP2 = DSQRT(STOP22)
49753 SBOT1 = DSQRT(SBOT12)
49754 SBOT2 = DSQRT(SBOT22)
49756 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49758 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49761 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
49763 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
49764 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
49766 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
49768 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
49769 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
49771 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
49772 * (-.5D0*LOG(STOP12/STOP22)
49773 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
49774 * G(STOP12,STOP22))
49776 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
49777 * (.5D0*LOG(SBOT12/SBOT22)
49778 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
49779 * G(SBOT12,SBOT22))
49781 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
49782 * (MQ2+MBOT2)/(MD2+MBOT2))
49783 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
49784 * LOG(SBOT1**2/SBOT2**2)) +
49785 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
49786 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
49789 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
49790 * -STOP2**2))**2*G(STOP12,STOP22)
49792 VH3B(1,1)=VH3B(1,1)+
49793 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
49795 VH3T(1,1) = VH3T(1,1) +
49796 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
49798 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
49799 * (MQ2+MTOP2)/(MUR2+MTOP2))
49800 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
49801 * LOG(STOP1**2/STOP2**2)) +
49802 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
49803 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
49806 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
49807 * -SBOT2**2))**2*G(SBOT12,SBOT22)
49809 VH3T(2,2)=VH3T(2,2)+
49810 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
49811 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
49813 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
49814 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
49815 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
49818 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
49819 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
49820 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
49823 VH3T(1,2)=VH3T(1,2) +
49824 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
49826 VH3B(1,2)=VH3B(1,2) +
49827 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
49829 VH3T(2,1) = VH3T(1,2)
49830 VH3B(2,1) = VH3B(1,2)
49832 C TQ = LOG((MQ2 + MTOP2)/MTOP2)
49833 C TU = LOG((MUR2+MTOP2)/MTOP2)
49834 C TQD = LOG((MQ2 + MB**2)/MB**2)
49835 C TD = LOG((MD2+MB**2)/MB**2)
49840 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
49841 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
49842 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
49843 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
49862 C*********************************************************************
49865 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
49867 FUNCTION PYFINT(A,B,C)
49869 C...Double precision and integer declarations.
49870 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49871 IMPLICIT INTEGER(I-N)
49872 INTEGER PYK,PYCHGE,PYCOMP
49874 COMMON/PYINTS/XXM(20)
49877 C...Local variables.
49879 DOUBLE PRECISION PYFISB
49886 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
49891 C*********************************************************************
49894 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
49898 C...Double precision and integer declarations.
49899 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49900 IMPLICIT INTEGER(I-N)
49901 INTEGER PYK,PYCHGE,PYCOMP
49903 COMMON/PYINTS/XXM(20)
49906 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
49907 &(X*(XXM(2)-XXM(3))+XXM(3)))
49912 C*********************************************************************
49915 C...Calculates decays of sfermions.
49917 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
49919 C...Double precision and integer declarations.
49920 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49921 IMPLICIT INTEGER(I-N)
49922 INTEGER PYK,PYCHGE,PYCOMP
49923 C...Parameter statement to help give large particle numbers.
49924 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49925 &KEXCIT=4000000,KDIMEN=5000000)
49927 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49928 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49929 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49930 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49931 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49932 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
49934 C...Local variables.
49935 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
49936 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
49938 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
49939 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
49940 DOUBLE PRECISION PYLAMF,XL
49941 DOUBLE PRECISION TANW,XW,AEM,C1,AS
49942 DOUBLE PRECISION AL,AR,BL,BR
49943 DOUBLE PRECISION CH1,CH2,CH3,CH4
49944 DOUBLE PRECISION XMBOT,XMTOP
49945 DOUBLE PRECISION XLAM(0:400)
49946 INTEGER IDLAM(400,3)
49947 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
49948 DOUBLE PRECISION SR2
49949 DOUBLE PRECISION CBETA,SBETA
49950 DOUBLE PRECISION CW
49951 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
49952 DOUBLE PRECISION COSA,SINA,TANB
49953 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
49954 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
49956 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
49957 DATA IGG/23,25,35,36/
49958 DATA PI/3.141592654D0/
49959 DATA SR2/1.4142136D0/
49960 DATA KFNCHI/1000022,1000023,1000025,1000035/
49961 DATA KFCCHI/1000024,1000037/
49963 C...COUNT THE NUMBER OF DECAY MODES
49967 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
49968 &KFIN.EQ.KSUSY2+16) RETURN
49974 TANW = SQRT(XW/(1D0-XW))
49979 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
49984 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
49985 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
49991 C...ILR is 1 for left and 2 for right.
49993 C...IFL is matching non-SUSY flavour.
49994 IFL=MOD(KFIN,KSUSY1)
49995 C...IDU is weak isospin, 1 for down and 2 for up.
50006 XMBOT=PYMRUN(5,XMI2)
50007 XMTOP=PYMRUN(6,XMI2)
50021 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
50023 IF(IMSS(11).EQ.1) THEN
50026 XMGR=PMAS(PYCOMP(IDG),1)
50027 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
50030 ELSEIF(IFL.EQ.6) THEN
50035 IF(XMI.GT.XMGR+XMF) THEN
50040 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
50044 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
50046 C...CHARGED DECAYS:
50048 C...DI -> U CHI1-,CHI2-
50052 C...UI -> D CHI1+,CHI2+
50059 IF(XMI.GE.AXMJ+XMFP) THEN
50066 ELSEIF(IFL.LT.6) THEN
50071 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
50072 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
50078 ELSEIF(IFL.LT.5) THEN
50083 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
50084 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
50088 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50089 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50090 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50091 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50107 XL=PYLAMF(XMI2,XMA2,XMB2)
50108 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50109 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50110 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
50113 IDLAM(LKNT,1)=-KFCCHI(IX)
50114 IDLAM(LKNT,2)=IFL+1
50116 IDLAM(LKNT,1)=KFCCHI(IX)
50117 IDLAM(LKNT,2)=IFL-1
50128 IF(XMI.GE.AXMJ+XMF) THEN
50134 ELSEIF(IFL.LT.5) THEN
50137 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
50138 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
50139 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50144 ELSEIF(IFL.LT.5) THEN
50147 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
50148 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
50149 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50153 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50154 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50155 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50156 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50172 XL=PYLAMF(XMI2,XMA2,XMB2)
50173 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50174 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50175 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
50176 IDLAM(LKNT,1)=KFNCHI(IX)
50182 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
50186 IF(ILR.EQ.1) GOTO 160
50188 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
50189 IF(XMI.LT.XMSF1+XMB) GOTO 160
50191 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
50194 ELSEIF(IG.EQ.25) THEN
50197 ELSEIF(IFL.EQ.6) THEN
50199 ELSEIF(IFL.LT.5) THEN
50205 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
50206 & XMF**2/XMW*COSA/SBETA
50207 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
50208 & XMF**2/XMW*COSA/SBETA
50210 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
50211 & XMF**2/XMW*(-SINA)/CBETA
50212 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
50213 & XMF**2/XMW*(-SINA)/CBETA
50217 ELSEIF(IFL.EQ.6) THEN
50219 ELSEIF(IFL.EQ.15) THEN
50224 C.........need to complexify
50226 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
50229 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
50235 ELSEIF(IG.EQ.35) THEN
50238 ELSEIF(IFL.EQ.6) THEN
50240 ELSEIF(IFL.LT.5) THEN
50246 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
50247 & XMF**2/XMW*SINA/SBETA
50248 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
50249 & XMF**2/XMW*SINA/SBETA
50251 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
50252 & XMF**2/XMW*COSA/CBETA
50253 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
50254 & XMF**2/XMW*COSA/CBETA
50258 ELSEIF(IFL.EQ.6) THEN
50260 ELSEIF(IFL.EQ.15) THEN
50265 C.........Need to complexify
50267 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
50270 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
50276 ELSEIF(IG.EQ.36) THEN
50281 ELSEIF(IFL.EQ.6) THEN
50283 ELSEIF(IFL.LT.5) THEN
50290 ELSEIF(IFL.EQ.6) THEN
50292 ELSEIF(IFL.EQ.15) THEN
50297 C.........Need to complexify
50299 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
50301 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
50307 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
50308 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
50309 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
50310 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50313 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50315 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
50318 IDLAM(LKNT,1)=KFIN-KSUSY1
50324 IF(MOD(IFL,2).EQ.0) THEN
50330 XMSF1=PMAS(PYCOMP(KF1),1)
50331 XMSF2=PMAS(PYCOMP(KF2),1)
50332 IF(XMI.GT.XMB+XMSF1) THEN
50333 IF(MOD(IFL,2).EQ.0) THEN
50335 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
50337 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
50341 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
50343 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
50346 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50348 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50351 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
50353 IF(XMI.GT.XMB+XMSF2) THEN
50354 IF(MOD(IFL,2).EQ.0) THEN
50356 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
50358 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
50362 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
50364 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
50367 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
50369 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50372 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
50377 IF(MOD(IFL,2).EQ.0) THEN
50383 XMSF1=PMAS(PYCOMP(KF1),1)
50384 XMSF2=PMAS(PYCOMP(KF2),1)
50385 IF(XMI.GT.XMB+XMSF1) THEN
50390 IF(MOD(IFL,2).EQ.0) THEN
50393 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
50394 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
50395 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
50396 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
50399 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
50400 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
50401 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
50402 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
50413 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
50414 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
50415 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
50416 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
50419 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
50420 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
50421 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
50422 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
50431 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50433 C.......Need to complexify
50434 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
50435 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
50436 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
50437 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
50440 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
50442 IF(XMI.GT.XMB+XMSF2) THEN
50447 IF(MOD(IFL,2).EQ.0) THEN
50450 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
50451 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
50452 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
50453 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
50456 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
50457 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
50458 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
50459 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
50470 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
50471 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
50472 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
50473 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
50476 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
50477 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
50478 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
50479 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
50488 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50490 C.......Need to complexify
50491 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
50492 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
50493 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
50494 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
50497 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
50500 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
50505 IF(IFL.EQ.6) XMF=PMAS(6,1)
50506 IF(IFL.EQ.5) XMF=PMAS(5,1)
50507 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
50509 IF(XMI.GE.AXMJ+XMF) THEN
50526 XL=PYLAMF(XMI2,XMA2,XMB2)
50527 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50528 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
50529 IDLAM(LKNT,1)=KSUSY1+21
50535 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
50536 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
50537 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
50538 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
50539 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
50540 C...M*M = C1**2 * G**2/(16PI**2)
50541 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
50543 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
50544 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
50545 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
50546 IDLAM(LKNT,1)=KSUSY1+22
50551 C...R-violating sfermion decays (SKANDS).
50552 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
50557 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50558 XLAM(0)=XLAM(0)+XLAM(I)
50560 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
50565 C*********************************************************************
50568 C...Calculates gluino decay modes.
50570 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
50572 C...Double precision and integer declarations.
50573 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50574 IMPLICIT INTEGER(I-N)
50575 INTEGER PYK,PYCHGE,PYCOMP
50576 C...Parameter statement to help give large particle numbers.
50577 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50578 &KEXCIT=4000000,KDIMEN=5000000)
50580 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50581 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50582 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50583 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50584 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50586 C COMMON/PYINTS/XXM(20)
50588 COMMON/PYINTC/XXC(10),CXC(8)
50589 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50591 C...Local variables
50592 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
50593 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
50594 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
50595 DOUBLE PRECISION PYLAMF,XL
50596 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
50597 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
50598 DOUBLE PRECISION XLAM(0:400)
50599 INTEGER IDLAM(400,3)
50600 INTEGER LKNT,IX,ILR,I,IKNT,IFL
50601 DOUBLE PRECISION SR2
50602 DOUBLE PRECISION GAM
50603 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
50604 EXTERNAL PYGAUS,PYXXZ6
50605 DOUBLE PRECISION PYGAUS,PYXXZ6
50606 DOUBLE PRECISION PREC
50607 INTEGER KFNCHI(4),KFCCHI(2)
50608 DATA PI/3.141592654D0/
50609 DATA SR2/1.4142136D0/
50611 DATA KFNCHI/1000022,1000023,1000025,1000035/
50612 DATA KFCCHI/1000024,1000037/
50614 C...COUNT THE NUMBER OF DECAY MODES
50616 IF(KFIN.NE.KSUSY1+21) RETURN
50620 TANW = SQRT(XW/(1D0-XW))
50630 XMI=SIGN(XMI,RMSS(3))
50632 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
50634 IF(IMSS(11).EQ.1) THEN
50637 XMGR=PMAS(PYCOMP(IDG),1)
50638 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
50639 IF(AXMI.GT.XMGR) THEN
50648 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
50652 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
50655 IF(AXMI.GE.AXMJ+XMF) THEN
50656 C...Minus sign difference from gluino-quark-squark feynman rules
50673 XL=PYLAMF(XMI2,XMA2,XMB2)
50674 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
50675 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
50676 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
50680 XLAM(LKNT)=XLAM(LKNT-1)
50681 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50682 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50688 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
50689 C...GLUINO -> NI Q QBAR
50693 IF(AXMI.GE.AXMJ) THEN
50695 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
50697 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
50704 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
50705 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
50711 T3I=SIGN(1D0,EI+1D-6)/2D0
50712 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50713 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50717 CXC(4)=DCONJG(GLIJ)
50721 CXC(8)=-DCONJG(GRIJ)
50723 S12MAX=(AXMI-AXMJ)**2
50724 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
50725 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50727 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
50728 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
50729 IDLAM(LKNT,1)=KFNCHI(IX)
50733 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50735 XLAM(LKNT)=XLAM(LKNT-1)
50736 IDLAM(LKNT,1)=KFNCHI(IX)
50741 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50742 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
50743 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
50745 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
50746 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
50748 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
50751 IDLAM(LKNT,1)=KFNCHI(IX)
50754 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
50759 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
50760 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
50761 C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
50765 T3I=SIGN(1D0,EI+1D-6)/2D0
50766 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50767 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50769 CXC(4)=DCONJG(GLIJ)
50771 CXC(8)=-DCONJG(GRIJ)
50772 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
50773 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50775 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
50776 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
50777 IDLAM(LKNT,1)=KFNCHI(IX)
50781 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50783 XLAM(LKNT)=XLAM(LKNT-1)
50784 IDLAM(LKNT,1)=KFNCHI(IX)
50789 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
50790 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
50792 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
50793 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
50794 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
50796 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
50797 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
50799 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
50802 IDLAM(LKNT,1)=KFNCHI(IX)
50805 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
50811 C...GLUINO -> CI Q QBAR'
50815 IF(AXMI.GE.AXMJ) THEN
50817 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
50818 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
50821 S12MAX=(AXMI-AXMJ)**2
50826 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
50827 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
50830 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
50832 CXC(1)=DCMPLX(0D0,0D0)
50833 CXC(3)=DCMPLX(0D0,0D0)
50834 CXC(5)=DCMPLX(0D0,0D0)
50835 CXC(7)=DCMPLX(0D0,0D0)
50836 CXC(2)=UMIXC(IX,1)*OLPP/SR2
50837 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
50838 CXC(6)=DCMPLX(0D0,0D0)
50839 CXC(8)=DCMPLX(0D0,0D0)
50840 IF(XXC(5).LT.AXMI) THEN
50842 ELSEIF(XXC(6).LT.AXMI) THEN
50847 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
50848 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
50850 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
50851 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50852 IDLAM(LKNT,1)=KFCCHI(IX)
50856 XLAM(LKNT)=XLAM(LKNT-1)
50857 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50858 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50859 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50861 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
50863 XLAM(LKNT)=XLAM(LKNT-1)
50864 IDLAM(LKNT,1)=KFCCHI(IX)
50868 XLAM(LKNT)=XLAM(LKNT-1)
50869 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50870 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50871 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50877 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
50878 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
50879 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
50880 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
50881 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
50882 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
50883 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
50884 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
50885 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
50886 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
50887 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
50888 CALL PYTBBC(IX,100,XMI,GAM)
50891 IDLAM(LKNT,1)=KFCCHI(IX)
50895 XLAM(LKNT)=XLAM(LKNT-1)
50896 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50897 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50898 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50899 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
50900 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
50901 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
50902 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
50908 C...R-parity violating (3-body) decays.
50909 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
50914 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50915 XLAM(0)=XLAM(0)+XLAM(I)
50917 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
50923 C*********************************************************************
50926 C...Calculates the three-body decay of gluinos into
50927 C...neutralinos and third generation fermions.
50929 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
50931 C...Double precision and integer declarations.
50932 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50933 IMPLICIT INTEGER(I-N)
50934 INTEGER PYK,PYCHGE,PYCOMP
50935 C...Parameter statement to help give large particle numbers.
50936 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50937 &KEXCIT=4000000,KDIMEN=5000000)
50939 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50940 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50941 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50942 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50943 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50944 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50946 C...Local variables.
50947 EXTERNAL PYSIMP,PYLAMF
50948 DOUBLE PRECISION PYSIMP,PYLAMF
50950 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
50951 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
50952 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
50953 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
50954 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
50955 DOUBLE PRECISION XLN1,XLN2,B1,B2
50956 DOUBLE PRECISION E,XMGLU,GAM
50957 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
50958 SAVE HRB,HLB,FLB,FRB
50959 DOUBLE PRECISION ALPHAW,ALPHAS
50960 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
50961 SAVE HLT,HRT,FLT,FRT
50962 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
50964 DOUBLE PRECISION AMBOT,SINC,COSC
50965 DOUBLE PRECISION AMTOP,SINA,COSA
50966 DOUBLE PRECISION SINW,COSW,TANW
50967 DOUBLE PRECISION ROT1(4,4)
50970 DATA IFIRST/.TRUE./
50973 SINB=TANB/SQRT(1D0+TANB**2)
50984 AMBOT=PYMRUN(5,XMGLU**2)
50985 AMTOP=PYMRUN(6,XMGLU**2)
50987 FAKT1=AMBOT/W2/AMW/COSB
50988 FAKT2=AMTOP/W2/AMW/SINB
50999 ROT1(2,1)=-ROT1(1,2)
51000 ROT1(2,2)=ROT1(1,1)
51003 ROT1(4,3)=-ROT1(3,4)
51004 ROT1(4,4)=ROT1(3,3)
51008 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
51013 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
51014 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51015 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
51017 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
51018 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
51019 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
51020 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
51023 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
51024 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51025 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
51026 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
51027 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
51028 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
51029 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
51033 C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51034 C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51035 C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51036 C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51040 IF(NINT(3D0*E).EQ.2) THEN
51047 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
51048 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
51057 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
51058 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
51064 SIN2D=SIND*COSD*2D0
51078 ALPHAW=PYALEM(XMG2)
51079 ALPHAS=PYALPS(XMG2)
51083 XM24=(XMG2+XM2)*(XM2+XMR2)
51085 SMAX=(XMG-ABS(XMR))**2
51086 XMQA=XMG2+2D0*XM2+XMR2
51088 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51090 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
51092 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
51093 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
51094 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
51095 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
51096 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
51097 & +2D0*(FF*SIND2-HH*COSD2))*W
51098 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
51099 & +4D0*HFL*XM*XMR)*XLN1
51100 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
51101 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
51102 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
51103 & +8D0*HFL*XMQ4*SIN2D)*B1
51104 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
51105 & +4D0*HFR*XMR*XM)*XLN2
51106 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
51107 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
51108 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
51109 & -8D0*HFR*XMQ4*SIN2D)*B2
51110 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
51111 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
51112 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
51113 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
51114 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
51115 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
51116 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
51117 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
51118 G(5)=(2D0*(HH*COSD2-FF*SIND2)
51119 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
51120 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
51121 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
51122 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
51123 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
51124 & +COS2D*XM*(SBAR+XMG2-XMR2))
51125 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
51126 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
51127 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
51128 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
51129 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
51130 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
51131 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
51134 SUMME(LIN)=SUMME(LIN)+G(J)
51139 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51140 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51145 C*********************************************************************
51148 C...Calculates the three-body decay of gluinos into
51149 C...charginos and third generation fermions.
51151 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
51153 C...Double precision and integer declarations.
51154 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51155 IMPLICIT INTEGER(I-N)
51156 INTEGER PYK,PYCHGE,PYCOMP
51157 C...Parameter statement to help give large particle numbers.
51158 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51159 &KEXCIT=4000000,KDIMEN=5000000)
51161 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51162 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51163 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51164 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51165 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51166 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
51168 C...Local variables.
51169 EXTERNAL PYSIMP,PYLAMF
51170 DOUBLE PRECISION PYSIMP,PYLAMF
51172 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
51173 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
51174 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
51175 DOUBLE PRECISION SUMME(0:100),A(4,8)
51176 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
51177 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
51178 DOUBLE PRECISION XMGLU,GAM
51179 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
51180 &DDD(2),EEE(2),FFF(2)
51181 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
51182 DOUBLE PRECISION ALPHAW,ALPHAS
51183 DOUBLE PRECISION AMC(2)
51185 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
51186 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
51190 DATA IFIRST/.TRUE./
51193 SINB=TANB/SQRT(1D0+TANB**2)
51201 AMBOT=PYMRUN(5,XMGLU**2)
51202 AMTOP=PYMRUN(6,XMGLU**2)
51205 FAKT1=AMBOT/W2/AMW/COSB
51206 FAKT2=AMTOP/W2/AMW/SINB
51211 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
51212 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
51213 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
51214 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
51215 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
51216 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
51217 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
51218 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
51220 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51221 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51222 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51223 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51227 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
51228 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
51229 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
51230 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
51232 COS2A=COSA**2-SINA**2
51233 SIN2A=SINA*COSA*2D0
51234 COS2C=COSC**2-SINC**2
51235 SIN2C=SINC*COSC*2D0
51242 ALPHAW=PYALEM(XMG2)
51243 ALPHAS=PYALPS(XMG2)
51247 XMQ2=XMG2+XMT2+XMB2+XMR2
51248 XMQ4=XMG*XMT*XMB*XMR
51249 XMQ3=XMG2*XMR2+XMT2*XMB2
51250 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
51251 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
51253 XMST(1)=AMST(1)*AMST(1)
51254 XMST(2)=AMST(1)*AMST(1)
51255 XMST(3)=AMST(2)*AMST(2)
51256 XMST(4)=AMST(2)*AMST(2)
51257 XMSB(1)=AMSB(1)*AMSB(1)
51258 XMSB(2)=AMSB(2)*AMSB(2)
51259 XMSB(3)=AMSB(1)*AMSB(1)
51260 XMSB(4)=AMSB(2)*AMSB(2)
51262 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
51263 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
51264 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
51265 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
51266 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
51267 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
51268 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
51269 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
51271 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
51272 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
51273 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
51274 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
51275 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
51276 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
51277 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
51278 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
51280 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
51281 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
51282 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
51283 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
51284 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
51285 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
51286 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
51287 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
51289 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
51290 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
51291 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
51292 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
51293 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
51294 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
51295 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
51296 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
51298 SMAX=(XMG-ABS(XMR))**2
51299 SMIN=(XMB+XMT)**2+0.1D0
51302 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51303 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
51305 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
51306 W=DSQRT(W)/2D0/SBAR
51307 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
51308 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
51309 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
51310 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
51311 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
51312 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
51313 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
51314 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
51315 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
51316 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
51317 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
51318 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
51319 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
51320 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
51321 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
51322 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
51323 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
51324 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
51325 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
51326 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
51327 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
51328 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
51329 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
51330 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
51331 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
51332 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
51333 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
51334 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
51335 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
51336 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
51337 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
51338 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
51339 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
51340 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
51341 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
51342 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
51343 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
51344 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
51345 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
51346 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
51347 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
51348 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
51349 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
51351 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
51352 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
51353 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
51354 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
51355 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
51356 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
51357 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
51358 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
51359 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
51360 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
51361 & -A(J,6)*(XMG2+XMR2-SBAR)
51362 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
51363 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
51364 & /(GRS+XMSB(J)+XMST(J))
51368 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51369 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51374 C*********************************************************************
51377 C...Calculates decay widths for the neutralinos (admixtures of
51378 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
51380 C...Input: KCIN = KF code for particle
51381 C...Output: XLAM = widths
51382 C... IDLAM = KF codes for decay particles
51383 C... IKNT = number of decay channels defined
51384 C...AUTHOR: STEPHEN MRENNA
51386 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
51387 C...when CHIGAMMA .NE. 0
51388 C...10 FEB 96: Calculate this decay for small tan(beta)
51390 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
51392 C...Double precision and integer declarations.
51393 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51394 IMPLICIT INTEGER(I-N)
51395 INTEGER PYK,PYCHGE,PYCOMP
51396 C...Parameter statement to help give large particle numbers.
51397 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51398 &KEXCIT=4000000,KDIMEN=5000000)
51400 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51401 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51402 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51403 c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51405 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51406 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51407 C COMMON/PYINTS/XXM(20)
51409 COMMON/PYINTC/XXC(10),CXC(8)
51410 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51412 C...Local variables.
51413 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
51414 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
51416 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
51417 &XMZ,XMZ2,AXMJ,AXMI
51418 DOUBLE PRECISION S12MIN,S12MAX
51419 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
51420 DOUBLE PRECISION PYLAMF,XL
51421 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
51422 DOUBLE PRECISION PYX2XH,PYX2XG
51423 DOUBLE PRECISION XLAM(0:400)
51424 INTEGER IDLAM(400,3)
51425 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
51426 INTEGER ITH(3),KF1,KF2
51428 DOUBLE PRECISION DH(3),EH(3)
51429 DOUBLE PRECISION SR2
51430 DOUBLE PRECISION CBETA,SBETA
51431 DOUBLE PRECISION GAMCON,XMT1,XMT2
51432 DOUBLE PRECISION PYALEM,PI,PYALPS
51433 DOUBLE PRECISION RAT1,RAT2
51434 DOUBLE PRECISION T3T,FCOL
51435 DOUBLE PRECISION ALFA,BETA,TANB
51436 DOUBLE PRECISION PYXXGA
51437 EXTERNAL PYGAUS,PYXXZ6
51438 DOUBLE PRECISION PYGAUS,PYXXZ6
51439 DOUBLE PRECISION PREC
51440 INTEGER KFNCHI(4),KFCCHI(2)
51444 DATA PI/3.141592654D0/
51445 DATA SR2/1.4142136D0/
51446 DATA KFNCHI/1000022,1000023,1000025,1000035/
51447 DATA KFCCHI/1000024,1000037/
51449 C...COUNT THE NUMBER OF DECAY MODES
51458 TANW = SQRT(XW/XW1)
51460 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
51462 IF(KFIN.EQ.KFNCHI(2)) IX=2
51463 IF(KFIN.EQ.KFNCHI(3)) IX=3
51464 IF(KFIN.EQ.KFNCHI(4)) IX=4
51484 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
51489 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
51490 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
51494 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51495 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
51497 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
51498 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
51502 GAMCON=AEM**3/8D0/PI/XMW2/XW
51503 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
51504 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
51505 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
51506 IDLAM(LKNT,1)=KSUSY1+22
51509 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
51513 C...GRAVITINO DECAY MODES
51515 IF(IMSS(11).EQ.1) THEN
51518 XMGR=PMAS(PYCOMP(IDG),1)
51521 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51522 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
51527 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
51529 IF(AXMI.GT.XMGR+XMZ) THEN
51534 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
51535 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
51536 & (1D0-XMZ2/XMI2)**4
51538 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
51543 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
51544 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
51546 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
51551 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
51552 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
51554 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
51559 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
51560 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
51562 IF(IX.EQ.1) GOTO 300
51570 C...CHI0_I -> CHI0_J + GAMMA
51571 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
51572 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
51573 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
51574 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
51575 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
51576 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
51577 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
51579 IDLAM(LKNT,1)=KFNCHI(IJ)
51582 GAMCON=AEM**3/8D0/PI/XMW2/XW
51583 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
51584 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
51585 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
51589 C...CHI0_I -> CHI0_J + Z0
51590 IF(AXMI.GE.AXMJ+XMZ) THEN
51592 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
51593 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
51595 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51596 GLR=DBLE(OLPP*DCONJG(ORPP))
51597 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
51598 IDLAM(LKNT,1)=KFNCHI(IJ)
51601 ELSEIF(AXMI.GE.AXMJ) THEN
51608 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
51609 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
51611 C...CHARGED LEPTONS
51613 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51614 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51616 T3I=SIGN(1D0,EI+1D-6)/2D0
51617 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51618 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51619 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51620 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51622 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51623 CXC(4)=DCONJG(GLIJ)
51624 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51626 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51627 CXC(8)=-DCONJG(GRIJ)
51629 S12MAX=(AXMI-AXMJ)**2
51630 IF( XXC(5).LT.AXMI ) THEN
51633 IF(XXC(6).LT.AXMI ) THEN
51639 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
51641 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51642 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51643 IDLAM(LKNT,1)=KFNCHI(IJ)
51646 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
51648 XLAM(LKNT)=XLAM(LKNT-1)
51649 IDLAM(LKNT,1)=KFNCHI(IJ)
51655 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51656 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51657 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
51659 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
51660 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51662 IF( XXC(5).LT.AXMI ) THEN
51665 IF(XXC(6).LT.AXMI ) THEN
51671 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
51673 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51674 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51675 IDLAM(LKNT,1)=KFNCHI(IJ)
51683 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51684 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51686 T3I=SIGN(1D0,EI+1D-6)/2D0
51687 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51688 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51689 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51690 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51692 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51693 CXC(4)=DCONJG(GLIJ)
51694 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51696 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51697 CXC(8)=-DCONJG(GRIJ)
51699 S12MAX=(AXMI-AXMJ)**2
51700 IF( XXC(5).LT.AXMI ) THEN
51703 IF( XXC(6).LT.AXMI ) THEN
51710 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51711 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51712 IDLAM(LKNT,1)=KFNCHI(IJ)
51716 XLAM(LKNT)=XLAM(LKNT-1)
51717 IDLAM(LKNT,1)=KFNCHI(IJ)
51722 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
51724 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
51725 IF( XXC(5).LT.AXMI ) THEN
51730 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51731 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51734 XLAM(LKNT)=XLAM(LKNT-1)
51736 IDLAM(LKNT,1)=KFNCHI(IJ)
51742 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51743 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51745 T3I=SIGN(1D0,EI+1D-6)/2D0
51746 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51747 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51748 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51749 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51751 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51752 CXC(4)=DCONJG(GLIJ)
51753 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51755 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51756 CXC(8)=-DCONJG(GRIJ)
51758 S12MAX=(AXMI-AXMJ)**2
51759 IF( XXC(5).LT.AXMI ) THEN
51762 IF( XXC(6).LT.AXMI ) THEN
51768 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51770 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51771 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51772 IDLAM(LKNT,1)=KFNCHI(IJ)
51775 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51777 XLAM(LKNT)=XLAM(LKNT-1)
51778 IDLAM(LKNT,1)=KFNCHI(IJ)
51784 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51785 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51786 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
51788 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
51789 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51791 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
51792 IF(XXC(5).LT.AXMI) THEN
51794 ELSEIF(XXC(6).LT.AXMI) THEN
51799 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51801 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51802 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51803 IDLAM(LKNT,1)=KFNCHI(IJ)
51811 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51812 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51814 T3I=SIGN(1D0,EI+1D-6)/2D0
51815 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51816 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51817 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51818 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51820 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51821 CXC(4)=DCONJG(GLIJ)
51822 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51824 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51825 CXC(8)=-DCONJG(GRIJ)
51827 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
51828 IF(XXC(5).LT.AXMI) THEN
51830 ELSEIF(XXC(6).LT.AXMI) THEN
51836 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51838 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51839 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51840 IDLAM(LKNT,1)=KFNCHI(IJ)
51843 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51845 XLAM(LKNT)=XLAM(LKNT-1)
51846 IDLAM(LKNT,1)=KFNCHI(IJ)
51854 C...CHI0_I -> CHI0_J + H0_K
51861 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
51862 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
51863 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
51864 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
51865 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
51866 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
51867 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
51868 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
51870 XMH=PMAS(ITH(IH),1)
51872 IF(AXMI.GE.AXMJ+XMH) THEN
51874 XL=PYLAMF(XMI2,XMJ2,XMH2)
51875 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
51877 C...SIGN OF MASSES I,J
51879 IF(IH.EQ.3) XMK=-XMK
51880 GX2=ABS(F21K)**2+ABS(F12K)**2
51881 GLR=DBLE(F21K*DCONJG(F12K))
51882 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
51883 IDLAM(LKNT,1)=KFNCHI(IJ)
51884 IDLAM(LKNT,2)=ITH(IH)
51890 C...CHI0_I -> CHI+_J + W-
51895 IF(AXMI.GE.AXMJ+XMW) THEN
51897 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
51898 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
51899 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
51900 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
51901 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
51902 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
51903 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
51904 IDLAM(LKNT,1)=KFCCHI(IJ)
51908 XLAM(LKNT)=XLAM(LKNT-1)
51909 IDLAM(LKNT,1)=-KFCCHI(IJ)
51912 ELSEIF(AXMI.GE.AXMJ) THEN
51914 S12MAX=(AXMI-AXMJ)**2
51915 RT2I = 1D0/SQRT(2D0)
51916 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
51917 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
51918 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
51919 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
51920 CXC(5)=DCMPLX(0D0,0D0)
51921 CXC(7)=DCMPLX(0D0,0D0)
51925 T3I=SIGN(1D0,EI+1D-6)/2D0
51927 T3J=SIGN(1D0,EJ+1D-6)/2D0
51928 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
51929 & TANW+ZMIXC(IX,2)*T3J)*RT2I
51930 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
51931 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
51932 CXC(6)=DCMPLX(0D0,0D0)
51933 CXC(8)=DCMPLX(0D0,0D0)
51938 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51939 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51942 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
51943 IF(XXC(5).LT.AXMI) THEN
51945 ELSEIF(XXC(6).LT.AXMI) THEN
51950 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
51952 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51953 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51954 IDLAM(LKNT,1)=KFCCHI(IJ)
51958 XLAM(LKNT)=XLAM(LKNT-1)
51959 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51960 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51961 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51962 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
51964 XLAM(LKNT)=XLAM(LKNT-1)
51965 IDLAM(LKNT,1)=KFCCHI(IJ)
51969 XLAM(LKNT)=XLAM(LKNT-1)
51970 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51971 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51972 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51976 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51977 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51978 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51980 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51981 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51983 IF(XXC(5).LT.AXMI) THEN
51986 IF(XXC(6).LT.AXMI) THEN
51991 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51993 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51994 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51995 XLAM(LKNT)=XLAM(LKNT-1)
51996 IDLAM(LKNT,1)=KFCCHI(IJ)
52000 XLAM(LKNT)=XLAM(LKNT-1)
52001 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52002 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52003 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52006 C...NOW, DO THE QUARKS
52011 T3I=SIGN(1D0,EI+1D-6)/2D0
52013 T3J=SIGN(1D0,EJ+1D-6)/2D0
52014 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
52015 & TANW+ZMIXC(IX,2)*T3J)
52016 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
52017 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
52018 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
52019 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
52020 IF(XXC(5).LT.AXMI) THEN
52023 IF(XXC(6).LT.AXMI) THEN
52028 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
52030 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52031 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52032 IDLAM(LKNT,1)=KFCCHI(IJ)
52036 XLAM(LKNT)=XLAM(LKNT-1)
52037 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52038 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52039 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52040 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52042 XLAM(LKNT)=XLAM(LKNT-1)
52043 IDLAM(LKNT,1)=KFCCHI(IJ)
52047 XLAM(LKNT)=XLAM(LKNT-1)
52048 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52049 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52050 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52058 C...CHI0_I -> CHI+_I + H-
52064 IF(AXMI.GE.AXMJ+XMHP) THEN
52066 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
52067 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
52068 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
52069 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
52071 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52072 GLR=DBLE(OLPP*DCONJG(ORPP))
52073 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52074 IDLAM(LKNT,1)=KFCCHI(IJ)
52075 IDLAM(LKNT,2)=-ITHC
52078 XLAM(LKNT)=XLAM(LKNT-1)
52079 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52080 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52081 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52087 C...2-BODY DECAYS TO FERMION SFERMION
52089 IF(J.GE.7.AND.J.LE.10) GOTO 290
52092 XMSF1=PMAS(PYCOMP(KF1),1)
52093 XMSF2=PMAS(PYCOMP(KF2),1)
52103 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
52104 IF(MOD(J,2).EQ.0) THEN
52105 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52106 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
52107 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52110 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52111 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
52112 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52117 IF(AXMI.GE.XMF+XMSF1) THEN
52121 XL=PYLAMF(XMI2,XMA2,XMB2)
52122 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
52123 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
52124 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52125 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52130 XLAM(LKNT)=XLAM(LKNT-1)
52131 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52132 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52137 IF(AXMI.GE.XMF+XMSF2) THEN
52141 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
52142 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
52143 XL=PYLAMF(XMI2,XMA2,XMB2)
52144 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52145 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52150 XLAM(LKNT)=XLAM(LKNT-1)
52151 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52152 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52157 C...3-BODY DECAY TO Q Q~ GLUINO
52158 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52159 IF(AXMI.GE.XMJ) THEN
52160 RT2I = 1D0/SQRT(2D0)
52161 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
52169 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52170 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52176 T3I=SIGN(1D0,EI+1D-6)/2D0
52177 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52178 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52182 CXC(4)=DCONJG(GLIJ)
52186 CXC(8)=-DCONJG(GRIJ)
52188 S12MAX=(AXMI-AXMJ)**2
52189 CMRENNA.This statement must be here to define S12MAX
52190 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
52191 C...ALL QUARKS BUT T
52192 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52194 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
52195 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52196 IDLAM(LKNT,1)=KSUSY1+21
52199 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52201 XLAM(LKNT)=XLAM(LKNT-1)
52202 IDLAM(LKNT,1)=KSUSY1+21
52208 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52209 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52210 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
52212 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
52213 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52215 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
52218 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52220 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
52221 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52222 IDLAM(LKNT,1)=KSUSY1+21
52229 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52230 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52231 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
52235 T3I=SIGN(1D0,EI+1D-6)/2D0
52236 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52237 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52239 CXC(4)=DCONJG(GLIJ)
52241 CXC(8)=-DCONJG(GRIJ)
52242 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52244 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
52245 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52246 IDLAM(LKNT,1)=KSUSY1+21
52249 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52251 XLAM(LKNT)=XLAM(LKNT-1)
52252 IDLAM(LKNT,1)=KSUSY1+21
52260 C...R-violating decay modes (SKANDS).
52261 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
52266 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
52267 XLAM(0)=XLAM(0)+XLAM(I)
52269 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
52274 C*********************************************************************
52277 C...Calculate decay widths for the charginos (admixtures of
52278 C...charged Wino and charged Higgsino.
52280 C...Input: KCIN = KF code for particle
52281 C...Output: XLAM = widths
52282 C... IDLAM = KF codes for decay particles
52283 C... IKNT = number of decay channels defined
52284 C...AUTHOR: STEPHEN MRENNA
52286 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
52287 C...when CHIENU .NE. 0
52289 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
52291 C...Double precision and integer declarations.
52292 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52293 IMPLICIT INTEGER(I-N)
52294 INTEGER PYK,PYCHGE,PYCOMP
52295 C...Parameter statement to help give large particle numbers.
52296 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52297 &KEXCIT=4000000,KDIMEN=5000000)
52299 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52300 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52301 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52302 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52303 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52305 C COMMON/PYINTS/XXM(20)
52307 COMMON/PYINTC/XXC(10),CXC(8)
52308 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
52310 C...Local variables
52311 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
52312 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
52314 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
52315 &XMZ,XMZ2,AXMJ,AXMI
52316 DOUBLE PRECISION S12MIN,S12MAX
52317 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
52318 DOUBLE PRECISION PYLAMF,XL
52319 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
52320 DOUBLE PRECISION PYX2XH,PYX2XG
52321 DOUBLE PRECISION XLAM(0:400)
52322 INTEGER IDLAM(400,3)
52323 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
52326 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
52327 DOUBLE PRECISION SR2
52328 DOUBLE PRECISION CBETA,SBETA,TANB
52330 DOUBLE PRECISION PYALEM,PI,PYALPS
52331 DOUBLE PRECISION FCOL
52332 INTEGER KF1,KF2,ISF
52333 INTEGER KFNCHI(4),KFCCHI(2)
52335 DOUBLE PRECISION TEMP
52336 EXTERNAL PYGAUS,PYXXZ6
52337 DOUBLE PRECISION PYGAUS,PYXXZ6
52338 DOUBLE PRECISION PREC
52341 DATA ETAH/1D0,1D0,-1D0/
52342 DATA SR2/1.4142136D0/
52343 DATA PI/3.141592654D0/
52345 DATA KFNCHI/1000022,1000023,1000025,1000035/
52346 DATA KFCCHI/1000024,1000037/
52348 C...COUNT THE NUMBER OF DECAY MODES
52356 TANW = SQRT(XW/XW1)
52358 C...1 OR 2 DEPENDING ON CHARGINO TYPE
52360 IF(KFIN.EQ.KFCCHI(2)) IX=2
52378 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52379 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52383 C...GRAVITINO DECAY MODES
52385 IF(IMSS(11).EQ.1) THEN
52388 XMGR=PMAS(PYCOMP(IDG),1)
52390 C COSW=SQRT(1D0-XW)
52391 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
52392 IF(AXMI.GT.XMGR+XMW) THEN
52398 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
52399 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
52400 & (1D0-XMW2/XMI2)**4
52402 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
52407 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
52408 & (ABS(UMIXC(IX,2))*SBETA)**2))
52409 & *(1D0-PMAS(37,1)**2/XMI2)**4
52413 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52414 IF(IX.EQ.1) GOTO 170
52419 C...CHI_2+ -> CHI_1+ + Z0
52420 IF(AXMI.GE.AXMJ+XMZ) THEN
52423 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
52424 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
52425 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
52426 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
52427 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52428 GLR=DBLE(OLPP*DCONJG(ORPP))
52429 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
52430 IDLAM(LKNT,1)=KFCCHI(1)
52434 C...CHARGED LEPTONS
52435 ELSEIF(AXMI.GE.AXMJ) THEN
52437 S12MAX=(AXMI-AXMJ)**2
52440 EI=KCHG(IABS(IA),1)/3D0
52441 T3I=SIGN(1D0,EI+1D-6)/2D0
52446 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52451 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
52452 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
52453 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
52454 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
52455 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52456 CXC(2)=DCMPLX(0D0,0D0)
52457 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52458 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
52459 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52460 CXC(6)=DCMPLX(0D0,0D0)
52461 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52462 CXC(8)=DCMPLX(0D0,0D0)
52463 IF( XXC(5).LT.AXMI ) THEN
52468 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
52470 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52471 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52472 IDLAM(LKNT,1)=KFCCHI(1)
52475 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
52477 XLAM(LKNT)=XLAM(LKNT-1)
52478 IDLAM(LKNT,1)=KFCCHI(1)
52482 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
52484 XLAM(LKNT)=XLAM(LKNT-1)
52485 IDLAM(LKNT,1)=KFCCHI(1)
52495 EI=KCHG(IABS(IA),1)/3D0
52496 T3I=SIGN(1D0,EI+1D-6)/2D0
52497 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52499 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52500 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52501 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
52502 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52503 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52504 IF( XXC(5).LT.AXMI ) THEN
52509 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
52511 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52512 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52513 IDLAM(LKNT,1)=KFCCHI(1)
52517 XLAM(LKNT)=XLAM(LKNT-1)
52518 IDLAM(LKNT,1)=KFCCHI(1)
52522 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
52523 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52524 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
52526 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
52528 IF( XXC(5).LT.AXMI ) THEN
52533 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52534 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52535 IDLAM(LKNT,1)=KFCCHI(1)
52544 EI=KCHG(IABS(IA),1)/3D0
52545 T3I=SIGN(1D0,EI+1D-6)/2D0
52546 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52548 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52549 CXC(2)=DCMPLX(0D0,0D0)
52550 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52551 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
52552 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52553 CXC(6)=DCMPLX(0D0,0D0)
52554 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52555 CXC(8)=DCMPLX(0D0,0D0)
52556 IF( XXC(5).LT.AXMI ) THEN
52561 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52563 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52564 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52565 IDLAM(LKNT,1)=KFCCHI(1)
52568 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52570 XLAM(LKNT)=XLAM(LKNT-1)
52571 IDLAM(LKNT,1)=KFCCHI(1)
52576 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52577 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52578 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52580 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52582 IF( XXC(5).LT.AXMI ) THEN
52587 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52588 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52589 IDLAM(LKNT,1)=KFCCHI(1)
52598 EI=KCHG(IABS(IA),1)/3D0
52599 T3I=SIGN(1D0,EI+1D-6)/2D0
52600 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52602 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52603 CXC(2)=DCMPLX(0D0,0D0)
52604 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52605 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
52606 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52607 CXC(6)=DCMPLX(0D0,0D0)
52608 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52609 CXC(8)=DCMPLX(0D0,0D0)
52610 IF( XXC(5).LT.AXMI ) THEN
52615 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52617 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52618 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52619 IDLAM(LKNT,1)=KFCCHI(1)
52622 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52624 XLAM(LKNT)=XLAM(LKNT-1)
52625 IDLAM(LKNT,1)=KFCCHI(1)
52633 C...CHI_2+ -> CHI_1+ + H0_K
52641 XMH=PMAS(ITH(IH),1)
52643 C...NO 3-BODY OPTION
52644 IF(AXMI.GE.AXMJ+XMH) THEN
52646 XL=PYLAMF(XMI2,XMJ2,XMH2)
52647 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
52648 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
52649 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
52650 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
52652 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52653 GLR=DBLE(OLPP*DCONJG(ORPP))
52654 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
52655 IDLAM(LKNT,1)=KFCCHI(1)
52656 IDLAM(LKNT,2)=ITH(IH)
52661 C...CHI1 JUMPS TO HERE
52664 C...CHI+_I -> CHI0_J + W+
52669 IF(AXMI.GE.AXMJ+XMW) THEN
52672 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
52674 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
52675 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
52676 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
52677 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
52678 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
52679 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
52680 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
52681 IDLAM(LKNT,1)=KFNCHI(IJ)
52685 ELSEIF(AXMI.GE.AXMJ) THEN
52687 S12MAX=(AXMI-AXMJ)**2
52689 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
52691 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
52692 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
52693 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
52694 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
52695 CXC(5)=DCMPLX(0D0,0D0)
52696 CXC(7)=DCMPLX(0D0,0D0)
52700 T3I=SIGN(1D0,EI+1D-6)/2D0
52702 T3J=SIGN(1D0,EJ+1D-6)/2D0
52703 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
52704 & TANW+ZMIXC(IJ,2)*T3J)/SR2
52705 CXC(4)=-DCONJG(UMIXC(IX,1))*(
52706 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
52707 CXC(6)=DCMPLX(0D0,0D0)
52708 CXC(8)=DCMPLX(0D0,0D0)
52713 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52714 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52717 CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
52718 IF(XXC(5).LT.AXMI) THEN
52720 ELSEIF(XXC(6).LT.AXMI) THEN
52725 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
52726 C...--> 1/(16PI)/M**3*(AEM/XW)**2
52727 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
52729 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52730 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
52731 IDLAM(LKNT,1)=KFNCHI(IJ)
52734 C...ONLY DECAY CHI+1 -> E+ NU_E
52735 IF( IMSS(12).NE. 0 ) GOTO 260
52736 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
52738 XLAM(LKNT)=XLAM(LKNT-1)
52739 IDLAM(LKNT,1)=KFNCHI(IJ)
52744 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
52746 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52747 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
52749 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
52751 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
52752 IF(XXC(5).LT.AXMI) THEN
52754 ELSEIF(XXC(6).LT.AXMI) THEN
52759 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52760 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
52761 IDLAM(LKNT,1)=KFNCHI(IJ)
52766 C...NOW, DO THE QUARKS
52771 T3I=SIGN(1D0,EI+1D-6)/2D0
52773 T3J=SIGN(1D0,EJ+1D-6)/2D0
52774 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
52775 & TANW+ZMIXC(IJ,2)*T3J)
52776 CXC(4)=-DCONJG(UMIXC(IX,1))*(
52777 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
52778 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52779 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52780 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
52781 IF(XXC(5).LT.AXMI) THEN
52784 IF(XXC(6).LT.AXMI) THEN
52789 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
52791 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52792 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52793 IDLAM(LKNT,1)=KFNCHI(IJ)
52796 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52798 XLAM(LKNT)=XLAM(LKNT-1)
52799 IDLAM(LKNT,1)=KFNCHI(IJ)
52808 C...CHI+_I -> CHI0_J + H+
52814 IF(AXMI.GE.AXMJ+XMHP) THEN
52816 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
52817 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
52818 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
52819 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
52821 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52822 GLR=DBLE(OLPP*DCONJG(ORPP))
52823 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52824 IDLAM(LKNT,1)=KFNCHI(IJ)
52832 C...2-BODY DECAYS TO FERMION SFERMION
52834 IF(J.GE.7.AND.J.LE.10) GOTO 240
52835 IF(MOD(J,2).EQ.0) THEN
52841 XMSF1=PMAS(PYCOMP(KF1),1)
52842 XMSF2=PMAS(PYCOMP(KF2),1)
52851 IF(MOD(J,2).EQ.0) THEN
52854 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
52855 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
52861 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
52863 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
52868 IF(AXMI.GE.XMF+XMSF1) THEN
52872 XL=PYLAMF(XMI2,XMA2,XMB2)
52873 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
52874 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
52875 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52876 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52878 IF(MOD(J,2).EQ.0) THEN
52888 IF(AXMI.GE.XMF+XMSF2) THEN
52892 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
52893 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
52894 XL=PYLAMF(XMI2,XMA2,XMB2)
52895 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52896 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52898 IF(MOD(J,2).EQ.0) THEN
52908 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
52909 C...A 2-BODY -- 2-BODY CHAIN
52910 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52911 IF(AXMI.GE.XMJ) THEN
52914 S12MAX=(AXMI-AXMJ)**2
52919 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
52920 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
52923 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
52925 CXC(1)=DCMPLX(0D0,0D0)
52926 CXC(3)=DCMPLX(0D0,0D0)
52927 CXC(5)=DCMPLX(0D0,0D0)
52928 CXC(7)=DCMPLX(0D0,0D0)
52929 CXC(2)=UMIXC(IX,1)*OLPP/SR2
52930 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
52931 CXC(6)=DCMPLX(0D0,0D0)
52932 CXC(8)=DCMPLX(0D0,0D0)
52933 IF(XXC(5).LT.AXMI) THEN
52935 ELSEIF(XXC(6).LT.AXMI) THEN
52940 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
52941 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
52943 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
52944 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52945 IDLAM(LKNT,1)=KSUSY1+21
52948 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52950 XLAM(LKNT)=XLAM(LKNT-1)
52951 IDLAM(LKNT,1)=KSUSY1+21
52959 C...R-violating decay modes (SKANDS).
52960 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
52965 XLAM(0)=XLAM(0)+XLAM(I)
52966 IF(XLAM(I).LT.0D0) THEN
52967 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
52968 & (IDLAM(I,J),J=1,3)
52972 IF(XLAM(0).EQ.0D0) THEN
52974 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
52975 WRITE(MSTU(11),*) LKNT
52976 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
52982 C*********************************************************************
52985 C...Used in the calculation of inoi -> inoj + f + ~f.
52989 C...Double precision and integer declarations.
52990 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52991 IMPLICIT INTEGER(I-N)
52992 INTEGER PYK,PYCHGE,PYCOMP
52993 C...Parameter statement to help give large particle numbers.
52994 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52995 &KEXCIT=4000000,KDIMEN=5000000)
52997 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52998 C COMMON/PYINTS/XXM(20)
53000 COMMON/PYINTC/XXC(10),CXC(8)
53001 SAVE /PYDAT1/,/PYINTC/
53003 C...Local variables.
53004 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
53005 DOUBLE PRECISION PYXXZ6,X
53006 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
53007 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
53008 DOUBLE PRECISION SIJ
53009 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
53010 DOUBLE PRECISION OL2
53011 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
53014 C...Statement functions.
53015 C...Integral from x to y of (t-a)(b-t) dt.
53016 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
53017 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
53018 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
53019 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
53020 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
53021 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
53022 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
53023 C...Integral from x to y of (t-a)/(b-t) dt.
53024 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
53025 C...Integral from x to y of 1/(t-a) dt.
53026 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
53034 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
53035 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
53036 &( (X-XM22-S)**2 -4D0*XM22*S ) )
53038 S23MIN=(S23AVE-S23DEL)
53039 S23MAX=(S23AVE+S23DEL)
53056 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
53057 SIJ=2D0*XXC(2)*XXC(4)*S13
53058 IF(XMV.LE.1000D0) THEN
53059 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
53060 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
53061 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
53062 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
53063 IF(XXC(5).LE.10000D0) THEN
53064 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
53065 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
53066 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
53067 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
53068 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
53069 & *(S13-XMV**2)/WPROP2
53074 IF(XXC(6).LE.10000D0) THEN
53075 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
53076 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
53077 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
53078 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
53079 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
53080 & *(S13-XMV**2)/WPROP2
53089 IF(XXC(5).LE.10000D0) THEN
53090 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
53091 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
53092 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
53093 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
53097 IF(XXC(6).LE.10000D0) THEN
53098 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
53099 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
53100 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
53101 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
53106 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
53108 IF(PYXXZ6.LT.0D0) THEN
53109 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
53110 WRITE(MSTU(11),*) (XXC(I),I=1,5)
53111 WRITE(MSTU(11),*) (XXC(I),I=6,10)
53112 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
53113 WRITE(MSTU(11),*) S23MIN,S23MAX
53121 C*********************************************************************
53124 C...Calculates chi0_i -> chi0_j + gamma.
53126 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
53128 C...Double precision and integer declarations.
53129 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53130 IMPLICIT INTEGER(I-N)
53131 INTEGER PYK,PYCHGE,PYCOMP
53133 C...Local variables.
53134 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
53135 DOUBLE PRECISION F1,F2
53137 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
53138 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
53139 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
53140 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
53145 C*********************************************************************
53148 C...Calculates the decay rate for ino -> ino + gauge boson.
53150 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
53152 C...Double precision and integer declarations.
53153 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53154 IMPLICIT INTEGER(I-N)
53155 INTEGER PYK,PYCHGE,PYCOMP
53157 C...Local variables.
53158 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
53159 DOUBLE PRECISION XL,PYLAMF,C1
53160 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53166 XL=PYLAMF(XMI2,XMJ2,XMV2)
53167 PYX2XG=C1/8D0/XMI3*SQRT(XL)
53168 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
53169 &12D0*GLR*XM1*XM2*XMV2)
53174 C*********************************************************************
53177 C...Calculates the decay rate for ino -> ino + H.
53179 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
53181 C...Double precision and integer declarations.
53182 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53183 IMPLICIT INTEGER(I-N)
53184 INTEGER PYK,PYCHGE,PYCOMP
53186 C...Local variables.
53187 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
53188 DOUBLE PRECISION XL,PYLAMF,C1
53189 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53195 XL=PYLAMF(XMI2,XMJ2,XMV2)
53196 PYX2XH=C1/8D0/XMI3*SQRT(XL)
53197 &*(GX2*(XMI2+XMJ2-XMV2)+
53203 C*********************************************************************
53206 C...Calculates the non-standard decay modes of the Higgs boson.
53208 C...Author: Stephen Mrenna
53209 C...Last Update: April 2001
53210 C......Allow complex values for Z,U, and V
53212 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
53214 C...Double precision and integer declarations.
53215 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53216 IMPLICIT INTEGER(I-N)
53217 INTEGER PYK,PYCHGE,PYCOMP
53218 C...Parameter statement to help give large particle numbers.
53219 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53220 &KEXCIT=4000000,KDIMEN=5000000)
53222 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53223 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53224 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53225 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
53226 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53227 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53228 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
53230 C...Local variables.
53231 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
53232 COMPLEX*16 QIJ,RIJ,F21K,F12K
53234 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
53235 DOUBLE PRECISION XMI2,XMI3,XMJ2
53236 DOUBLE PRECISION PYLAMF,XL,CF,EI
53238 DOUBLE PRECISION TANW,XW,AEM,C1,AS
53239 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
53240 DOUBLE PRECISION XLAM(0:400)
53241 INTEGER IDLAM(400,3)
53242 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
53244 INTEGER KFNCHI(4),KFCCHI(2)
53245 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
53246 DOUBLE PRECISION SR2
53247 DOUBLE PRECISION BETA,ALFA
53248 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
53249 DOUBLE PRECISION PYALEM
53250 DOUBLE PRECISION AL,AR,ALR
53251 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
53252 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
53253 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
53254 DATA ITH/25,35,36,37/
53255 DATA ETAH/1D0,1D0,-1D0/
53256 DATA SR2/1.4142136D0/
53257 DATA KFNCHI/1000022,1000023,1000025,1000035/
53258 DATA KFCCHI/1000024,1000037/
53260 C...COUNT THE NUMBER OF DECAY MODES
53267 TANW = SQRT(XW/(1D0-XW))
53270 C...1 - 4 DEPENDING ON Higgs species.
53272 IF(KFIN.EQ.ITH(2)) IH=2
53273 IF(KFIN.EQ.ITH(3)) IH=3
53274 IF(KFIN.EQ.ITH(4)) IH=4
53297 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
53302 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
53303 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
53308 IF(IH.EQ.4) GOTO 220
53310 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
53311 C...H0_K -> CHI0_I + CHI0_J
53324 IF(AXMI.GE.AXMJ+AXMK) THEN
53326 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
53327 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
53328 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
53329 & ZMIXC(IJ,3)*ZMIXC(IK,1))
53330 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
53331 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
53332 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
53333 & ZMIXC(IJ,4)*ZMIXC(IK,1))
53334 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
53335 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
53336 C...SIGN OF MASSES I,J
53338 GX2=ABS(F12K)**2+ABS(F21K)**2
53339 GLR=DBLE(F12K*DCONJG(F21K))
53340 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
53341 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
53342 IDLAM(LKNT,1)=KFNCHI(IJ)
53343 IDLAM(LKNT,2)=KFNCHI(IK)
53349 C...H0_K -> CHI+_I CHI-_J
53356 IF(AXMI.GE.AXMJ+AXMK) THEN
53358 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
53359 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
53360 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
53361 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
53362 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53363 GLR=DBLE(OLPP*DCONJG(ORPP))
53365 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
53366 IDLAM(LKNT,1)=KFCCHI(IJ)
53367 IDLAM(LKNT,2)=-KFCCHI(IK)
53373 C...HIGGS TO SFERMION SFERMION
53375 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
53377 XMJL=PMAS(PYCOMP(IJ),1)
53378 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
53379 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
53382 XL=PYLAMF(XMI2,XMJ2,XMJ2)
53389 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
53390 & XMF**2/XMW*SINA/CBETA
53391 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
53392 & XMF**2/XMW*SINA/CBETA
53394 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
53396 ELSEIF(IFL.EQ.15) THEN
53397 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
53403 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
53404 & XMF**2/XMW*COSA/SBETA
53405 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
53406 & XMF**2/XMW*COSA/SBETA
53408 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
53415 ELSEIF(IH.EQ.2) THEN
53417 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
53418 & XMF**2/XMW*COSA/CBETA
53419 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
53420 & XMF**2/XMW*COSA/CBETA
53422 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
53424 ELSEIF(IFL.EQ.15) THEN
53425 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
53431 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
53432 & XMF**2/XMW*SINA/SBETA
53433 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
53434 & XMF**2/XMW*SINA/SBETA
53436 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
53443 ELSEIF(IH.EQ.3) THEN
53449 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
53450 ELSEIF(IFL.EQ.15) THEN
53451 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
53455 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
53459 IF(IH.EQ.3) GOTO 180
53463 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
53470 IF(AXMI.GE.2D0*XMJ) THEN
53472 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53474 & +2D0*GHLR*ALR)**2
53480 IF(AXMI.GE.2D0*XMJR) THEN
53484 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
53487 XL=PYLAMF(XMI2,XMJ2,XMJ2)
53488 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53490 & +2D0*GHLR*ALR)**2
53491 IDLAM(LKNT,1)=IJ+KSUSY1
53492 IDLAM(LKNT,2)=-(IJ+KSUSY1)
53497 IF(AXMI.GE.XMJL+XMJR) THEN
53499 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
53500 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
53501 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
53504 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
53505 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53506 & (GHLL*AL+GHRR*AR)**2
53508 IDLAM(LKNT,2)=-(IJ+KSUSY1)
53512 IDLAM(LKNT,2)=IJ+KSUSY1
53514 XLAM(LKNT)=XLAM(LKNT-1)
53524 C...H+ -> CHI+_I + CHI0_J
53532 IF(AXMI.GE.AXMJ+AXMK) THEN
53534 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
53535 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
53536 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
53537 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
53538 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53539 GLR=DBLE(OLPP*DCONJG(ORPP))
53540 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
53541 IDLAM(LKNT,1)=KFNCHI(IJ)
53542 IDLAM(LKNT,2)=KFCCHI(IK)
53548 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
53549 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
53555 XM1=PMAS(PYCOMP(KSUSY1+6),1)
53556 XM2=PMAS(PYCOMP(KSUSY1+5),1)
53557 IF(XMI.GE.XM1+XM2) THEN
53558 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53560 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53561 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
53562 IDLAM(LKNT,1)=KSUSY1+6
53563 IDLAM(LKNT,2)=-(KSUSY1+5)
53568 XM1=PMAS(PYCOMP(KSUSY2+6),1)
53569 XM2=PMAS(PYCOMP(KSUSY1+5),1)
53570 IF(XMI.GE.XM1+XM2) THEN
53571 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53573 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53574 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
53575 IDLAM(LKNT,1)=KSUSY2+6
53576 IDLAM(LKNT,2)=-(KSUSY1+5)
53581 XM1=PMAS(PYCOMP(KSUSY1+6),1)
53582 XM2=PMAS(PYCOMP(KSUSY2+5),1)
53583 IF(XMI.GE.XM1+XM2) THEN
53584 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53586 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53587 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
53588 IDLAM(LKNT,1)=KSUSY1+6
53589 IDLAM(LKNT,2)=-(KSUSY2+5)
53594 XM1=PMAS(PYCOMP(KSUSY2+6),1)
53595 XM2=PMAS(PYCOMP(KSUSY2+5),1)
53596 IF(XMI.GE.XM1+XM2) THEN
53597 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53599 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53600 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
53601 IDLAM(LKNT,1)=KSUSY2+6
53602 IDLAM(LKNT,2)=-(KSUSY2+5)
53607 GL=-XMW/SR2*SIN(2D0*BETA)
53609 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
53610 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
53611 IF(XMI.GE.XM1+XM2) THEN
53612 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53614 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
53615 IDLAM(LKNT,1)=-(KSUSY1+IJ)
53616 IDLAM(LKNT,2)=KSUSY1+IJ+1
53624 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
53625 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
53626 IF(XMI.GE.XM1+XM2) THEN
53627 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53629 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
53630 IDLAM(LKNT,1)=-(KSUSY1+IJ)
53631 IDLAM(LKNT,2)=KSUSY1+IJ+1
53636 C...H+ -> TAU1 NUTAUL
53637 XM1=PMAS(PYCOMP(KSUSY1+15),1)
53638 XM2=PMAS(PYCOMP(KSUSY1+16),1)
53639 IF(XMI.GE.XM1+XM2) THEN
53640 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53642 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
53643 IDLAM(LKNT,1)=-(KSUSY1+15)
53644 IDLAM(LKNT,2)= KSUSY1+16
53648 C...H+ -> TAU2 NUTAUL
53649 XM1=PMAS(PYCOMP(KSUSY2+15),1)
53650 XM2=PMAS(PYCOMP(KSUSY1+16),1)
53651 IF(XMI.GE.XM1+XM2) THEN
53652 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53654 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
53655 IDLAM(LKNT,1)=-(KSUSY2+15)
53656 IDLAM(LKNT,2)= KSUSY1+16
53664 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
53665 XLAM(0)=XLAM(0)+XLAM(I)
53667 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
53672 C*********************************************************************
53675 C...Calculates the decay rate for a Higgs to an ino pair.
53677 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
53679 C...Double precision and integer declarations.
53680 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53681 IMPLICIT INTEGER(I-N)
53682 INTEGER PYK,PYCHGE,PYCOMP
53684 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53687 C...Local variables.
53688 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
53689 DOUBLE PRECISION XL,PYLAMF,C1
53690 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
53696 XL=PYLAMF(XMI2,XMJ2,XMK2)
53697 PYH2XX=C1/4D0/XMI3*SQRT(XL)
53698 &*(GX2*(XMI2-XMJ2-XMK2)-
53700 IF(PYH2XX.LT.0D0) PYH2XX=0D0
53705 C*********************************************************************
53708 C...Integration by adaptive Gaussian quadrature.
53709 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53711 FUNCTION PYGAUS(F, A, B, EPS)
53713 C...Double precision and integer declarations.
53714 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53715 IMPLICIT INTEGER(I-N)
53716 INTEGER PYK,PYCHGE,PYCOMP
53718 C...Local declarations.
53720 DOUBLE PRECISION F,W(12), X(12)
53721 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53722 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53723 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
53724 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
53725 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
53726 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
53727 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
53728 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
53729 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
53730 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
53731 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
53732 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
53734 C...The Gaussian quadrature algorithm.
53736 IF(B .EQ. A) GOTO 140
53737 CONST = 5D-3 / ABS(B-A)
53748 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
53753 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
53756 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
53758 IF(BB .NE. B) GOTO 100
53761 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
53763 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
53772 C*********************************************************************
53775 C...Integration by adaptive Gaussian quadrature.
53776 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53777 C...Carbon copy of PYGAUS, but avoids having to use it recursively.
53779 FUNCTION PYGAU2(F, A, B, EPS)
53781 C...Double precision and integer declarations.
53782 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53783 IMPLICIT INTEGER(I-N)
53784 INTEGER PYK,PYCHGE,PYCOMP
53786 C...Local declarations.
53788 DOUBLE PRECISION F,W(12), X(12)
53789 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53790 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53791 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
53792 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
53793 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
53794 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
53795 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
53796 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
53797 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
53798 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
53799 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
53800 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
53802 C...The Gaussian quadrature algorithm.
53804 IF(B .EQ. A) GOTO 140
53805 CONST = 5D-3 / ABS(B-A)
53816 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
53821 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
53824 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
53826 IF(BB .NE. B) GOTO 100
53829 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
53831 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
53840 C*********************************************************************
53843 C...Simpson formula for an integral.
53845 FUNCTION PYSIMP(Y,X0,X1,N)
53847 C...Double precision and integer declarations.
53848 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53849 IMPLICIT INTEGER(I-N)
53850 INTEGER PYK,PYCHGE,PYCOMP
53852 C...Local variables.
53853 DOUBLE PRECISION Y,X0,X1,H,S
53859 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
53866 C*********************************************************************
53869 C...The standard lambda function.
53871 FUNCTION PYLAMF(X,Y,Z)
53873 C...Double precision and integer declarations.
53874 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53875 IMPLICIT INTEGER(I-N)
53876 INTEGER PYK,PYCHGE,PYCOMP
53878 C...Local variables.
53879 DOUBLE PRECISION PYLAMF,X,Y,Z
53881 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
53882 IF(PYLAMF.LT.0D0) PYLAMF=0D0
53887 C*********************************************************************
53890 C...Generates 3-body decays of gauginos.
53892 SUBROUTINE PYTBDY(IDIN)
53894 C...Double precision and integer declarations.
53895 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53896 IMPLICIT INTEGER(I-N)
53897 INTEGER PYK,PYCHGE,PYCOMP
53898 C...Parameter statement to help give large particle numbers.
53899 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53900 &KEXCIT=4000000,KDIMEN=5000000)
53902 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53903 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53904 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53905 C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
53906 C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53907 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53908 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53909 C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
53910 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
53912 C...Local variables.
53913 DOUBLE PRECISION XM(5)
53914 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
53915 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
53916 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
53917 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
53918 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
53919 DOUBLE PRECISION CPHI1,SPHI1
53920 DOUBLE PRECISION S23DEL,EPS
53921 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
53922 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
53923 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
53925 DATA INOID/22,23,25,35/
53936 S12MIN=(XM(1)+XM(2))**2
53937 S12MAX=(XM(5)-XM(3))**2
53938 YJACO1=S12MAX-S12MIN
53940 C...Initialize some parameters
53952 C...Mrenna: check that we are indeed decaying a SUSY particle
53953 IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
53957 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
53958 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
53960 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
53961 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
53962 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
53963 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
53966 EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
53967 T3I=SIGN(1D0,EI+1D-6)/2D0
53970 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
53972 ELSEIF(IZID1*IZID2.NE.0) THEN
53974 GMMZ=PMAS(23,1)*PMAS(23,2)
53976 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
53977 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
53979 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
53980 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
53982 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
53984 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
53986 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
53987 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
53988 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
53989 XM1M2=SMZ(IZID1)*SMZ(IZID2)
53990 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
53992 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
53994 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
53996 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
53998 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
53999 IF(IZID1.NE.0) THEN
54000 XM1M2=SMZ(IZID1)*SMW(IWID2)
54004 XM1M2=SMZ(IZID2)*SMW(IWID1)
54007 RT2I = 1D0/SQRT(2D0)
54009 GMMZ=PMAS(24,1)*PMAS(24,2)
54011 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54012 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54015 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
54017 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
54018 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
54019 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
54020 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
54021 EJ=KCHG(IABS(JA),1)/3D0
54022 T3J=SIGN(1D0,EJ+1D-6)/2D0
54023 QRLS=DCMPLX(0D0,0D0)
54029 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
54030 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
54031 IF(MOD(IA,2).EQ.0) THEN
54032 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
54033 & TANW+ZMIXC(IZID2,2)*T3I)
54034 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54035 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
54037 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
54038 & TANW+ZMIXC(IZID2,2)*T3J)
54039 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54040 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
54042 ELSEIF(IWID1*IWID2.NE.0) THEN
54045 XM1M2=SMW(IWID1)*SMW(IWID2)
54047 GMMZ=PMAS(23,1)*PMAS(23,2)
54049 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54050 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54051 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
54052 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
54054 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
54055 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
54056 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
54057 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
54058 QRLS=-DCMPLX(EI/XW1)*ORPP
54059 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
54060 QRRS=-DCMPLX(EI/XW1)*OLPP
54061 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
54062 IF(MOD(IA,2).EQ.0) THEN
54063 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
54064 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
54066 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
54067 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
54069 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
54076 IF(ISKIP.NE.0) THEN
54079 S12=S12MIN+YJACO1*(KT-1)/99
54080 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54081 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54082 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54083 & -(2D0*XM(1)*XM(2))**2
54084 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54085 & -(2D0*XM(3)*XM(5))**2
54088 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54090 S23MIN=S23AVE-S23DEL
54091 S23MAX=S23AVE+S23DEL
54092 YJACO2=S23MAX-S23MIN
54095 S23=S23MIN+YJACO2*(KS-1)/99
54098 WU2 = (UH-ZM12)*(UH-ZM22)
54099 WT2 = (TH-ZM12)*(TH-ZM22)
54101 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54102 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54103 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54104 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54105 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54106 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54107 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54108 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
54109 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54110 IF(WT0.GT.WTMAX) WTMAX=WT0
54120 BX=S12MIN+0.5D0*YJACO1
54123 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
54131 C...SOLVE FOR F1 AND F2
54132 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54133 &-(2D0*XM(1)*XM(2))**2
54134 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54135 &-(2D0*XM(3)*XM(5))**2
54138 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54140 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54141 &-(2D0*XM(1)*XM(2))**2
54142 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54143 &-(2D0*XM(3)*XM(5))**2
54146 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54149 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
54150 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
54156 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54157 & -(2D0*XM(1)*XM(2))**2
54158 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54159 & -(2D0*XM(3)*XM(5))**2
54162 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54169 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54170 & -(2D0*XM(1)*XM(2))**2
54171 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54172 & -(2D0*XM(3)*XM(5))**2
54175 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54180 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
54190 180 S12=S12MIN+PYR(0)*YJACO1
54193 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54194 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54195 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54196 &-(2D0*XM(1)*XM(2))**2
54197 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54198 &-(2D0*XM(3)*XM(5))**2
54201 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54203 S23MIN=S23AVE-S23DEL
54204 S23MAX=S23AVE+S23DEL
54205 YJACO2=S23MAX-S23MIN
54206 S23=S23MIN+PYR(0)*YJACO2
54208 C...CHECK THE SAMPLING
54209 IF(IKNT.GT.100) THEN
54210 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
54213 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
54215 IF(ISKIP.EQ.0) GOTO 190
54221 WU2 = (UH-ZM12)*(UH-ZM22)
54222 WT2 = (TH-ZM12)*(TH-ZM22)
54224 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54225 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54227 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54228 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54229 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54230 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54231 c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
54232 c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
54233 c &/DCMPLX(TH-XML2)
54234 c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
54235 c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
54236 c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
54237 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54238 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
54239 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54241 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
54242 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
54244 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
54245 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
54247 P1=SQRT(D1*D1-XM(1)**2)
54248 P2=SQRT(D2*D2-XM(2)**2)
54249 P3=SQRT(D3*D3-XM(3)**2)
54250 CTHE1=2D0*PYR(0)-1D0
54251 ANG1=2D0*PYR(0)*PARU(1)
54255 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
54257 P(N+1,1)=P1*STHE1*CPHI1
54258 P(N+1,2)=P1*STHE1*SPHI1
54263 ANG3=2D0*PYR(0)*PARU(1)
54266 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
54268 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
54270 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
54271 &+P3*STHE3*SPHI3*SPHI1
54272 &+P3*CTHE3*STHE1*CPHI1
54273 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
54274 &-P3*STHE3*SPHI3*CPHI1
54275 &+P3*CTHE3*STHE1*SPHI1
54276 P(N+3,3)=P3*STHE3*CPHI3*STHE1
54281 P(N+2,I)=-P(N+1,I)-P(N+3,I)
54289 C*********************************************************************
54292 C...Finds the s-hat dependent eigenvalues of the inverse propagator
54293 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
54294 C...phase space generation. Extended to include techni-a meson, and
54295 C...to return the width.
54297 SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
54299 C...Double precision and integer declarations.
54300 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54301 IMPLICIT INTEGER(I-N)
54302 INTEGER PYK,PYCHGE,PYCOMP
54303 C...Parameter statement to help give large particle numbers.
54304 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54305 &KEXCIT=4000000,KDIMEN=5000000)
54307 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54308 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54309 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54310 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
54311 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
54313 C...Local variables.
54314 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
54315 &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
54316 &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
54323 SINW=MIN(SQRT(PARU(102)),1D0)
54324 COSW=SQRT(1D0-SINW**2)
54326 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
54327 QUPD=2D0*RTCM(2)-1D0
54329 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
54330 FAR=SQRT(AEM/ALPRHT)
54334 FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
54347 AR(2,2) = SH-PMAS(23,1)**2
54348 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
54349 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
54350 AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
54371 CALL PYWIDT(23,SH,WDTP,WDTE)
54372 AT(2,2) = WDTP(0)*SHR
54373 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
54374 AT(3,3) = WDTP(0)*SHR
54375 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
54376 AT(4,4) = WDTP(0)*SHR
54377 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
54378 AT(5,5) = WDTP(0)*SHR
54382 AR(1,1) = SH-PMAS(24,1)**2
54383 AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
54384 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
54391 CALL PYWIDT(24,SH,WDTP,WDTE)
54392 AT(1,1) = WDTP(0)*SHR
54393 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
54394 AT(2,2) = WDTP(0)*SHR
54395 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
54396 AT(3,3) = WDTP(0)*SHR
54399 CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
54404 WX(I)=SQRT(ABS(SH-WR(I)))
54406 IF(WR(I).LT.SXMN) THEN
54416 C*********************************************************************
54419 C...Universal Extra Dimensions Model (UED)
54420 C...Initialize the xd masses and widths
54421 C...M. ELKACIMI 4/03/2006
54422 C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands
54426 C...Double precision and integer declarations.
54427 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54428 IMPLICIT INTEGER(I-N)
54429 INTEGER PYK,PYCHGE,PYCOMP
54431 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54432 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54433 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
54434 C...UED Pythia common
54435 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54437 C...SAVE statements
54438 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPUED/
54440 C...Print out some info about the UED model
54441 WRITE(MSTU(11),7000)
54443 & '********** PYXDIN: initialization of UED ******************',
54445 & 'Universal Extra Dimensions (UED) switched on ',
54447 & 'This implementation is courtesy of',
54448 & ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ',
54449 & ' see [hep-ph/0602198] (Les Houches 2005) ',
54451 & 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ',
54452 & 'Dobrescu), with gravity-mediated decay widths calculated in',
54453 & '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
54454 & 'radiative corrections to the KK masses from [hep/ph0204342]',
54455 & '(Cheng, Matchev, Schmaltz).'
54456 WRITE(MSTU(11),7000)
54458 & 'SM particles can propagate into one small extra dimension ',
54459 & 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
54460 & 'graviton is further allowed to propagate into N = IUED(4)',
54461 & 'large (eV^-1) extra dimensions.'
54462 WRITE(MSTU(11),7000)
54464 & 'The switches and parameters for UED are:',
54465 & ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
54466 & ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
54467 & ' IUED(3): (D=5) number of quark flavours',
54468 & ' IUED(4): (D=6) number of large extra dimensions into',
54469 & ' which the graviton propagates',
54470 & ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
54471 & ' IUED(6): (D=1) With/without rad.corrs. (=1/0)',
54473 & ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
54474 & ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
54475 & ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
54476 & ' when IUED(5)=0',
54477 & ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
54478 WRITE(MSTU(11),7000)
54480 & 'N.B.: the Higgs mass is also a free parameter of the UED ',
54481 & 'model, but is set through pmas(25,1).',
54484 C...Hardcoded switch, required by current implementation
54485 CALL PYGIVE('MSTP(42)=0')
54487 C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
54488 IF(IUED(2).EQ.0) CALL PYGIVE('MDCY(C5100022,1)=0')
54490 C...Calculated the radiative corrections to the KK particle masses
54493 C...Initialize the graviton mass
54494 C...only if the KK particles decays gravitationally
54495 IF(IUED(2).EQ.1) CALL PYGRAM(0)
54497 WRITE(MSTU(11),7000)
54498 & '********** PYXDIN: UED initialization completed ***********'
54500 C...Format to use for comments
54501 7000 FORMAT(' * ',A)
54505 C*********************************************************************
54508 C...Auxiliary to PYXDIN
54509 C...Mass kk states radiative corrections
54510 C...Radiative corrections are included (hep/ph0204342)
54514 C...Double precision and integer declarations.
54515 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54516 IMPLICIT INTEGER(I-N)
54517 INTEGER PYK,PYCHGE,PYCOMP
54519 PARAMETER(KKPART=25,KKFLA=450)
54521 C...UED Pythia common
54522 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54523 C...Pythia common: particles properties
54524 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54526 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54527 C...Decay information.
54528 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54529 C...Resonance width and secondary decay treatment.
54530 COMMON/PYINT4/MWID(500),WIDS(500,5)
54531 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54533 C...Local variables
54534 DOUBLE PRECISION PI,QUP,QDW
54535 DOUBLE PRECISION WDTP,WDTE
54536 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
54537 DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3
54538 DOUBLE PRECISION DSMG2,LOGLAM,DBMG2
54539 DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE
54540 DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2
54541 DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2
54542 DOUBLE PRECISION SWW1,CWW1
54543 DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST
54544 DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE
54545 DOUBLE PRECISION SW21,CW21,SW021,CW021
54546 COMMON/SW1/SW021,CW021
54547 C...UED related declarations:
54548 C...equivalences between ordered particles (451->475)
54549 C...and UED particle code (5 000 000 + id)
54550 DIMENSION IUEDEQ(475)
54551 DATA (IUEDEQ(I),I=451,475)/
54553 & 6100001,6100002,6100003,6100004,6100005,6100006,
54555 & 5100001,5100002,5100003,5100004,5100005,5100006,
54556 C...Singlet leptons
54557 & 6100011,6100013,6100015,
54558 C...Doublet leptons
54559 & 5100012,5100011,5100014,5100013,5100016,5100015,
54560 C...Gauge boson KK excitations
54561 & 5100021,5100022,5100023,5100024/
54563 C...N.B. rinv=rued(1)
54564 IF(RUED(1).LE.0.)THEN
54565 WRITE(MSTU(11),*) 'PYUEDC: RINV < 0 : ',RUED(1)
54566 WRITE(MSTU(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
54579 c...qt is q-tilde, qs is q-star
54580 c...strong coupling value
54584 c...weak mixing angle
54588 c...for the mass corrections
54593 C... Either fix the cutoff scale LAMUED
54594 IF(IUED(5).EQ.0)THEN
54595 LOGLAM = DLOG((RUED(3)*(1./RUED(1)))**2)
54596 C... or the ratio LAMUED/RINV (=product Lambda*R)
54597 ELSEIF(IUED(5).EQ.1)THEN
54598 LOGLAM = DLOG(RUED(4)**2)
54600 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
54604 C...Calculate the radiative corrections for the UED KK masses
54605 IF(IUED(6).EQ.1)THEN
54607 C...or induce a minute mass difference
54608 C...keeping the UED KK mass values nearly equal to 1/R
54609 ELSEIF(IUED(6).EQ.0)THEN
54612 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
54616 c...Take into account only the strong interactions:
54618 c...The space bulk corrections :
54619 DSMG2 = RMKK2*(-1.5)*(ALPHS/4./PI)*ZETA3/PI**2
54620 c...The boundary terms:
54621 DBMG2 = RMKK2*(23./2.)*(ALPHS/4./PI)*LOGLAM
54623 c...Mass corrections for fermions are extracted from
54624 c...Phys. Rev. D66 036005(2002)9
54625 DBMQDO=RMKK*(3.*(ALPHS/4./PI)+27./16.*(ALPHEM/4./PI/SW2)
54626 . +1./16.*(ALPHEM/4./PI/CW2))*LOGLAM
54627 DBMQU=RMKK*(3.*(ALPHS/4./PI)
54628 . +(ALPHEM/4./PI/CW2))*LOGLAM
54629 DBMQD=RMKK*(3.*(ALPHS/4./PI)
54630 . +0.25*(ALPHEM/4./PI/CW2))*LOGLAM
54632 DBMLDO=RMKK *((27./16.)*(ALPHEM/4./PI/SW2)+9./16.*
54633 . (ALPHEM/4./PI/CW2))*LOGLAM
54634 DBMLE=RMKK *(9./4.*(ALPHEM/4./PI/CW2))*LOGLAM
54636 c...Vector boson masss matrix diagonalization
54637 DBMB2 = RMKK2*(-1./6.)*(ALPHEM/4./PI/CW2)*LOGLAM
54638 DSMB2 = RMKK2*(-39./2.)*(ALPHEM/4./PI**3/CW2)*ZETA3
54639 DBMA2 = RMKK2*(15./2.)*(ALPHEM/4./PI/SW2)*LOGLAM
54640 DSMA2 = RMKK2*(-5./2.)*(ALPHEM/4./PI**3/SW2)*ZETA3
54642 c...Elements of the mass matrix
54643 A = RMZ2*SW2 + DBMB2 + DSMB2
54644 B = RMZ2*CW2 + DBMA2 + DSMA2
54645 C = RMZ2*DSQRT(SW2*CW2)
54646 SQRDEL = DSQRT( (A-B)**2 + 4*C**2 )
54648 c...Eigenvalues: corrections to X1 and Z1 masses
54649 DMB2 = (A+B-SQRDEL)/2.
54650 DMA2 = (A+B+SQRDEL)/2.
54652 c...Rotation angles
54656 SW21= SWW1**2/(SWW1**2 + CWW1**2)
54663 RMGST = RMKK+RFACT*(DSQRT(RMKK2 + DSMG2 + DBMG2)-RMKK)
54665 RMDQST=RMKK+RFACT*DBMQDO
54666 RMSQUS=RMKK+RFACT*DBMQU
54667 RMSQDS=RMKK+RFACT*DBMQD
54669 C...Note: MZ mass is included in ma2
54670 RMPHST= RMKK+RFACT*(DSQRT(RMKK2 + DMB2)-RMKK)
54671 RMZST = RMKK+RFACT*(DSQRT(RMKK2 + DMA2)-RMKK)
54672 RMWST = RMKK+RFACT*(DSQRT(RMKK2 + DBMA2 + DSMA2 + RMW**2)-RMKK)
54674 RMLSLD=RMKK+RFACT*DBMLDO
54675 RMLSLE=RMKK+RFACT*DBMLE
54678 PMAS(KKFLA+IPART,1)=RMSQDS
54681 PMAS(KKFLA+IPART,1)=RMSQUS
54684 PMAS(KKFLA+IPART,1)=RMDQST
54687 PMAS(KKFLA+IPART,1)=RMLSLE
54690 PMAS(KKFLA+IPART,1)=RMLSLD
54692 PMAS(KKFLA+22,1)=RMGST
54693 PMAS(KKFLA+23,1)=RMPHST
54694 PMAS(KKFLA+24,1)=RMZST
54695 PMAS(KKFLA+25,1)=RMWST
54697 WRITE(MSTU(11),7000) ' PYUEDC: ',
54698 & 'UED Mass Spectrum (GeV) :'
54699 WRITE(MSTU(11),7100) ' m(d*_S,s*_S,b*_S) = ',RMSQDS
54700 WRITE(MSTU(11),7100) ' m(u*_S,c*_S,t*_S) = ',RMSQUS
54701 WRITE(MSTU(11),7100) ' m(q*_D) = ',RMDQST
54702 WRITE(MSTU(11),7100) ' m(l*_S) = ',RMLSLE
54703 WRITE(MSTU(11),7100) ' m(l*_D) = ',RMLSLD
54704 WRITE(MSTU(11),7100) ' m(g*) = ',RMGST
54705 WRITE(MSTU(11),7100) ' m(gamma*) = ',RMPHST
54706 WRITE(MSTU(11),7100) ' m(Z*) = ',RMZST
54707 WRITE(MSTU(11),7100) ' m(W*) = ',RMWST
54708 WRITE(MSTU(11),7000) ' '
54710 C...Initialize widths, branching ratios and life time
54713 IF(MWID(KC).EQ.1.AND.MDCY(KC,1).EQ.1)THEN
54714 CALL PYWIDT(IUEDEQ(KC),PMAS(KC,1)**2,WDTP,WDTE)
54715 IF(WDTP(0).LE.0)THEN
54717 + 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', KC
54718 WRITE(MSTU(11),*) 'INITIAL VALUE IS TAKEN',PMAS(KC,2)
54721 DO 180 IDC=1,MDCY(KC,3)
54722 IC=IDC+MDCY(KC,2)-1
54723 IF(MDME(IC,1).EQ.1.AND.WDTP(IDC).GT.0.)THEN
54724 C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm
54725 PMAS(KC,4)=PARU(3)/WDTP(IDC)*1.D-12
54726 BRAT(IC)=WDTP(IDC)/WDTP(0)
54733 C...Format to use for comments
54734 7000 FORMAT(' * ',A)
54735 7100 FORMAT(' * ',A,F12.3)
54738 C********************************************************************
54741 C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
54742 C... Original version:
54745 C Universal Extra Dimensions Subprocess cross sections
54746 C The expressions used are from atl-com-phys-2005-003
54747 C What is coded here is shat**2/pi * dsigma/dt = |M|**2
54748 C For each UED subprocess, the color flow used is the same
54749 C as the equivalent QCD subprocess. Different configuration
54750 C color flows are considered to have the same probability.
54752 C The Xsection is calculated following ATL-PHYS-PUB-2005-003
54753 C by G.Azuelos and P.H.Beauchemin.
54755 C This routine is called from pysigh.
54757 SUBROUTINE PYXUED(NCHN,SIGS)
54759 C...Double precision and integer declarations
54760 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54761 IMPLICIT INTEGER(I-N)
54764 COMMON/DECMOD/NGRDEC
54766 PARAMETER(KKPART=25,KKFLA=450)
54768 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54769 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54770 COMMON/PYINT1/MINT(400),VINT(400)
54771 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
54772 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
54773 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
54774 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
54775 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
54776 SAVE /PYDAT2/,/PYINT1/,/PYINT3/,/PYPARS/
54777 C...UED Pythia common
54778 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54779 C...Local arrays and complex variables
54780 DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS
54781 + ,FAC1,XMNKK,XMUED,SIGS
54784 C...Return if UED not switched on
54785 IF (IUED(1).LE.0) THEN
54789 C...Energy scale of the parton processus
54790 C...taken equal to the mass of the final state kk
54793 C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
54794 XMNKK=PMAS(KKFLA+23,1)
54796 C...To compare the cross section with phys-pub-2005-03
54797 C...(no radiative corrections),
54798 C...take xmnkk=rinv and q2=rinv**2
54800 C...n.b. (rinv=rued(1))
54801 c IF(NGRDEC.EQ.1)XMNKK=RUED(0)
54802 IF(NGRDEC.EQ.1)XMNKK=RUED(1)
54811 BETA34=DSQRT(1.D0-4.D0*XMNKK**2/SHAT)
54814 c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
54815 Q2=RUED(1)**2+(TP*UP-RUED(1)**4)/SP
54817 c IF(NGRDEC.EQ.1)Q2=RUED(0)**2
54818 IF(NGRDEC.EQ.1)Q2=RUED(1)**2
54821 C...Strong coupling value
54824 IF(ISUB.EQ.311)THEN
54826 FAC1=9./8.*ALPHAS**2/(SP*TP*UP)**2
54827 XMUED=FAC1*(XMNKK**4*(6.*TP**4+18.*TP**3*UP+
54828 & 24.*TP**2*UP**2+18.*TP*UP**3+6.*UP**4)
54829 & +XMNKK**2*(6.*TP**4*UP+12.*TP**3*UP**2+
54830 & 12.*TP**2*UP**3+6*TP*UP**4)
54831 & +2.*TP**6+6*TP**5*UP+13*TP**4*UP**2+
54832 & 15.*TP**3*UP**3+13*TP**2*UP**4+
54833 & 6.*TP*UP**5+2.*UP**6)
54837 C...Three color flow configurations (qcd g+g->g+g)
54839 IF(XCOL.LE.1./3.)THEN
54841 ELSEIF(XCOL.LE.2./3.)THEN
54846 SIGH(NCHN)=COMFAC*XMUED
54847 ELSEIF(ISUB.EQ.312)THEN
54848 C...q + g -> q*_D + g*, q*_S + g*
54849 C...(the two channels have the same cross section)
54850 FAC1=-1./36.*ALPHAS**2/(SP*TP*UP)**2
54851 XMUED=FAC1*(12.*SP*UP**5+5.*SP**2*UP**4+22.*SP**3*UP**3+
54852 & 5.*SP**4*UP**2+12.*SP**5*UP)
54853 XMUED=COMFAC*2.*XMUED
54855 DO 190 I=MMINA,MMAXA
54856 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
54859 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
54860 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
54863 ISIG(NCHN,3-ISDE)=21
54866 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
54870 ELSEIF(ISUB.EQ.313)THEN
54871 C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj
54872 C...(the two channels have the same cross section)
54873 C...qi and qj have the same charge sign
54874 DO 100 I=MMIN1,MMAX1
54876 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 100
54877 DO 101 J=MMIN2,MMAX2
54879 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).
54881 IF(J*I.LE.0)GOTO 101
54886 FAC1=1./72.*ALPHAS**2/(TP*UP)**2
54888 & (XMNKK**2*(8*TP**3+4./3.*TP**2*UP+4./3.*TP*UP**2
54889 & +8.*UP**3)+8.*TP**4+56./3.*TP**3*UP+
54890 & 20.*TP**2*UP**2+56./3.*
54891 & TP*UP**3+8.*UP**4)
54892 SIGH(NCHN)=COMFAC*2.*XMUED
54894 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
54896 FAC1=2./9.*ALPHAS**2/TP**2
54897 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
54898 SIGH(NCHN)=COMFAC*2.*XMUED
54903 ELSEIF(ISUB.EQ.314)THEN
54904 C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
54905 C...(the two channels have the same cross section)
54909 ISIG(NCHN,3)=INT(1.5+PYR(0))
54911 FAC1=5./6.*ALPHAS**2/(SP*TP*UP)**2
54912 XMUED=FAC1*(-XMNKK**4*(8.*TP*UP**3+8.*TP**2*UP**2+8.*TP**3*UP
54913 + +4.*UP**4+4*TP**4)
54914 + -XMNKK**2*(0.5*TP*UP**4+4.*TP**2*UP**3+15./2.*TP**3
54915 + *UP**2+ 4.*TP**4*UP)+TP*UP**5-0.25*TP**2*UP**4+
54916 + 2.*TP**3*UP**3-0.25*TP**4*UP**2+TP**5*UP)
54918 SIGH(NCHN)=COMFAC*XMUED
54919 C...has been multiplied by 5: all possible quark flavors in final state
54921 ELSEIF(ISUB.EQ.315)THEN
54922 C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
54923 C...(the two channels have the same cross section)
54924 DO 141 I=MMIN1,MMAX1
54925 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
54926 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 141
54927 DO 142 J=MMIN2,MMAX2
54928 IF(J.EQ.0.OR.ABS(I).NE.ABS(J).OR.I*J.GE.0) GOTO 142
54929 FAC1=2./9.*ALPHAS**2*1./(SP*TP)**2
54930 XMUED=FAC1*(XMNKK**2*SP*(4.*TP**2-SP*TP-SP**2)+
54931 & 4.*TP**4+3.*SP*TP**3+11./12.*TP**2*SP**2-
54932 & 2./3.*SP**3*TP+SP**4)
54937 SIGH(NCHN)=COMFAC*2.*XMUED
54940 ELSEIF(ISUB.EQ.316)THEN
54941 C...q + qbar' -> q*_D + q*_Sbar'
54942 FAC1=2./9.*ALPHAS**2
54943 DO 300 I=MMIN1,MMAX1
54945 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 300
54946 DO 301 J=MMIN2,MMAX2
54948 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 301
54949 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 301
54954 FAC1=2./9.*ALPHAS**2/TP**2
54955 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
54956 SIGH(NCHN)=COMFAC*XMUED
54960 ELSEIF(ISUB.EQ.317)THEN
54961 C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar'
54962 C...(the two channels have the same cross section)
54963 DO 400 I=MMIN1,MMAX1
54965 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 400
54966 DO 401 J=MMIN1,MMAX1
54968 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 401
54969 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 401
54974 FAC1=1./18.*ALPHAS**2/TP**2
54975 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
54976 SIGH(NCHN)=COMFAC*2.*XMUED
54979 ELSEIF(ISUB.EQ.318)THEN
54980 C...q + q' -> q*_D + q*_S'
54981 DO 500 I=MMIN1,MMAX1
54983 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 500
54984 DO 501 J=MMIN2,MMAX2
54986 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 501
54987 IF(J*I.LE.0)GOTO 501
54992 ISIG(NCHN,3)=INT(1.5+PYR(0))
54993 FAC1=1./36.*ALPHAS**2/(TP*UP)**2
54994 XMUED=FAC1*(-8.*XMNKK**2*(TP**3+TP**2*UP+TP*UP**2+UP**3)
54995 & +8.*TP**4+4.*TP**2*UP**2+8.*UP**4)
54996 SIGH(NCHN)=COMFAC*XMUED
55002 FAC1=1./18.*ALPHAS**2/TP**2
55003 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
55004 SIGH(NCHN)=COMFAC*2.*XMUED
55008 ELSEIF(ISUB.EQ.319)THEN
55009 C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
55010 C...(the two channels have the same cross section)
55011 DO 741 I=MMIN1,MMAX1
55012 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
55013 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 741
55014 DO 742 J=MMIN2,MMAX2
55015 IF(J.EQ.0.OR.IABS(J).NE.IABS(I).OR.J*I.GT.0) GOTO 742
55016 FAC1=16./9.*ALPHAS**2*1./(SP)**2
55017 XMUED=FAC1*(2.*XMNKK**2*SP+SP**2+2.*SP*TP+2.*TP**2)
55022 SIGH(NCHN)=COMFAC*2.*XMUED
55030 C*********************************************************************
55033 C...Universal Extra Dimensions Model (UED)
55034 C...Computation of the Graviton mass.
55036 SUBROUTINE PYGRAM(IN)
55038 C...Double precision and integer declarations
55039 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55040 IMPLICIT INTEGER(I-N)
55042 C...Pythia commonblocks
55043 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55044 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55045 C...UED Pythia common
55046 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55048 C...Local variables
55050 PARAMETER(KCFLA=450,NMAX=5000)
55051 DIMENSION YVEC(5000),RESVEC(5000)
55052 COMMON/INTSAV/YSAV,YMAX,RESMAX
55053 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55054 COMMON/KAPPA/XKAPPA
55056 C...External function (used in call to PYGAUS)
55059 C...SAVE statements
55060 SAVE /PYDAT1/,/PYDAT2/,/PYPUED/,/INTSAV/
55068 C...Initialize for numerical integration
55070 XKAPPA=DSQRT(2.D0)/XMPLNK
55072 C...For NDIM=2, compute graviton mass distribution numerically
55075 C... For first event: tabulate distribution of stepwise integrals:
55076 C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
55081 YSAV = (I-0.5)/DBLE(NMAX)
55083 C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
55084 RESINT = PYGAUS(PYGRAW,0D0,1D0,TOL)
55087 C... Save max of distribution (for accept/reject below)
55088 IF(RESINT.GT.RESMAX)THEN
55095 C... Generate Mg for each graviton (1D0 ensures a minimal open phase space)
55098 XMGAMK=PMAS(KCGAKK,1)
55100 C... Pick random graviton mass, accept according to stored integrals
55101 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55102 110 RMG=AMMAX*PYR(0)
55105 C... Bin enumeration starts at 1, but make sure always in range
55107 IBIN=MIN(IBIN,NMAX)
55108 IF(RESVEC(IBIN)/RESMAX.LT.PYR(0)) GOTO 110
55110 C... For NDIM=4 and 6, the analytical expression for the
55111 C... graviton mass distribution integral is used.
55112 ELSEIF(NDIM.EQ.4.OR.NDIM.EQ.6)THEN
55114 C... Ensure minimal open phase space (max(mG*) < m(gamma*))
55117 C... KK photon (?) compressed code and mass
55119 XMGAMK=PMAS(KCGAKK,1)
55121 C... Find maximum of (dGamma/dMg)
55127 RESINT=Y**(NDIM-3)*(1D0/(1D0-Y**2))*(1D0+DCOS(PI*Y))
55128 IF(RESINT.GE.RESMAX)THEN
55135 C... Pick random graviton mass, accept/reject
55136 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55137 130 RMG=AMMAX*PYR(0)
55139 DGADMG=X**(NDIM-3)*(1./(1.-X**2))*(1.+DCOS(PI*X))
55140 IF(DGADMG/RESMAX.LT.PYR(0)) GOTO 130
55142 C... If the user has not chosen N=2,4 or 6, STOP
55144 WRITE(MSTU(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',NDIM,
55145 & ' (MUST BE 2, 4, OR 6) '
55149 C... Now store the sampled Mg
55155 C*********************************************************************
55158 C...Universal Extra Dimensions Model (UED)
55160 C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
55162 C...Integrand for the KK boson -> SM boson + graviton
55163 C...graviton mass distribution (and gravity mediated total width),
55164 C...which contains (see 0201300 and below for the full product)
55165 C...the gravity mediated partial decay width Gamma(xx, yy)
55166 C... i.e. GRADEN(YY)*PYWDKK(XXA)
55167 C... where xx is exclusive to gravity
55168 C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55169 C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.
55171 DOUBLE PRECISION FUNCTION PYGRAW(YIN)
55173 C...Double precision and integer declarations
55174 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55175 IMPLICIT INTEGER (I-N)
55177 C...Pythia commonblocks
55178 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55180 C...Local UED commonblocks and variables
55181 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55182 COMMON/INTSAV/YSAV,YMAX,RESMAX
55184 C...SAVE statements
55185 SAVE /PYDAT1/,/INTSAV/
55187 C...External: Pythia's Gamma function
55196 XX=DSQRT(1.-YY**2)*YIN
55197 DJAC=(1.-YMIN)*DSQRT(1.-YY**2)
55198 FAC=2.*PI**((NDIM-1.)/2.)*XMPLNK**2*RINV**NDIM/XMD**(NDIM+2)
55202 XXA=DSQRT(XX**2+YY**2)
55203 GRADEN=4./PI2 * (YY**2/(1.-YY**2)**2)*(1.+DCOS(PI*YY))
55206 + FAC*XX**(NDIM-2)*GRADEN*PYWDKK(XXA)
55210 C*********************************************************************
55213 C...Universal Extra Dimensions Model (UED)
55215 C...Multiplied by the square modulus of a form factor
55216 C...(see GRADEN in function PYGRAW)
55217 C...PYWDKK is the KK boson -> SM boson + graviton
55218 C...gravity mediated partial decay width Gamma(xx, yy)
55219 C... where xx is exclusive to gravity
55220 C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55221 C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
55223 C...N.B. The Feynman rules for the couplings of the graviton fields
55224 C...to the UED fields are related to the corresponding couplings of
55225 C...the graviton fields to the SM fields by the form factor.
55227 DOUBLE PRECISION FUNCTION PYWDKK(X)
55229 C...Double precision and integer declarations
55230 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55231 IMPLICIT INTEGER (I-N)
55233 C...Pythia commonblocks
55234 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55235 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55237 C...Local UED commonblocks and variables
55238 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55239 COMMON/KAPPA/XKAPPA
55241 C...SAVE statements
55242 SAVE /PYDAT1/,/PYDAT2/,/UEDGRA/,/KAPPA/
55246 C...gamma* mass 473
55248 XMNKK=PMAS(KCQKK,1)
55250 C...Bosons partial width Macesanu hep-ph/0201300
55251 PYWDKK=XKAPPA**2/(96.*PI)*XMNKK**3/X**4*
55252 + ((1.-X**2)**2*(1.+3.*X**2+6.*X**4))
55257 C*********************************************************************
55260 C...Finds eigenvalues of a general complex matrix
55262 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
55263 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
55264 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
55265 C OF A COMPLEX GENERAL MATRIX.
55269 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
55270 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55271 C DIMENSION STATEMENT.
55273 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
55275 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
55276 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
55278 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
55279 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
55280 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
55284 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55285 C RESPECTIVELY, OF THE EIGENVALUES.
55287 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55288 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
55290 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
55291 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
55292 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
55294 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
55296 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55297 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55299 C THIS VERSION DATED AUGUST 1983.
55302 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
55304 INTEGER N,NM,IS1,IS2,IERR,MATZ
55305 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55306 X FV1(5),FV2(5),FV3(5)
55307 IF (N .LE. NM) GOTO 100
55311 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
55312 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
55313 IF (MATZ .NE. 0) GOTO 110
55314 C .......... FIND EIGENVALUES ONLY ..........
55315 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
55317 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
55318 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
55319 IF (IERR .NE. 0) GOTO 120
55320 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
55324 C*********************************************************************
55327 C...Auxiliary to PYEICG.
55329 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55330 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
55332 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
55333 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55334 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55336 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
55337 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
55341 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55342 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55343 C DIMENSION STATEMENT.
55345 C N IS THE ORDER OF THE MATRIX.
55347 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55348 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55349 C SET LOW=1, IGH=N.
55351 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55352 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55353 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
55354 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
55355 C THE REDUCTION BY CORTH, IF PERFORMED.
55359 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
55360 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
55361 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
55362 C EIGENVECTORS IS TO BE PERFORMED.
55364 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55365 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55366 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55367 C FOR INDICES IERR+1,...,N.
55370 C ZERO FOR NORMAL RETURN,
55371 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55372 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55374 C CALLS PYCDIV FOR COMPLEX DIVISION.
55375 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55376 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55378 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55379 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55381 C THIS VERSION DATED AUGUST 1983.
55384 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
55386 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
55387 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
55388 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55392 IF (LOW .EQ. IGH) GOTO 130
55393 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55398 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
55399 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
55400 YR = HR(I,I-1) / NORM
55401 YI = HI(I,I-1) / NORM
55406 SI = YR * HI(I,J) - YI * HR(I,J)
55407 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
55412 SI = YR * HI(J,I) + YI * HR(J,I)
55413 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
55418 C .......... STORE ROOTS ISOLATED BY CBAL ..........
55419 130 DO 140 I = 1, N
55420 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
55429 C .......... SEARCH FOR NEXT EIGENVALUE ..........
55430 150 IF (EN .LT. LOW) GOTO 320
55433 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55434 C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
55435 160 DO 170 LL = LOW, EN
55437 IF (L .EQ. LOW) GOTO 180
55438 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
55439 X + DABS(HR(L,L)) + DABS(HI(L,L))
55440 TST2 = TST1 + DABS(HR(L,L-1))
55441 IF (TST2 .EQ. TST1) GOTO 180
55443 C .......... FORM SHIFT ..........
55444 180 IF (L .EQ. EN) GOTO 300
55445 IF (ITN .EQ. 0) GOTO 310
55446 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
55449 XR = HR(ENM1,EN) * HR(EN,ENM1)
55450 XI = HI(ENM1,EN) * HR(EN,ENM1)
55451 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
55452 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
55453 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
55454 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
55455 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
55458 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
55462 C .......... FORM EXCEPTIONAL SHIFT ..........
55463 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
55466 210 DO 220 I = LOW, EN
55467 HR(I,I) = HR(I,I) - SR
55468 HI(I,I) = HI(I,I) - SI
55475 C .......... REDUCE TO TRIANGLE (ROWS) ..........
55481 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
55482 XR = HR(I-1,I-1) / NORM
55484 XI = HI(I-1,I-1) / NORM
55487 HI(I-1,I-1) = 0.0D0
55488 HI(I,I-1) = SR / NORM
55495 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
55496 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
55497 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
55498 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
55504 IF (SI .EQ. 0.0D0) GOTO 250
55505 NORM = PYTHAG(HR(EN,EN),SI)
55506 SR = HR(EN,EN) / NORM
55510 C .......... INVERSE OPERATION (COLUMNS) ..........
55511 250 DO 280 J = LP1, EN
55520 IF (I .EQ. J) GOTO 260
55522 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55523 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55524 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55525 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55530 IF (SI .EQ. 0.0D0) GOTO 160
55535 HR(I,EN) = SR * YR - SI * YI
55536 HI(I,EN) = SR * YI + SI * YR
55540 C .......... A ROOT FOUND ..........
55541 300 WR(EN) = HR(EN,EN) + TR
55542 WI(EN) = HI(EN,EN) + TI
55545 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55546 C CONVERGED AFTER 30*N ITERATIONS ..........
55551 C*********************************************************************
55554 C...Auxiliary to PYEICG.
55556 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55557 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
55559 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
55560 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55561 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55563 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
55564 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
55565 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
55566 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
55567 C THIS GENERAL MATRIX TO HESSENBERG FORM.
55571 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55572 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55573 C DIMENSION STATEMENT.
55575 C N IS THE ORDER OF THE MATRIX.
55577 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55578 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55579 C SET LOW=1, IGH=N.
55581 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
55582 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
55583 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
55584 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
55585 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
55587 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55588 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55589 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
55590 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
55591 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
55592 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
55597 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
55598 C HAVE BEEN DESTROYED.
55600 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55601 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55602 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55603 C FOR INDICES IERR+1,...,N.
55605 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55606 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
55607 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
55608 C THE EIGENVECTORS HAS BEEN FOUND.
55611 C ZERO FOR NORMAL RETURN,
55612 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55613 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55615 C CALLS PYCDIV FOR COMPLEX DIVISION.
55616 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55617 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55619 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55620 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55622 C THIS VERSION DATED OCTOBER 1989.
55624 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
55625 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
55628 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
55630 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
55631 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
55632 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55634 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55638 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
55647 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
55648 C FROM THE INFORMATION LEFT BY CORTH ..........
55649 IEND = IGH - LOW - 1
55650 IF (IEND.LT.0) GOTO 220
55651 IF (IEND.EQ.0) GOTO 170
55652 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
55653 DO 160 II = 1, IEND
55655 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
55656 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
55657 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
55658 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
55661 DO 120 K = IP1, IGH
55662 ORTR(K) = HR(K,I-1)
55663 ORTI(K) = HI(K,I-1)
55671 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
55672 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
55679 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
55680 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
55686 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55691 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
55692 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
55693 YR = HR(I,I-1) / NORM
55694 YI = HI(I,I-1) / NORM
55699 SI = YR * HI(I,J) - YI * HR(I,J)
55700 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
55705 SI = YR * HI(J,I) + YI * HR(J,I)
55706 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
55710 DO 200 J = LOW, IGH
55711 SI = YR * ZI(J,I) + YI * ZR(J,I)
55712 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
55717 C .......... STORE ROOTS ISOLATED BY CBAL ..........
55718 220 DO 230 I = 1, N
55719 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
55728 C .......... SEARCH FOR NEXT EIGENVALUE ..........
55729 240 IF (EN .LT. LOW) GOTO 430
55732 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55733 C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
55734 250 DO 260 LL = LOW, EN
55736 IF (L .EQ. LOW) GOTO 270
55737 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
55738 X + DABS(HR(L,L)) + DABS(HI(L,L))
55739 TST2 = TST1 + DABS(HR(L,L-1))
55740 IF (TST2 .EQ. TST1) GOTO 270
55742 C .......... FORM SHIFT ..........
55743 270 IF (L .EQ. EN) GOTO 420
55744 IF (ITN .EQ. 0) GOTO 550
55745 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
55748 XR = HR(ENM1,EN) * HR(EN,ENM1)
55749 XI = HI(ENM1,EN) * HR(EN,ENM1)
55750 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
55751 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
55752 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
55753 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
55754 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
55757 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
55761 C .......... FORM EXCEPTIONAL SHIFT ..........
55762 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
55765 300 DO 310 I = LOW, EN
55766 HR(I,I) = HR(I,I) - SR
55767 HI(I,I) = HI(I,I) - SI
55774 C .......... REDUCE TO TRIANGLE (ROWS) ..........
55780 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
55781 XR = HR(I-1,I-1) / NORM
55783 XI = HI(I-1,I-1) / NORM
55786 HI(I-1,I-1) = 0.0D0
55787 HI(I,I-1) = SR / NORM
55794 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
55795 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
55796 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
55797 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
55803 IF (SI .EQ. 0.0D0) GOTO 350
55804 NORM = PYTHAG(HR(EN,EN),SI)
55805 SR = HR(EN,EN) / NORM
55809 IF (EN .EQ. N) GOTO 350
55815 HR(EN,J) = SR * YR + SI * YI
55816 HI(EN,J) = SR * YI - SI * YR
55818 C .......... INVERSE OPERATION (COLUMNS) ..........
55819 350 DO 390 J = LP1, EN
55828 IF (I .EQ. J) GOTO 360
55830 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55831 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55832 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55833 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55836 DO 380 I = LOW, IGH
55841 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55842 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55843 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55844 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55849 IF (SI .EQ. 0.0D0) GOTO 250
55854 HR(I,EN) = SR * YR - SI * YI
55855 HI(I,EN) = SR * YI + SI * YR
55858 DO 410 I = LOW, IGH
55861 ZR(I,EN) = SR * YR - SI * YI
55862 ZI(I,EN) = SR * YI + SI * YR
55866 C .......... A ROOT FOUND ..........
55867 420 HR(EN,EN) = HR(EN,EN) + TR
55869 HI(EN,EN) = HI(EN,EN) + TI
55873 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
55874 C VECTORS OF UPPER TRIANGULAR FORM ..........
55880 TR = DABS(HR(I,J)) + DABS(HI(I,J))
55881 IF (TR .GT. NORM) NORM = TR
55884 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
55885 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
55893 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
55894 DO 490 II = 1, ENM1
55901 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
55902 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
55907 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
55910 460 YR = 0.01D0 * YR
55912 IF (TST2 .GT. TST1) GOTO 460
55914 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
55915 C .......... OVERFLOW CONTROL ..........
55916 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
55917 IF (TR .EQ. 0.0D0) GOTO 490
55919 TST2 = TST1 + 1.0D0/TST1
55920 IF (TST2 .GT. TST1) GOTO 490
55922 HR(J,EN) = HR(J,EN)/TR
55923 HI(J,EN) = HI(J,EN)/TR
55929 C .......... END BACKSUBSTITUTION ..........
55930 C .......... VECTORS OF ISOLATED ROOTS ..........
55932 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
55940 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
55941 C VECTORS OF ORIGINAL FULL MATRIX.
55942 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
55947 DO 540 I = LOW, IGH
55952 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
55953 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
55961 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55962 C CONVERGED AFTER 30*N ITERATIONS ..........
55967 C*********************************************************************
55970 C...Auxiliary to PYCMQR
55972 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
55975 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
55977 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
55978 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
55980 S = DABS(BR) + DABS(BI)
55985 S = BRS**2 + BIS**2
55986 CR = (ARS*BRS + AIS*BIS)/S
55987 CI = (AIS*BRS - ARS*BIS)/S
55991 C*********************************************************************
55994 C...Auxiliary to PYCMQR
55996 C (YR,YI) = COMPLEX DSQRT(XR,XI)
55997 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
56000 SUBROUTINE PYCSRT(XR,XI,YR,YI)
56002 DOUBLE PRECISION XR,XI,YR,YI
56003 DOUBLE PRECISION S,TR,TI,PYTHAG
56007 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
56008 IF (TR .GE. 0.0D0) YR = S
56009 IF (TI .LT. 0.0D0) S = -S
56010 IF (TR .LE. 0.0D0) YI = S
56011 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
56012 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
56016 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
56017 DOUBLE PRECISION A,B
56019 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
56021 DOUBLE PRECISION P,R,S,T,U
56022 P = DMAX1(DABS(A),DABS(B))
56023 IF (P .EQ. 0.0D0) GOTO 110
56024 R = (DMIN1(DABS(A),DABS(B))/P)**2
56027 IF (T .EQ. 4.0D0) GOTO 110
56029 U = 1.0D0 + 2.0D0*S
56037 C*********************************************************************
56040 C...Auxiliary to PYEICG
56042 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56043 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
56044 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56045 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56047 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
56048 C EIGENVALUES WHENEVER POSSIBLE.
56052 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56053 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56054 C DIMENSION STATEMENT.
56056 C N IS THE ORDER OF THE MATRIX.
56058 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56059 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
56063 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56064 C RESPECTIVELY, OF THE BALANCED MATRIX.
56066 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
56067 C ARE EQUAL TO ZERO IF
56068 C (1) I IS GREATER THAN J AND
56069 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
56071 C SCALE CONTAINS INFORMATION DETERMINING THE
56072 C PERMUTATIONS AND SCALING FACTORS USED.
56074 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
56075 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
56076 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
56077 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
56078 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
56079 C = D(J,J) J = LOW,...,IGH
56080 C = P(J) J = IGH+1,...,N.
56081 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
56084 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
56086 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
56087 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
56088 C K,L HAVE BEEN REVERSED.)
56090 C ARITHMETIC IS REAL THROUGHOUT.
56092 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56093 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56095 C THIS VERSION DATED AUGUST 1983.
56098 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
56100 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
56101 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
56102 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
56111 C .......... IN-LINE PROCEDURE FOR ROW AND
56112 C COLUMN EXCHANGE ..........
56114 IF (J .EQ. M) GOTO 130
56134 130 IF(IEXC.EQ.1) GOTO 140
56135 IF(IEXC.EQ.2) GOTO 180
56136 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
56137 C AND PUSH THEM DOWN ..........
56138 140 IF (L .EQ. 1) GOTO 320
56140 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
56141 150 DO 170 JJ = 1, L
56145 IF (I .EQ. J) GOTO 160
56146 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
56155 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
56156 C AND PUSH THEM LEFT ..........
56159 190 DO 210 J = K, L
56162 IF (I .EQ. J) GOTO 200
56163 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
56170 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
56172 220 SCALE(I) = 1.0D0
56173 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
56174 230 NOCONV = .FALSE.
56181 IF (J .EQ. I) GOTO 240
56182 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
56183 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
56185 C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
56186 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
56190 250 IF (C .GE. G) GOTO 260
56195 270 IF (C .LT. G) GOTO 280
56199 C .......... NOW BALANCE ..........
56200 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
56202 SCALE(I) = SCALE(I) * F
56206 AR(I,J) = AR(I,J) * G
56207 AI(I,J) = AI(I,J) * G
56211 AR(J,I) = AR(J,I) * F
56212 AI(J,I) = AI(J,I) * F
56217 IF (NOCONV) GOTO 230
56224 C*********************************************************************
56227 C...Auxiliary to PYEICG.
56229 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56230 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
56231 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56232 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56234 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
56235 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
56236 C BALANCED MATRIX DETERMINED BY CBAL.
56240 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56241 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56242 C DIMENSION STATEMENT.
56244 C N IS THE ORDER OF THE MATRIX.
56246 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
56248 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
56249 C AND SCALING FACTORS USED BY CBAL.
56251 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
56253 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56254 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
56255 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
56259 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56260 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
56261 C IN THEIR FIRST M COLUMNS.
56263 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56264 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56266 C THIS VERSION DATED AUGUST 1983.
56269 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
56271 INTEGER I,J,K,M,N,II,NM,IGH,LOW
56272 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
56275 IF (M .EQ. 0) GOTO 150
56276 IF (IGH .EQ. LOW) GOTO 120
56278 DO 110 I = LOW, IGH
56280 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
56281 C IF THE FOREGOING STATEMENT IS REPLACED BY
56282 C S=1.0D0/SCALE(I). ..........
56284 ZR(I,J) = ZR(I,J) * S
56285 ZI(I,J) = ZI(I,J) * S
56289 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
56290 C IGH+1 STEP 1 UNTIL N DO -- ..........
56291 120 DO 140 II = 1, N
56293 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
56294 IF (I .LT. LOW) I = LOW - II
56296 IF (K .EQ. I) GOTO 140
56312 C*********************************************************************
56315 C...Auxiliary to PYEICG.
56317 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
56318 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
56319 C BY MARTIN AND WILKINSON.
56320 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
56322 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
56323 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
56324 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
56325 C UNITARY SIMILARITY TRANSFORMATIONS.
56329 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56330 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56331 C DIMENSION STATEMENT.
56333 C N IS THE ORDER OF THE MATRIX.
56335 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56336 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56337 C SET LOW=1, IGH=N.
56339 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56340 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
56344 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56345 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
56346 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
56347 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
56348 C HESSENBERG MATRIX.
56350 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
56351 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
56353 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56355 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56356 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56358 C THIS VERSION DATED AUGUST 1983.
56361 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
56363 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
56364 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
56365 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
56369 IF (LA .LT. KP1) GOTO 210
56376 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
56378 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
56380 IF (SCALE .EQ. 0.0D0) GOTO 200
56382 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56385 ORTR(I) = AR(I,M-1) / SCALE
56386 ORTI(I) = AI(I,M-1) / SCALE
56387 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
56391 F = PYTHAG(ORTR(M),ORTI(M))
56392 IF (F .EQ. 0.0D0) GOTO 120
56395 ORTR(M) = (1.0D0 + G) * ORTR(M)
56396 ORTI(M) = (1.0D0 + G) * ORTI(M)
56401 C .......... FORM (I-(U*UT)/H) * A ..........
56402 130 DO 160 J = M, N
56405 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56408 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
56409 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
56416 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
56417 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
56421 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
56425 C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
56428 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
56429 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
56436 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
56437 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
56442 ORTR(M) = SCALE * ORTR(M)
56443 ORTI(M) = SCALE * ORTI(M)
56444 AR(M,M-1) = -G * AR(M,M-1)
56445 AI(M,M-1) = -G * AI(M,M-1)
56451 C*********************************************************************
56454 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56457 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
56459 INTEGER N,NP,INDX(N)
56461 COMPLEX*16 A(NP,NP)
56462 PARAMETER (TINY=1.0D-20)
56464 REAL*8 AAMAX,VV(6),DUM
56465 COMPLEX*16 SUM,DUMC
56471 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
56473 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
56480 SUM=SUM-A(I,K)*A(K,J)
56488 SUM=SUM-A(I,K)*A(K,J)
56492 IF (DUM.GE.AAMAX) THEN
56507 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
56510 A(I,J)=A(I,J)/A(J,J)
56518 C*********************************************************************
56521 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56524 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
56526 INTEGER N,NP,INDX(N)
56527 COMPLEX*16 A(NP,NP),B(N)
56538 SUM=SUM-A(I,J)*B(J)
56540 ELSE IF (ABS(SUM).NE.0D0) THEN
56548 SUM=SUM-A(I,J)*B(J)
56555 C***********************************************************************
56558 C...Calculates full and partial widths of resonances.
56559 C....copy of PYWIDT, used for techniparticle widths
56561 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
56563 C...Double precision and integer declarations.
56564 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56565 IMPLICIT INTEGER(I-N)
56566 INTEGER PYK,PYCHGE,PYCOMP
56567 C...Parameter statement to help give large particle numbers.
56568 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56569 &KEXCIT=4000000,KDIMEN=5000000)
56571 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56572 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56573 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
56574 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
56575 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
56576 COMMON/PYINT1/MINT(400),VINT(400)
56577 COMMON/PYINT4/MWID(500),WIDS(500,5)
56578 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
56579 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
56580 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
56581 &/PYINT4/,/PYMSSM/,/PYTCSM/
56582 C...Local arrays and saved variables.
56583 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
56585 SAVE MOFSV,WIDWSV,WID2SV
56586 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
56588 C...Compressed code and sign; mass.
56595 C...Reset width information.
56600 C...Common electroweak and strong constants.
56603 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
56606 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
56608 RADC=1D0+AS/PARU(1)
56610 IF(KFLA.EQ.23) THEN
56612 XWC=1D0/(16D0*XW*XW1)
56613 FAC=(AEM*XWC/3D0)*SHR
56615 DO 130 I=1,MDCY(KC,3)
56617 IF(MDME(IDC,1).LT.0) GOTO 130
56618 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
56619 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
56620 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
56624 AF=SIGN(1D0,EF+0.1D0)
56627 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
56628 ELSEIF(I.LE.16) THEN
56629 C...Z0 -> l+ + l-, nu + nubar
56631 AF=SIGN(1D0,EF+0.1D0)
56635 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
56636 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
56638 WDTP(0)=WDTP(0)+WDTP(I)
56642 ELSEIF(KFLA.EQ.24) THEN
56644 FAC=(AEM/(24D0*XW))*SHR
56645 DO 140 I=1,MDCY(KC,3)
56647 IF(MDME(IDC,1).LT.0) GOTO 140
56648 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
56649 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
56650 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
56653 C...W+/- -> q + qbar'
56654 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
56655 ELSEIF(I.LE.20) THEN
56656 C...W+/- -> l+/- + nu
56659 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
56660 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
56661 WDTP(0)=WDTP(0)+WDTP(I)
56664 C.....V8 -> quark anti-quark
56665 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
56668 IF(ITCM(2).EQ.0) THEN
56670 ELSEIF(ITCM(2).EQ.1) THEN
56673 DO 150 I=1,MDCY(KC,3)
56675 IF(MDME(IDC,1).LT.0) GOTO 150
56676 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
56678 IF(RM1.GT.0.25D0) GOTO 150
56680 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
56685 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
56686 IF(I.EQ.6) WID2=WIDS(6,1)
56687 WDTP(0)=WDTP(0)+WDTP(I)
56694 C*********************************************************************
56697 C...Calculates R-violating decays of sfermions.
56700 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
56702 C...Double precision and integer declarations.
56703 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56704 IMPLICIT INTEGER(I-N)
56705 C...Parameter statement to help give large particle numbers.
56706 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56707 &KEXCIT=4000000,KDIMEN=5000000)
56709 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56710 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
56711 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
56712 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
56713 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
56714 C...Local variables.
56715 DOUBLE PRECISION XLAM(0:400)
56716 INTEGER IDLAM(400,3), PYCOMP
56717 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
56719 C...IS R-VIOLATION ON ?
56720 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
56721 C...Mass eigenstate counter
56722 ICNT=INT(KFIN/KSUSY1)
56723 C...SM KF code of SUSY particle
56724 KFSM=KFIN-ICNT*KSUSY1
56725 C...Squared Sparticle Mass
56726 SM=PMAS(PYCOMP(KFIN),1)**2
56727 C... Squared mass of top quark
56728 SMT=PMAS(PYCOMP(6),1)**2
56729 C...IS L-VIOLATION ON ?
56730 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
56731 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
56732 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
56738 C...~e,~mu,~tau -> nu_I + lepton-_J
56740 IDLAM(LKNT,1)= 12 +2*(I-1)
56741 IDLAM(LKNT,2)= 11 +2*(J-1)
56744 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56745 IF (IMSS(51).NE.0) XLAM(LKNT) =
56746 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56747 C...KINEMATICS CHECK
56748 IF (XLAM(LKNT).EQ.0D0) THEN
56754 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
56760 IDLAM(LKNT,1)=-12 -2*(I-1)
56761 IDLAM(LKNT,2)= 11 +2*(K-1)
56764 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56765 IF (IMSS(51).NE.0) XLAM(LKNT) =
56766 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56767 C...KINEMATICS CHECK
56768 IF (XLAM(LKNT).EQ.0D0) THEN
56774 C...~e,~mu,~tau -> u_Jbar + d_K
56779 IDLAM(LKNT,1)=-2 -2*(J-1)
56780 IDLAM(LKNT,2)= 1 +2*(K-1)
56783 IF (IMSS(52).NE.0) THEN
56784 C...Use massive top quark
56785 IF (IDLAM(LKNT,1).EQ.-6) THEN
56786 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
56789 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
56790 C...If no top quark, all decay products massless
56792 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56794 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56796 C...KINEMATICS CHECK
56797 IF (XLAM(LKNT).EQ.0D0) THEN
56804 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
56805 C...No right-handed neutrinos
56807 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
56812 C...~nu_J -> lepton+_I + lepton-_K
56814 IDLAM(LKNT,1)=-11 -2*(I-1)
56815 IDLAM(LKNT,2)= 11 +2*(K-1)
56818 RM2=RVLAM(I,J,K)**2 * SM
56819 IF (IMSS(51).NE.0) XLAM(LKNT) =
56820 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56821 C...KINEMATICS CHECK
56822 IF (XLAM(LKNT).EQ.0D0) THEN
56828 C...~nu_I -> dbar_J + d_K
56833 IDLAM(LKNT,1)=-1 -2*(J-1)
56834 IDLAM(LKNT,2)= 1 +2*(K-1)
56837 RM2=3*RVLAMP(I,J,K)**2 * SM
56838 IF (IMSS(52).NE.0) XLAM(LKNT) =
56839 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56840 C...KINEMATICS CHECK
56841 IF (XLAM(LKNT).EQ.0D0) THEN
56848 C * SDOWN -> NU(BAR) + D and LEPTON- + U
56849 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
56853 C...~d_J -> nu_Ibar + d_K
56855 IDLAM(LKNT,1)=-12 -2*(I-1)
56856 IDLAM(LKNT,2)= 1 +2*(K-1)
56859 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56860 IF (IMSS(52).NE.0) XLAM(LKNT) =
56861 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56862 C...KINEMATICS CHECK
56863 IF (XLAM(LKNT).EQ.0D0) THEN
56871 C...~d_K -> nu_I + d_J
56873 IDLAM(LKNT,1)= 12 +2*(I-1)
56874 IDLAM(LKNT,2)= 1 +2*(J-1)
56877 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56878 IF (IMSS(52).NE.0) XLAM(LKNT) =
56879 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56880 C...KINEMATICS CHECK
56881 IF (XLAM(LKNT).EQ.0D0) THEN
56884 C...~d_K -> lepton_I- + u_J
56886 IDLAM(LKNT,1)= 11 +2*(I-1)
56887 IDLAM(LKNT,2)= 2 +2*(J-1)
56890 IF (IMSS(52).NE.0) THEN
56891 C...Use massive top quark
56892 IF (IDLAM(LKNT,2).EQ.6) THEN
56893 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
56895 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
56896 C...If no top quark, all decay products massless
56898 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56900 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56902 C...KINEMATICS CHECK
56903 IF (XLAM(LKNT).EQ.0D0) THEN
56910 C * SUP -> LEPTON+ + D
56911 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
56915 C...~u_J -> lepton_I+ + d_K
56917 IDLAM(LKNT,1)=-11 -2*(I-1)
56918 IDLAM(LKNT,2)= 1 +2*(K-1)
56921 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56922 IF (IMSS(52).NE.0) XLAM(LKNT) =
56923 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56924 C...KINEMATICS CHECK
56925 IF (XLAM(LKNT).EQ.0D0) THEN
56932 C...BARYON NUMBER VIOLATING DECAYS
56933 IF (IMSS(53).GE.1) THEN
56934 C * SUP -> DBAR + DBAR
56935 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
56939 C...~u_I -> dbar_J + dbar_K
56941 C...(anti-) symmetry J <-> K.
56943 IDLAM(LKNT,1) = -1 -2*(J-1)
56944 IDLAM(LKNT,2) = -1 -2*(K-1)
56947 RM2 = 2.*(RVLAMB(I,J,K)**2)
56948 & * SFMIX(KFSM,2*ICNT)**2 * SM
56950 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56951 C...KINEMATICS CHECK
56952 IF (XLAM(LKNT).EQ.0D0) THEN
56959 C * SDOWN -> UBAR + DBAR
56960 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
56964 C...LAMB coupling antisymmetric in J and K.
56966 C...~d_K -> ubar_I + dbar_K
56968 IDLAM(LKNT,1)= -2 -2*(I-1)
56969 IDLAM(LKNT,2)= -1 -2*(J-1)
56972 C...Use massive top quark
56973 IF (IDLAM(LKNT,1).EQ.-6) THEN
56974 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
56977 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
56978 C...If no top quark, all decay products massless
56980 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56982 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56984 C...KINEMATICS CHECK
56985 IF (XLAM(LKNT).EQ.0D0) THEN
56998 C*********************************************************************
57001 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
57004 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
57006 C...Double precision and integer declarations.
57007 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57008 IMPLICIT INTEGER(I-N)
57009 C...Parameter statement to help give large particle numbers.
57010 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57011 &KEXCIT=4000000,KDIMEN=5000000)
57013 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57014 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57015 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57016 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57017 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57018 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57019 C...Local variables.
57020 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57022 DOUBLE PRECISION XLAM(0:400)
57023 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
57024 INTEGER IDLAM(400,3), PYCOMP
57026 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
57028 C...R-VIOLATING DECAYS
57029 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57031 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
57032 C...WHICH NEUTRALINO ?
57034 IF (KFSM.EQ.23) NCHI=2
57035 IF (KFSM.EQ.25) NCHI=3
57036 IF (KFSM.EQ.35) NCHI=4
57037 C...SIGN OF MASS (Opposite convention as HERWIG)
57039 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
57041 C...Useful parameters for the calculation of the A and B constants.
57042 WMASS = PMAS(PYCOMP(24),1)
57043 ECHG = 2*SQRT(PARU(103)*PARU(1))
57044 COSB=1/(SQRT(1+RMSS(5)**2))
57045 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
57046 COSW=SQRT(1-PARU(102))
57047 SINW=SQRT(PARU(102))
57048 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
57049 C...Run quark masses to neutralino mass squared (for Higgs-type
57051 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
57053 RMQ(I)=PYMRUN(I,SQMCHI)
57055 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
57057 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
57058 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
57059 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
57060 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
57062 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
57063 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
57064 C2=ECHG*ZPMIX(NCHI,1)
57065 C3=GW*ZPMIX(NCHI,2)/COSW
57069 C x=1-2 : Select A or B constant (1:A ; 2:B)
57070 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57071 C 11-16:e,nu_e,mu,...)
57072 C z=1-2 : Mass eigenstate number
57073 C...CALCULATE COUPLINGS
57075 CMS=PMAS(PYCOMP(I),1)
57076 C...Intermediate sleptons
57077 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
57078 & *(C2-C3*SINW**2))
57079 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
57080 & *(C2-C3*SINW**2))
57081 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
57083 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
57085 C...Inermediate sneutrinos
57087 AB(2,I+1,1)=5D-1*C3
57090 C...Inermediate sdown
57093 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
57094 & *ED*(C2-C3*SINW**2))
57095 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
57096 & *ED*(C2-C3*SINW**2))
57097 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
57098 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57099 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
57100 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57101 C...Inermediate sup
57104 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
57105 & *EU*(C2-C3*SINW**2))
57106 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
57107 & *EU*(C2-C3*SINW**2))
57108 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
57109 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57110 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
57111 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57114 IF (IMSS(51).GE.1) THEN
57115 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
57116 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
57117 C...STEP IN I,J,K USING SINGLE COUNTER
57119 C...LAMBDA COUPLING ASYM IN I,J
57120 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57122 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57123 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57124 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57126 C...Set coupling, and decay product masses on/off
57127 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57128 & ,MOD(ISC,3)+1)**2
57130 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
57132 C...Resonance KF codes (1=I,2=J,3=K)
57133 KFR(1)=-IDLAM(LKNT,1)
57134 KFR(2)=-IDLAM(LKNT,2)
57135 KFR(3)=-IDLAM(LKNT,3)
57136 C...Calculate width.
57137 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57138 & IDLAM(LKNT,3),XLAM(LKNT))
57139 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57140 C...Charge conjugate mode.
57142 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57143 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57144 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57145 XLAM(LKNT)=XLAM(LKNT-1)
57146 C...KINEMATICS CHECK
57147 IF (XLAM(LKNT).EQ.0D0) THEN
57154 IF (IMSS(52).GE.1) THEN
57155 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
57156 C * CHI0 -> NUBAR_I + DBAR_J + D_K
57159 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57160 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57161 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57163 C...Set coupling, and decay product masses on/off
57164 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57165 & ,MOD(ISC,3)+1)**2
57167 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
57169 C...Resonance KF codes (1=I,2=J,3=K)
57170 KFR(1)=-IDLAM(LKNT,1)
57171 KFR(2)=-IDLAM(LKNT,2)
57172 KFR(3)=-IDLAM(LKNT,3)
57173 C...Calculate width.
57174 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57176 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57177 C...Charge conjugate mode.
57179 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57180 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57181 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57182 XLAM(LKNT)=XLAM(LKNT-1)
57183 C...KINEMATICS CHECK
57184 IF (XLAM(LKNT).EQ.0D0) THEN
57188 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
57190 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57191 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57192 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57194 C...Set coupling, and decay product masses on/off
57195 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57196 & ,MOD(ISC,3)+1)**2
57198 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
57199 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
57200 C...Resonance KF codes (1=I,2=J,3=K)
57201 KFR(1)=-IDLAM(LKNT,1)
57202 KFR(2)=-IDLAM(LKNT,2)
57203 KFR(3)=-IDLAM(LKNT,3)
57204 C...Calculate width.
57205 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57207 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57208 C...Charge conjugate mode.
57210 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57211 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57212 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57213 XLAM(LKNT)=XLAM(LKNT-1)
57214 C...KINEMATICS CHECK
57215 IF (XLAM(LKNT).EQ.0D0) THEN
57221 IF (IMSS(53).GE.1) THEN
57222 C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
57223 C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
57225 C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
57226 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
57228 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
57229 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57230 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57232 C...Set coupling, and decay product masses on/off
57233 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
57234 & +1,MOD(ISC,3)+1)**2
57236 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
57237 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
57238 C...Resonance KF codes (1=I,2=J,3=K)
57239 KFR(1) = IDLAM(LKNT,1)
57240 KFR(2) = IDLAM(LKNT,2)
57241 KFR(3) = IDLAM(LKNT,3)
57242 C...Calculate width.
57243 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57244 & IDLAM(LKNT,3),XLAM(LKNT))
57245 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57246 C...Charge conjugate mode.
57248 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57249 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57250 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57251 XLAM(LKNT)=XLAM(LKNT-1)
57252 C...KINEMATICS CHECK
57253 IF (XLAM(LKNT).EQ.0D0) THEN
57265 C*********************************************************************
57268 C...Calculates R-violating chargino decay widths.
57271 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
57273 C...Double precision and integer declarations.
57274 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57275 IMPLICIT INTEGER(I-N)
57276 C...Parameter statement to help give large particle numbers.
57277 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57278 &KEXCIT=4000000,KDIMEN=5000000)
57280 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57281 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57282 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57283 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57284 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57285 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57286 C...Local variables.
57287 DOUBLE PRECISION XLAM(0:400)
57288 INTEGER IDLAM(400,3), PYCOMP
57289 C...Information from main routine to PYRVGW
57290 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57292 C...Auxiliary variables needed for BV (RV Gauge STOre)
57293 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
57295 C...Running quark masses
57296 DOUBLE PRECISION RMQ(6)
57297 C...Decay product masses on/off
57299 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57303 C...IF R-VIOLATION ON.
57304 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57306 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
57307 C...WHICH CHARGINO ?
57309 IF (KFSM.EQ.37) NCHI = 2
57311 C...Useful parameters for calculating the A and B constants.
57312 C...SIGN OF MASS (Opposite convention as HERWIG)
57314 IF (SMW(NCHI).LT.0D0) ISM = -1
57315 WMASS = PMAS(PYCOMP(24),1)
57316 COSB = 1/(SQRT(1+RMSS(5)**2))
57317 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
57318 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
57319 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
57320 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
57323 C...Running masses at Q^2=MCHI^2.
57324 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
57326 RMQ(I)=PYMRUN(I,SQMCHI)
57329 C... AB(x,y,z) coefficients:
57330 C x=1-2 : A or B coefficient (1:A ; 2:B)
57331 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57332 C 11-16:e,nu_e,mu,...)
57333 C z=1-2 : Mass eigenstate number
57335 C...Intermediate sleptons
57338 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
57340 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
57342 C...Intermediate sneutrinos
57343 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
57345 AB(2,I+1,1) = ISM*C3
57347 C...Intermediate sdown
57349 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
57350 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
57351 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
57352 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
57353 C...Intermediate sup
57355 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
57356 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
57357 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
57358 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
57361 C...LLE TYPE R-VIOLATION
57362 IF (IMSS(51).GE.1) THEN
57363 C...LOOP OVER DECAY MODES
57366 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
57367 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57369 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
57370 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
57371 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
57373 C...Set coupling, and decay product masses on/off
57374 RVLAMC = GW2 * 5D-1 *
57375 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57378 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
57379 C...Resonance KF codes (1=I,2=J,3=K).
57382 KFR(3) = -IDLAM(LKNT,3)+1
57383 C...Calculate width.
57384 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57385 & IDLAM(LKNT,3),XLAM(LKNT))
57386 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57387 C...KINEMATICS CHECK
57388 IF (XLAM(LKNT).EQ.0D0) THEN
57392 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
57393 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
57395 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
57396 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
57397 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
57399 C...Set coupling, and decay product masses on/off
57400 RVLAMC = GW2 * 5D-1 *
57401 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57402 C...I,J SYMMETRY => FACTOR 2
57405 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
57406 C...Resonance KF codes (1=I,2=J,3=K)
57407 KFR(1)=IDLAM(LKNT,1)-1
57408 KFR(2)=IDLAM(LKNT,2)-1
57410 C...Calculate width.
57411 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57412 & IDLAM(LKNT,3),XLAM(LKNT))
57413 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57414 C...KINEMATICS CHECK
57415 IF (XLAM(LKNT).EQ.0D0) THEN
57420 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
57422 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57423 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57424 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57426 C...Set coupling, and decay product masses on/off
57427 RVLAMC = GW2 * 5D-1 *
57428 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57429 C...I,J SYMMETRY => FACTOR 2
57432 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
57433 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
57434 C...Resonance KF codes (1=I,2=J,3=K)
57435 KFR(1) =-IDLAM(LKNT,1)+1
57436 KFR(2) =-IDLAM(LKNT,2)+1
57438 C...Calculate width.
57439 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57440 & IDLAM(LKNT,3),XLAM(LKNT))
57441 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57442 C...KINEMATICS CHECK
57443 IF (XLAM(LKNT).EQ.0D0) THEN
57450 C...LQD TYPE R-VIOLATION
57451 IF (IMSS(52).GE.1) THEN
57452 C...LOOP OVER DECAY MODES
57455 C...CHI+ -> NUBAR_I + DBAR_J + U_K
57457 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57458 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57459 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
57461 C...Set coupling, and decay product masses on/off
57462 RVLAMC = 3. * GW2 * 5D-1 *
57463 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57465 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
57467 C...Resonance KF codes (1=I,2=J,3=K)
57470 KFR(3)=-IDLAM(LKNT,3)+1
57471 C...Calculate width.
57472 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57474 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57475 C...KINEMATICS CHECK
57476 IF (XLAM(LKNT).EQ.0D0) THEN
57480 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
57482 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57483 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57484 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
57486 C...Set coupling, and decay product masses on/off
57487 RVLAMC = 3. * GW2 * 5D-1 *
57488 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57490 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
57491 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
57492 C...Resonance KF codes (1=I,2=J,3=K)
57495 KFR(3)=-IDLAM(LKNT,3)+1
57496 C...Calculate width.
57497 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57499 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57500 C...KINEMATICS CHECK
57501 IF (XLAM(LKNT).EQ.0D0) THEN
57505 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
57507 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57508 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57509 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57511 C...Set coupling, and decay product masses on/off
57512 RVLAMC = 3. * GW2 * 5D-1 *
57513 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57515 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
57516 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
57517 C...Resonance KF codes (1=I,2=J,3=K)
57518 KFR(1)=-IDLAM(LKNT,1)+1
57519 KFR(2)=-IDLAM(LKNT,2)+1
57521 C...Calculate width.
57522 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57524 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57525 C...KINEMATICS CHECK
57526 IF (XLAM(LKNT).EQ.0D0) THEN
57530 C * CHI+ -> NU_I + U_J + DBAR_K.
57532 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
57533 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
57534 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57536 C...Set coupling, and decay product masses on/off
57538 RVLAMC = 3. * GW2 * 5D-1 *
57539 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57540 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
57542 C...Resonance KF codes (1=I,2=J,3=K)
57543 KFR(1)=IDLAM(LKNT,1)-1
57544 KFR(2)=IDLAM(LKNT,2)-1
57546 C...Calculate width.
57547 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57549 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57550 C...KINEMATICS CHECK
57551 IF (XLAM(LKNT).EQ.0D0) THEN
57558 C...UDD TYPE R-VIOLATION
57559 C...These decays need special treatment since more than one BV coupling
57560 C...contributes (with interference). Consider e.g. (symbolically)
57561 C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
57562 C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
57563 C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
57564 C...The problem is that a single call to PYRVGW would evaluate all
57565 C...these terms and sum them, but without the different couplings. The
57566 C...way out is to call PYRVGW three times, once for the first line, once
57567 C...for the second line, and then once for all the lines (it is
57568 C...impossible to get just the last line out) without multiplying by
57569 C...couplings. The last line is then obtained as the result of the third
57570 C...call minus the results of the two first calls. Each term is then
57571 C...multiplied by its respective coupling before the whole thing is
57572 C...summed up in XLAM.
57573 C...Note that with three interfering resonances, this procedure becomes
57574 C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
57576 IF (IMSS(53).GE.1) THEN
57577 C...LOOP OVER DECAY MODES
57580 C...CHI+ -> U_I + U_J + D_K
57581 C...Decay mode I<->J symmetric.
57582 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
57584 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
57585 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
57586 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57588 C...Set coupling, and decay product masses on/off
57589 RVLAMC= 6. * GW2 * 5D-1
57590 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
57592 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
57594 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
57597 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
57598 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
57599 C...Resonance KF codes (1=I,2=J,3=K)
57600 KFR(1) = -IDLAM(LKNT,1)+1
57603 C...Calculate width.
57604 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57605 & IDLAM(LKNT,3),XRESI)
57606 C...Resonance KF codes (1=I,2=J,3=K)
57608 KFR(2) = -IDLAM(LKNT,2)+1
57610 C...Calculate width.
57611 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57612 & IDLAM(LKNT,3),XRESJ)
57613 C...Resonance KF codes (1=I,2=J,3=K)
57614 KFR(1) = -IDLAM(LKNT,1)+1
57615 KFR(2) = -IDLAM(LKNT,2)+1
57617 C...Calculate width.
57618 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57619 & IDLAM(LKNT,3),XRESIJ)
57620 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
57621 XRESIJ = XRESIJ-XRESI-XRESJ
57625 C...CALCULATE TOTAL WIDTH
57626 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
57627 & + RVLJIK*RVLIJK * XRESIJ
57628 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57629 C...KINEMATICS CHECK
57630 IF (XLAM(LKNT).EQ.0D0) THEN
57634 C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
57635 C...Symmetry I<->J<->K.
57636 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
57637 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
57639 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
57640 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57641 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57643 C...Set coupling, and decay product masses on/off
57644 RVLAMC = 6. * GW2 * 5D-1
57645 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
57647 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
57649 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
57652 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
57653 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
57654 C...Collect symmetry factors
57655 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
57656 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
57657 & RVLAMC = 5D-1 * RVLAMC
57658 C...Resonance KF codes (1=I,2=J,3=K)
57659 KFR(1) = IDLAM(LKNT,1)-1
57662 C...Calculate width.
57663 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57664 & IDLAM(LKNT,3),XRESI)
57665 C...Resonance KF codes (1=I,2=J,3=K)
57667 KFR(2) = IDLAM(LKNT,2)-1
57669 C...Calculate width.
57670 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57671 & IDLAM(LKNT,3),XRESJ)
57672 C...Resonance KF codes (1=I,2=J,3=K)
57675 KFR(3) = IDLAM(LKNT,3)-1
57676 C...Calculate width.
57677 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57678 & IDLAM(LKNT,3),XRESK)
57679 C...Resonance KF codes (1=I,2=J,3=K)
57680 KFR(1) = IDLAM(LKNT,1)-1
57681 KFR(2) = IDLAM(LKNT,2)-1
57683 C...Calculate width.
57684 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57685 & IDLAM(LKNT,3),XRESIJ)
57686 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*(XRESI+XRESJ)) THEN
57687 XRESIJ = XRESI+XRESJ-XRESIJ
57691 C...Resonance KF codes (1=I,2=J,3=K)
57693 KFR(2) = IDLAM(LKNT,2)-1
57694 KFR(3) = IDLAM(LKNT,3)-1
57695 C...Calculate width.
57696 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57697 & IDLAM(LKNT,3),XRESJK)
57698 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*(XRESJ+XRESK)) THEN
57699 XRESJK = XRESJ+XRESK-XRESJK
57703 C...Resonance KF codes (1=I,2=J,3=K)
57704 KFR(1) = IDLAM(LKNT,1)-1
57706 KFR(3) = IDLAM(LKNT,3)-1
57707 C...Calculate width.
57708 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57709 & IDLAM(LKNT,3),XRESIK)
57710 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*(XRESI+XRESK)) THEN
57711 XRESIK = XRESI+XRESK-XRESIK
57715 C...CALCULATE TOTAL WIDTH
57717 & RVLIJK**2 * XRESI
57718 & + RVLJKI**2 * XRESJ
57719 & + RVLKIJ**2 * XRESK
57720 & + RVLIJK*RVLJKI * XRESIJ
57721 & + RVLIJK*RVLKIJ * XRESIK
57722 & + RVLJKI*RVLKIJ * XRESJK
57723 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
57724 C...KINEMATICS CHECK
57725 IF (XLAM(LKNT).EQ.0D0) THEN
57737 C*********************************************************************
57740 C...Calculates R-violating gluino decay widths.
57741 C...See BV part of PYRVCH for comments about the way the BV decay width
57742 C...is calculated. Same comments apply here.
57745 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
57747 C...Double precision and integer declarations.
57748 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57749 IMPLICIT INTEGER(I-N)
57750 C...Parameter statement to help give large particle numbers.
57751 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57752 &KEXCIT=4000000,KDIMEN=5000000)
57754 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57755 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57756 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57757 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57758 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57759 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57760 C...Local variables.
57761 DOUBLE PRECISION XLAM(0:400)
57762 INTEGER IDLAM(400,3), PYCOMP
57763 C...Information from main routine to PYRVGW
57764 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57766 C...Auxiliary variables needed for BV (RV Gauge STOre)
57767 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
57769 C...Running quark masses
57770 DOUBLE PRECISION RMQ(6)
57771 C...Decay product masses on/off
57773 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57776 C...IF LQD OR UDD TYPE R-VIOLATION ON.
57777 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
57781 C x=1-2 : Select A or B coupling (1:A ; 2:B)
57782 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57783 C 11-16:e,nu_e,mu,... not used here)
57784 C z=1-2 : Mass eigenstate number
57787 AB(1,I,1) = SFMIX(I,2)
57788 AB(1,I,2) = SFMIX(I,4)
57790 AB(2,I,1) = -SFMIX(I,1)
57791 AB(2,I,2) = -SFMIX(I,3)
57793 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
57795 IF (IMSS(52).GE.1) THEN
57796 C...STEP IN I,J,K USING SINGLE COUNTER
57798 C * GLUINO -> NUBAR_I + DBAR_J + D_K.
57800 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57801 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57802 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57804 C...Set coupling, and decay product masses on/off
57805 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57808 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
57809 C...Resonance KF codes (1=I,2=J,3=K)
57811 KFR(2) = -IDLAM(LKNT,2)
57812 KFR(3) = -IDLAM(LKNT,3)
57813 C...Calculate width.
57814 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57817 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57818 C...Charge conjugate mode.
57820 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
57821 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
57822 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
57823 XLAM(LKNT) = XLAM(LKNT-1)
57824 C...KINEMATICS CHECK
57825 IF (XLAM(LKNT).EQ.0D0) THEN
57829 C * GLUINO -> LEPTON+_I + UBAR_J + D_K
57831 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57832 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57833 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57835 C...Set coupling, and decay product masses on/off
57836 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57837 & **2* 5D-1 * GSTR2
57839 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
57840 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
57841 C...Resonance KF codes (1=I,2=J,3=K)
57843 KFR(2) = -IDLAM(LKNT,2)
57844 KFR(3) = -IDLAM(LKNT,3)
57845 C...Calculate width.
57846 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57848 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57849 C...Charge conjugate mode.
57851 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
57852 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
57853 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
57854 XLAM(LKNT) = XLAM(LKNT-1)
57855 C...KINEMATICS CHECK
57856 IF (XLAM(LKNT).EQ.0D0) THEN
57864 IF (IMSS(53).GE.1) THEN
57865 C...STEP IN I,J,K USING SINGLE COUNTER
57867 C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
57868 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
57870 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
57871 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57872 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57874 C...Set coupling, and decay product masses on/off. A factor of 2 for
57875 C...(N_C-1) has been used to cancel a factor 0.5.
57876 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57879 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
57880 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
57881 C...Resonance KF codes (1=I,2=J,3=K)
57882 KFR(1) = IDLAM(LKNT,1)
57885 C...Calculate width.
57886 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57888 C...Resonance KF codes (1=I,2=J,3=K)
57890 KFR(2) = IDLAM(LKNT,2)
57892 C...Calculate width.
57893 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57895 C...Resonance KF codes (1=I,2=J,3=K)
57898 KFR(3) = IDLAM(LKNT,3)
57899 C...Calculate width.
57900 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57902 C...Resonance KF codes (1=I,2=J,3=K)
57903 KFR(1) = IDLAM(LKNT,1)
57904 KFR(2) = IDLAM(LKNT,2)
57906 C...Calculate width.
57907 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57909 C...Calculate interference function. (Factor -1/2 to make up for factor
57911 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
57912 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
57916 C...Resonance KF codes (1=I,2=J,3=K)
57918 KFR(2) = IDLAM(LKNT,2)
57919 KFR(3) = IDLAM(LKNT,3)
57920 C...Calculate width.
57921 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57923 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*XRESJK) THEN
57924 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
57928 C...Resonance KF codes (1=I,2=J,3=K)
57929 KFR(1) = IDLAM(LKNT,1)
57931 KFR(3) = IDLAM(LKNT,3)
57932 C...Calculate width.
57933 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57935 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*XRESIK) THEN
57936 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
57940 C...Calculate total width (factor 1/2 from 1/(N_C-1))
57941 XLAM(LKNT) = XRESI + XRESJ + XRESK
57942 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
57944 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57945 C...Charge conjugate mode.
57947 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
57948 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
57949 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
57950 XLAM(LKNT) = XLAM(LKNT-1)
57951 C...KINEMATICS CHECK
57952 IF (XLAM(LKNT).EQ.0D0) THEN
57962 C*********************************************************************
57965 C...Auxiliary function to PYRVSF for calculating R-Violating
57966 C...sfermion widths. Though the decay products are most often treated
57967 C...as massless in the calculation, the kinematical boundary of phase
57968 C...space is tested using the true masses.
57969 C...MODE = 1: All decay products massive
57970 C...MODE = 2: Decay product 1 massless
57971 C...MODE = 3: Decay product 2 massless
57972 C...MODE = 4: All decay products massless
57974 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
57976 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
57977 IMPLICIT INTEGER (I-N)
57978 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57979 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57980 SAVE /PYDAT1/,/PYDAT2/
57981 DOUBLE PRECISION SM(3)
57982 INTEGER PYCOMP, KC(3)
57986 SM(1)=PMAS(KC(1),1)**2
57987 SM(2)=PMAS(KC(2),1)**2
57988 SM(3)=PMAS(KC(3),1)**2
57989 C...Kinematics check
57990 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
57994 C...CM momenta squared
57995 IF (MODE.EQ.1) THEN
57996 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
57997 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
57998 ELSE IF (MODE.EQ.2) THEN
57999 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
58000 ELSE IF (MODE.EQ.3) THEN
58001 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
58005 C...Calculate Width
58006 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
58010 C*********************************************************************
58013 C...Generalized Matrix Element for R-Violating 3-body widths.
58015 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
58017 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
58018 IMPLICIT INTEGER (I-N)
58019 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58020 &KEXCIT=4000000,KDIMEN=5000000)
58021 PARAMETER (EPS=1D-4)
58022 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58023 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58025 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58026 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58027 DOUBLE PRECISION XLIM(3,3)
58028 INTEGER KC(0:3), PYCOMP
58029 LOGICAL DCMASS, DCHECK(6)
58030 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
58034 KC(0) = PYCOMP(KFIN)
58035 KC(1) = PYCOMP(ID1)
58036 KC(2) = PYCOMP(ID2)
58037 KC(3) = PYCOMP(ID3)
58038 RMS(0) = PMAS(KC(0),1)
58039 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
58040 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
58041 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
58042 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
58043 XLIM(1,1)=(RMS(1)+RMS(2))**2
58044 XLIM(1,2)=(RMS(0)-RMS(3))**2
58045 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
58046 XLIM(2,1)=(RMS(2)+RMS(3))**2
58047 XLIM(2,2)=(RMS(0)-RMS(1))**2
58048 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
58049 XLIM(3,1)=(RMS(1)+RMS(3))**2
58050 XLIM(3,2)=(RMS(0)-RMS(2))**2
58051 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
58052 C...Check Phase Space
58053 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
58057 C...INITIALIZE RESONANCE INFORMATION
58060 IRES = 2*(JRES-1)+IMASS
58062 DCHECK(IRES) =.FALSE.
58063 C...NO RIGHT-HANDED NEUTRINOS
58064 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
58065 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
58066 & .KFR(JRES).EQ.0) GOTO 100
58067 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
58068 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
58069 INTRES(IRES,1) = IABS(KFR(JRES))
58070 INTRES(IRES,2) = IMASS
58071 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
58072 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
58076 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
58078 C...RESONANCE CONTRIBUTIONS
58079 C...(Only sum contributions where the resonance is off shell).
58080 C...Store whether diagram on/off in DCHECK.
58081 C...LOOP OVER MASS STATES
58084 IF(INTRES(IDR,1).NE.0) THEN
58086 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58087 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
58088 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58089 DCHECK(IDR) =.TRUE.
58090 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
58095 IF(INTRES(IDR,1).NE.0) THEN
58096 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58097 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58098 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58099 DCHECK(IDR) =.TRUE.
58100 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
58105 IF(INTRES(IDR,1).NE.0) THEN
58106 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58107 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58108 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58109 DCHECK(IDR) =.TRUE.
58110 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
58114 C... L-R INTERFERENCES
58115 C... (Only add contributions where both contributing diagrams
58116 C... are non-resonant).
58118 IF (DCHECK(1).AND.DCHECK(2)) THEN
58119 C...Bug corrected 11/12 2001. Skands.
58120 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
58121 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
58122 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
58126 IF (DCHECK(3).AND.DCHECK(4)) THEN
58127 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
58128 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
58129 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
58133 IF (DCHECK(5).AND.DCHECK(6)) THEN
58134 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
58135 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
58136 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
58138 C... TRUE INTERFERENCES
58139 C... (Only add contributions where both contributing diagrams
58140 C... are non-resonant).
58142 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
58147 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58148 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
58149 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58150 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58155 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58156 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
58157 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58158 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58163 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58164 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
58165 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58166 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58174 C*********************************************************************
58177 C...Function to integrate resonance contributions
58179 FUNCTION PYRVI1(ID1,ID2,ID3)
58182 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
58183 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58184 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58185 LOGICAL MFLAG,DCMASS
58186 EXTERNAL PYRVG1,PYGAUS
58187 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58189 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58190 SAVE/PYRVNV/,/PYRVPM/
58191 C...Initialize mass and width information
58197 RESM(1)= RES(IDR,1)
58198 RESW(1)= RES(IDR,2)
58199 C...A->B and B->A for antisparticles
58200 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58201 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58202 C...Integration boundaries and mass flag
58203 LO = (RM(1)+RM(2))**2
58204 HI = (RM(0)-RM(3))**2
58206 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
58210 C*********************************************************************
58213 C...Function to integrate L-R interference contributions
58215 FUNCTION PYRVI2(ID1,ID2,ID3)
58218 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
58219 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58220 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58221 LOGICAL MFLAG,DCMASS
58222 EXTERNAL PYRVG2,PYGAUS
58223 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58225 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58226 SAVE/PYRVNV/,/PYRVPM/
58227 C...Initialize mass and width information
58233 RESM(1)= RES(IDR,1)
58234 RESW(1)= RES(IDR,2)
58235 RESM(2)= RES(IDR+1,1)
58236 RESW(2)= RES(IDR+1,2)
58237 C...A->B and B->A for antisparticles
58238 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58239 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58240 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
58241 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
58242 C...Boundaries and mass flag
58243 LO = (RM(1)+RM(2))**2
58244 HI = (RM(0)-RM(3))**2
58246 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
58250 C*********************************************************************
58253 C...Function to integrate true interference contributions
58255 FUNCTION PYRVI3(ID1,ID2,ID3)
58258 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
58259 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58260 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58261 LOGICAL MFLAG,DCMASS
58262 EXTERNAL PYRVG3,PYGAUS
58263 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58265 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58266 SAVE/PYRVNV/,/PYRVPM/
58267 C...Initialize mass and width information
58273 RESM(1)= RES(IDR,1)
58274 RESW(1)= RES(IDR,2)
58275 RESM(2)= RES(IDR2,1)
58276 RESW(2)= RES(IDR2,2)
58277 C...A -> B and B -> A for antisparticles
58278 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58279 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58280 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
58281 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
58282 C...Boundaries and mass flag
58283 LO = (RM(1)+RM(2))**2
58284 HI = (RM(0)-RM(3))**2
58286 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
58290 C*********************************************************************
58293 C...Integrand for resonance contributions
58298 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58299 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
58300 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
58303 RVR = PYRVR(X,RESM(1),RESW(1))
58304 C1 = 2D0*SQRT(MAX(0D0,X))
58305 IF (.NOT.MFLAG) THEN
58307 E3 = (RM(0)**2-X)/C1
58309 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
58311 E2 = (X-RM(1)**2+RM(2)**2)/C1
58312 E3 = (RM(0)**2-X-RM(3)**2)/C1
58313 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58314 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58315 DELTAY = 4D0*SR1*SR2
58316 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
58317 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
58318 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
58323 C*********************************************************************
58326 C...Integrand for L-R interference contributions
58331 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58332 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
58333 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
58336 C1 = 2D0*SQRT(MAX(0D0,X))
58337 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
58338 IF (.NOT.MFLAG) THEN
58340 E3 = (RM(0)**2-X)/C1
58342 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
58344 E2 = (X-RM(1)**2+RM(2)**2)/C1
58345 E3 = (RM(0)**2-X-RM(3)**2)/C1
58346 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58347 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58348 DELTAY = 4D0*SR1*SR2
58349 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
58350 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
58351 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
58356 C*********************************************************************
58359 C...Function to do Y integration over true interference contributions
58364 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58365 C...Second Dalitz variable for PYRVG4
58367 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
58368 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
58369 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
58371 EXTERNAL PYGAU2,PYRVG4
58372 SAVE/PYRVPM/,/PYG2DX/
58374 C1=2D0*SQRT(MAX(1D-9,X))
58376 IF (.NOT.MFLAG) THEN
58378 E3 = (RM(0)**2-X)/C1
58382 E2 = (X-RM(1)**2+RM(2)**2)/C1
58383 E3 = (RM(0)**2-X-RM(3)**2)/C1
58385 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58386 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58387 YMIN = SQ1-(SR1+SR2)**2
58388 YMAX = SQ1-(SR1-SR2)**2
58390 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
58394 C*********************************************************************
58397 C...Integrand for true intereference contributions
58402 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58404 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
58406 SAVE /PYRVPM/,/PYG2DX/
58408 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
58409 IF (.NOT.MFLAG) THEN
58410 PYRVG4 = RVS*B(1)*B(2)*X*Y
58412 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
58413 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
58414 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
58415 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
58420 C*********************************************************************
58423 C...Breit-Wigner for resonance contributions
58425 FUNCTION PYRVR(Mab2,RM,RW)
58428 DOUBLE PRECISION Mab2,RM,RW,PYRVR
58429 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
58433 C*********************************************************************
58436 C...Interference function
58438 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
58441 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
58442 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
58447 C*********************************************************************
58450 C...Stores one parton/particle in commonblock PYJETS.
58452 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
58454 C...Double precision and integer declarations.
58455 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58456 IMPLICIT INTEGER(I-N)
58457 INTEGER PYK,PYCHGE,PYCOMP
58459 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58460 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58461 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58462 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58464 C...Standard checks.
58466 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58467 IPA=MAX(1,IABS(IP))
58468 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
58469 &'(PY1ENT:) writing outside PYJETS memory')
58471 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
58473 C...Find mass. Reset K, P and V vectors.
58475 IF(MSTU(10).EQ.1) PM=P(IPA,5)
58476 IF(MSTU(10).GE.2) PM=PYMASS(KF)
58483 C...Store parton/particle in K and P vectors.
58485 IF(IP.LT.0) K(IPA,1)=2
58488 P(IPA,4)=MAX(PE,PM)
58489 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
58490 P(IPA,1)=PA*SIN(THE)*COS(PHI)
58491 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
58492 P(IPA,3)=PA*COS(THE)
58494 C...Set N. Optionally fragment/decay.
58496 IF(IP.EQ.0) CALL PYEXEC
58501 C*********************************************************************
58504 C...Stores two partons/particles in their CM frame,
58505 C...with the first along the +z axis.
58507 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
58509 C...Double precision and integer declarations.
58510 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58511 IMPLICIT INTEGER(I-N)
58512 INTEGER PYK,PYCHGE,PYCOMP
58514 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58515 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58516 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58517 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58519 C...Standard checks.
58521 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58522 IPA=MAX(1,IABS(IP))
58523 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
58524 &'(PY2ENT:) writing outside PYJETS memory')
58527 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
58528 &'(PY2ENT:) unknown flavour code')
58530 C...Find masses. Reset K, P and V vectors.
58532 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58533 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58535 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58536 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58545 C...Check flavours.
58546 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58547 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58548 IF(MSTU(19).EQ.1) THEN
58551 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
58552 & '(PY2ENT:) unphysical flavour combination')
58557 C...Store partons/particles in K vectors for normal case.
58560 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
58563 C...Store partons in K vectors for parton shower evolution.
58567 K(IPA,4)=MSTU(5)*(IPA+1)
58569 K(IPA+1,4)=MSTU(5)*IPA
58570 K(IPA+1,5)=K(IPA+1,4)
58573 C...Check kinematics and store partons/particles in P vectors.
58574 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
58575 &'(PY2ENT:) energy smaller than sum of masses')
58576 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
58579 P(IPA,4)=SQRT(PM1**2+PA**2)
58582 P(IPA+1,4)=SQRT(PM2**2+PA**2)
58585 C...Set N. Optionally fragment/decay.
58587 IF(IP.EQ.0) CALL PYEXEC
58592 C*********************************************************************
58595 C...Stores three partons or particles in their CM frame,
58596 C...with the first along the +z axis and the third in the (x,z)
58597 C...plane with x > 0.
58599 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
58601 C...Double precision and integer declarations.
58602 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58603 IMPLICIT INTEGER(I-N)
58604 INTEGER PYK,PYCHGE,PYCOMP
58606 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58607 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58608 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58609 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58611 C...Standard checks.
58613 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58614 IPA=MAX(1,IABS(IP))
58615 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
58616 &'(PY3ENT:) writing outside PYJETS memory')
58620 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
58621 &'(PY3ENT:) unknown flavour code')
58623 C...Find masses. Reset K, P and V vectors.
58625 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58626 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58628 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58629 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58631 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
58632 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
58641 C...Check flavours.
58642 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58643 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58644 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
58645 IF(MSTU(19).EQ.1) THEN
58647 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
58648 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
58649 & KQ1+KQ3.EQ.4)) THEN
58651 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
58657 C...Store partons/particles in K vectors for normal case.
58660 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
58662 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
58665 C...Store partons in K vectors for parton shower evolution.
58671 IF(KQ1.EQ.-1) KCS=5
58672 K(IPA,KCS)=MSTU(5)*(IPA+1)
58673 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
58674 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
58675 K(IPA+1,9-KCS)=MSTU(5)*IPA
58676 K(IPA+2,KCS)=MSTU(5)*IPA
58677 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
58680 C...Check kinematics.
58682 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
58683 &0.5D0*X3*PECM.LE.PM3) MKERR=1
58684 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
58685 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
58686 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
58687 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
58688 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
58689 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
58690 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
58691 IF(MKERR.NE.0) CALL PYERRM(13,
58692 &'(PY3ENT:) unphysical kinematical variable setup')
58694 C...Store partons/particles in P vectors.
58696 P(IPA,4)=SQRT(PA1**2+PM1**2)
58698 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
58699 P(IPA+2,3)=PA3*CTHE3
58700 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
58702 P(IPA+1,1)=-P(IPA+2,1)
58703 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
58704 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
58707 C...Set N. Optionally fragment/decay.
58709 IF(IP.EQ.0) CALL PYEXEC
58714 C*********************************************************************
58717 C...Stores four partons or particles in their CM frame, with
58718 C...the first along the +z axis, the last in the xz plane with x > 0
58719 C...and the second having y < 0 and y > 0 with equal probability.
58721 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
58723 C...Double precision and integer declarations.
58724 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58725 IMPLICIT INTEGER(I-N)
58726 INTEGER PYK,PYCHGE,PYCOMP
58728 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58729 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58730 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58731 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58733 C...Standard checks.
58735 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58736 IPA=MAX(1,IABS(IP))
58737 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
58738 &'(PY4ENT:) writing outside PYJETS momory')
58743 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
58744 &'(PY4ENT:) unknown flavour code')
58746 C...Find masses. Reset K, P and V vectors.
58748 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58749 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58751 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58752 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58754 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
58755 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
58757 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
58758 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
58767 C...Check flavours.
58768 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58769 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58770 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
58771 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
58772 IF(MSTU(19).EQ.1) THEN
58774 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
58775 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
58776 & KQ1+KQ4.EQ.4)) THEN
58777 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
58780 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
58787 C...Store partons/particles in K vectors for normal case.
58790 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
58792 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
58795 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
58798 C...Store partons for parton shower evolution from q-g-g-qbar or
58800 ELSEIF(KQ1+KQ2.NE.0) THEN
58806 IF(KQ1.EQ.-1) KCS=5
58807 K(IPA,KCS)=MSTU(5)*(IPA+1)
58808 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
58809 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
58810 K(IPA+1,9-KCS)=MSTU(5)*IPA
58811 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
58812 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
58813 K(IPA+3,KCS)=MSTU(5)*IPA
58814 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
58816 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
58822 K(IPA,4)=MSTU(5)*(IPA+1)
58824 K(IPA+1,4)=MSTU(5)*IPA
58825 K(IPA+1,5)=K(IPA+1,4)
58826 K(IPA+2,4)=MSTU(5)*(IPA+3)
58827 K(IPA+2,5)=K(IPA+2,4)
58828 K(IPA+3,4)=MSTU(5)*(IPA+2)
58829 K(IPA+3,5)=K(IPA+3,4)
58832 C...Check kinematics.
58834 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
58835 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
58837 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
58838 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
58839 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
58840 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
58841 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
58842 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
58843 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
58844 STHE4=SQRT(1D0-CTHE4**2)
58845 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
58846 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
58847 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
58848 STHE2=SQRT(1D0-CTHE2**2)
58849 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
58850 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
58851 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
58852 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
58853 IF(MKERR.EQ.1) CALL PYERRM(13,
58854 &'(PY4ENT:) unphysical kinematical variable setup')
58856 C...Store partons/particles in P vectors.
58858 P(IPA,4)=SQRT(PA1**2+PM1**2)
58860 P(IPA+3,1)=PA4*STHE4
58861 P(IPA+3,3)=PA4*CTHE4
58862 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
58864 P(IPA+1,1)=PA2*STHE2*CPHI2
58865 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
58866 P(IPA+1,3)=PA2*CTHE2
58867 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
58869 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
58870 P(IPA+2,2)=-P(IPA+1,2)
58871 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
58872 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
58875 C...Set N. Optionally fragment/decay.
58877 IF(IP.EQ.0) CALL PYEXEC
58882 C*********************************************************************
58885 C...An interface from a two-fermion generator to include
58886 C...parton showers and hadronization.
58888 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
58890 C...Double precision and integer declarations.
58891 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58892 IMPLICIT INTEGER(I-N)
58893 INTEGER PYK,PYCHGE,PYCOMP
58895 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58896 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58897 SAVE /PYJETS/,/PYDAT1/
58899 DIMENSION IJOIN(2),INTAU(2)
58901 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
58907 C...Loop through entries and pick up all final fermions/antifermions.
58911 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
58913 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
58914 IF(K(I,2).GT.0) THEN
58918 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
58924 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
58930 C...Check that event is arranged according to conventions.
58931 IF(I1.EQ.0.OR.I2.EQ.0) THEN
58932 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
58935 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
58938 C...Check whether fermion pair is quarks or leptons.
58939 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
58941 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
58944 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
58947 C...Decide whether to allow or not photon radiation in showers.
58949 IF(IRAD.EQ.0) MSTJ(41)=1
58951 C...Do colour joining and parton showers.
58954 IF(IQL12.EQ.1) THEN
58957 CALL PYJOIN(2,IJOIN)
58959 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
58960 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
58961 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
58962 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
58965 C...Do fragmentation and decays. Possibly except tau decay.
58969 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
58983 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
58991 C*********************************************************************
58994 C...An interface from a four-fermion generator to include
58995 C...parton showers and hadronization.
58997 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
58999 C...Double precision and integer declarations.
59000 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59001 IMPLICIT INTEGER(I-N)
59002 INTEGER PYK,PYCHGE,PYCOMP
59004 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59005 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59006 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59007 COMMON/PYINT1/MINT(400),VINT(400)
59008 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
59010 DIMENSION IJOIN(2),INTAU(4)
59012 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59018 C...Loop through entries and pick up all final fermions/antifermions.
59024 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59026 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59027 IF(K(I,2).GT.0) THEN
59030 ELSEIF(I3.EQ.0) THEN
59033 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
59038 ELSEIF(I4.EQ.0) THEN
59041 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
59047 C...Check that event is arranged according to conventions.
59048 IF(I3.EQ.0.OR.I4.EQ.0) THEN
59049 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
59051 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59052 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
59055 C...Check which fermion pairs are quarks and which leptons.
59056 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59058 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59061 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
59063 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59065 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59068 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
59071 C...Decide whether to allow or not photon radiation in showers.
59073 IF(IRAD.EQ.0) MSTJ(41)=1
59075 C...Decide on dipole pairing.
59080 IF(IQL12.EQ.IQL34) THEN
59083 DELTA=ATOTSQ-A1SQ-A2SQ
59084 IF(ISTRAT.EQ.1) THEN
59085 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
59086 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
59087 ELSEIF(ISTRAT.EQ.2) THEN
59088 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
59089 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
59091 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
59097 C...If colour reconnection then bookkeep W+W- or Z0Z0
59098 C...and copy q qbar q qbar consecutively.
59099 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59108 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
59112 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
59126 P(N+1,J)=P(IP1,J)+P(IP2,J)
59127 P(N+2,J)=P(IP3,J)+P(IP4,J)
59139 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59141 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59147 C...Remove original q qbar q qbar and update counters.
59148 K(IP1,1)=K(IP1,1)+10
59149 K(IP2,1)=K(IP2,1)+10
59150 K(IP3,1)=K(IP3,1)+10
59151 K(IP4,1)=K(IP4,1)+10
59162 C...Do colour joinings and parton showers.
59163 IF(IQL12.EQ.1) THEN
59166 CALL PYJOIN(2,IJOIN)
59168 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59169 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59170 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59171 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59174 IF(IQL34.EQ.1) THEN
59177 CALL PYJOIN(2,IJOIN)
59179 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59180 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59181 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59182 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59185 C...Optionally do colour reconnection.
59188 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59189 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
59193 C...Do fragmentation and decays. Possibly except tau decay.
59197 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59211 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59219 C*********************************************************************
59222 C...An interface from a six-fermion generator to include
59223 C...parton showers and hadronization.
59225 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
59227 C...Double precision and integer declarations.
59228 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59229 IMPLICIT INTEGER(I-N)
59230 INTEGER PYK,PYCHGE,PYCOMP
59232 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59233 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59234 SAVE /PYJETS/,/PYDAT1/
59236 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
59238 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59244 C...Loop through entries and pick up all final fermions/antifermions.
59252 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59254 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59255 IF(K(I,2).GT.0) THEN
59258 ELSEIF(I3.EQ.0) THEN
59260 ELSEIF(I5.EQ.0) THEN
59263 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
59268 ELSEIF(I4.EQ.0) THEN
59270 ELSEIF(I6.EQ.0) THEN
59273 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
59279 C...Check that event is arranged according to conventions.
59280 IF(I5.EQ.0.OR.I6.EQ.0) THEN
59281 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
59283 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
59284 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
59287 C...Check which fermion pairs are quarks and which leptons.
59288 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59290 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59293 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
59295 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59297 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59300 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
59302 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
59304 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
59307 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
59310 C...Decide whether to allow or not photon radiation in showers.
59312 IF(IRAD.EQ.0) MSTJ(41)=1
59314 C...Allow dipole pairings only among leptons and quarks separately.
59317 IF(IQL34.EQ.IQL56) P13D=P13
59319 IF(IQL12.EQ.IQL34) P21D=P21
59321 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
59323 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
59325 IF(IQL12.EQ.IQL56) P32D=P32
59327 C...Decide whether t+tbar.
59329 IF(PYR(0).LT.PTOP) THEN
59332 C...If t+tbar: reconstruct t's.
59338 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
59339 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
59347 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
59349 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
59353 C...If t+tbar: colour join t's and let them shower.
59356 CALL PYJOIN(2,IJOIN)
59357 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
59358 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
59359 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
59361 C...If t+tbar: pick up the t's after shower.
59365 IF(K(I,2).EQ.6) ITNEW=I
59366 IF(K(I,2).EQ.-6) ITBNEW=I
59369 C...If t+tbar: loop over two top systems.
59384 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
59385 & '(PY6FRM:) not b in t decay')
59387 C...If t+tbar: find boost from original to new top frame.
59389 BETAO(J)=P(ITO,J)/P(ITO,4)
59390 BETAN(J)=P(ITN,J)/P(ITN,4)
59393 C...If t+tbar: boost copy of b by t shower and connect it in colour.
59403 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59404 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59405 K(IB,4)=MSTU(5)*ITN
59406 K(IB,5)=MSTU(5)*ITN
59407 K(ITN,4)=K(ITN,4)+IB
59408 K(ITN,5)=K(ITN,5)+IB
59409 K(ITN,1)=K(ITN,1)+10
59410 K(IBO,1)=K(IBO,1)+10
59412 C...If t+tbar: construct W recoiling against b.
59420 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
59421 IF(IABS(KCHW).EQ.3) THEN
59422 K(IW,2)=ISIGN(24,KCHW)
59424 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
59428 C...If t+tbar: construct W momentum, including boost by t shower.
59430 P(IW,J)=P(IW1,J)+P(IW2,J)
59432 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
59434 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59435 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59437 C...If t+tbar: boost b and W to top rest frame.
59439 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
59441 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59442 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59444 C...If t+tbar: let b shower and pick up modified W.
59445 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
59446 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
59447 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
59449 IF(IABS(K(I,2)).EQ.24) IWM=I
59452 C...If t+tbar: take copy of W decay products.
59461 K(IW1,1)=K(IW1,1)+10
59462 K(IW2,1)=K(IW2,1)+10
59463 K(IWM,1)=K(IWM,1)+10
59477 C...If t+tbar: boost W decay products, first by effects of t shower,
59478 C...then by those of b shower. b and its shower simple boost back.
59479 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59480 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59481 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59482 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
59483 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
59484 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
59485 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
59486 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
59487 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
59491 C...Decide on dipole pairing.
59495 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
59496 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
59500 ELSEIF(PRN.LT.P12D+P13D) THEN
59504 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
59508 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
59512 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
59522 C...Do colour joinings and parton showers
59523 C...(except ones already made for t+tbar).
59525 IF(IQL12.EQ.1) THEN
59528 CALL PYJOIN(2,IJOIN)
59530 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59531 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59532 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59533 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59536 IF(IQL34.EQ.1) THEN
59539 CALL PYJOIN(2,IJOIN)
59541 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59542 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59543 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59544 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59546 IF(IQL56.EQ.1) THEN
59549 CALL PYJOIN(2,IJOIN)
59551 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
59552 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
59553 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
59554 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
59557 C...Do fragmentation and decays. Possibly except tau decay.
59561 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59575 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59583 C*********************************************************************
59586 C...An interface from a four-parton generator to include
59587 C...parton showers and hadronization.
59589 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
59591 C...Double precision and integer declarations.
59592 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59593 IMPLICIT INTEGER(I-N)
59594 INTEGER PYK,PYCHGE,PYCOMP
59596 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59597 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59598 SAVE /PYJETS/,/PYDAT1/
59600 DIMENSION IJOIN(2),PTOT(4),BETA(3)
59602 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59608 C...Loop through entries and pick up all final partons.
59614 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59616 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
59617 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
59620 ELSEIF(I3.EQ.0) THEN
59623 CALL PYERRM(16,'(PY4JET:) more than two quarks')
59625 ELSEIF(K(I,2).LT.0) THEN
59628 ELSEIF(I4.EQ.0) THEN
59631 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
59636 ELSEIF(I4.EQ.0) THEN
59639 CALL PYERRM(16,'(PY4JET:) more than two gluons')
59645 C...Check that event is arranged according to conventions.
59646 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
59647 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
59649 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59650 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
59653 C...Check whether second pair are quarks or gluons.
59654 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59656 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
59659 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
59662 C...Boost partons to their cm frame.
59664 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
59666 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
59668 BETA(J)=PTOT(J)/PTOT(4)
59670 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59671 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59672 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59673 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59676 C...Decide and set up shower history for q qbar q' qbar' events.
59677 IF(IQG34.EQ.1) THEN
59678 W1=PY4JTW(0,I1,I3,I4)
59679 W2=PY4JTW(0,I2,I3,I4)
59680 IF(W1.GT.PYR(0)*(W1+W2)) THEN
59681 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
59683 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
59686 C...Decide and set up shower history for q qbar g g events.
59688 W1=PY4JTW(I1,I3,I2,I4)
59689 W2=PY4JTW(I1,I4,I2,I3)
59690 W3=PY4JTW(0,I3,I1,I4)
59691 W4=PY4JTW(0,I4,I1,I3)
59692 W5=PY4JTW(0,I3,I2,I4)
59693 W6=PY4JTW(0,I4,I2,I3)
59694 W7=PY4JTW(0,I1,I3,I4)
59695 W8=PY4JTW(0,I2,I3,I4)
59696 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
59698 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
59699 ELSEIF(W1+W2.GT.WR) THEN
59700 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
59701 ELSEIF(W1+W2+W3.GT.WR) THEN
59702 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
59703 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
59704 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
59705 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
59706 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
59707 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
59708 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
59709 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
59710 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
59712 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
59716 C...Boost back original partons and mark them as deleted.
59717 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
59718 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
59719 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
59720 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
59726 C...Rotate shower initiating partons to be along z axis.
59727 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
59728 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
59729 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
59730 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
59732 C...Set up copy of shower initiating partons as on mass shell.
59742 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
59753 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
59754 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
59756 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
59758 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
59761 C...Decide whether to allow or not photon radiation in showers.
59762 C...Connect up colours.
59764 IF(IRAD.EQ.0) MSTJ(41)=1
59767 CALL PYJOIN(2,IJOIN)
59769 C...Decide on maximum virtuality and do parton shower.
59770 IF(PMAX.LT.PARJ(82)) THEN
59775 CALL PYSHOW(NSAV+1,-100,PQMAX)
59777 C...Rotate and boost back system.
59778 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
59780 C...Do fragmentation and decays.
59783 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59792 C*********************************************************************
59795 C...Auxiliary to PY4JET, to evaluate weight of configuration.
59797 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
59799 C...Double precision and integer declarations.
59800 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59801 IMPLICIT INTEGER(I-N)
59802 INTEGER PYK,PYCHGE,PYCOMP
59804 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59807 C...First case: when both original partons radiate.
59808 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
59811 P(N+1,J)=P(IA1,J)+P(IA2,J)
59812 P(N+2,J)=P(IA3,J)+P(IA4,J)
59814 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59816 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59818 Z1=P(IA1,4)/P(N+1,4)
59819 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
59820 Z2=P(IA3,4)/P(N+2,4)
59821 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
59823 C...Second case: when one original parton radiates to three.
59824 C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
59827 P(N+2,J)=P(IA3,J)+P(IA4,J)
59828 P(N+1,J)=P(N+2,J)+P(IA2,J)
59830 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59832 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59834 IF(K(IA2,2).EQ.21) THEN
59835 Z1=P(N+2,4)/P(N+1,4)
59836 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
59839 Z1=P(IA2,4)/P(N+1,4)
59840 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
59843 Z2=P(IA3,4)/P(N+2,4)
59844 IF(K(IA2,2).EQ.21) THEN
59845 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
59847 ELSEIF(K(IA3,2).EQ.21) THEN
59848 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
59850 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
59860 C*********************************************************************
59863 C...Auxiliary to PY4JET, to set up chosen configuration.
59865 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
59867 C...Double precision and integer declarations.
59868 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59869 IMPLICIT INTEGER(I-N)
59870 INTEGER PYK,PYCHGE,PYCOMP
59872 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59884 C...First case: when both original partons radiate.
59885 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
59888 C...Set up flavour and history pointers for new partons.
59906 C...Set up momenta for new partons.
59908 P(N+1,J)=P(IA1,J)+P(IA2,J)
59909 P(N+2,J)=P(IA3,J)+P(IA4,J)
59915 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59917 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59919 QMAX=MIN(P(N+1,5),P(N+2,5))
59921 C...Second case: q radiates twice.
59922 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
59923 C...IA5=N+2 does not radiate.
59924 ELSEIF(K(IA2,2).EQ.21) THEN
59926 C...Set up flavour and history pointers for new partons.
59944 C...Set up momenta for new partons.
59946 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
59948 P(N+3,J)=P(IA3,J)+P(IA4,J)
59953 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59955 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
59959 C...Third case: q radiates g, g branches.
59960 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
59961 C...IA5=N+2 does not radiate.
59964 C...Set up flavour and history pointers for new partons.
59982 C...Set up momenta for new partons.
59984 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
59987 P(N+4,J)=P(IA3,J)+P(IA4,J)
59991 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59993 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
60003 C*********************************************************************
60006 C...Connects a sequence of partons with colour flow indices,
60007 C...as required for subsequent shower evolution (or other operations).
60009 SUBROUTINE PYJOIN(NJOIN,IJOIN)
60011 C...Double precision and integer declarations.
60012 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60013 IMPLICIT INTEGER(I-N)
60014 INTEGER PYK,PYCHGE,PYCOMP
60016 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60017 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60018 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60019 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
60023 C...Check that partons are of right types to be connected.
60024 IF(NJOIN.LT.2) GOTO 120
60028 IF(I.LE.0.OR.I.GT.N) GOTO 120
60029 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
60031 IF(KC.EQ.0) GOTO 120
60032 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
60033 IF(KQ.EQ.0) GOTO 120
60034 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
60035 IF(KQ.NE.2) KQSUM=KQSUM+KQ
60036 IF(IJN.EQ.1) KQS=KQ
60038 IF(KQSUM.NE.0) GOTO 120
60040 C...Connect the partons sequentially (closing for gluon loop).
60042 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
60046 IF(IJN.NE.1) IP=IJOIN(IJN-1)
60047 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
60048 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
60049 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
60050 K(I,KCS)=MSTU(5)*IN
60051 K(I,9-KCS)=MSTU(5)*IP
60052 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
60053 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
60056 C...Error exit: no action taken.
60058 120 CALL PYERRM(12,
60059 &'(PYJOIN:) given entries can not be joined by one string')
60064 C*********************************************************************
60067 C...Sets values of commonblock variables.
60069 SUBROUTINE PYGIVE(CHIN)
60071 C...Double precision and integer declarations.
60072 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60073 IMPLICIT INTEGER(I-N)
60074 INTEGER PYK,PYCHGE,PYCOMP
60076 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60077 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60078 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60079 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60080 COMMON/PYDAT4/CHAF(500,2)
60082 COMMON/PYDATR/MRPY(6),RRPY(100)
60083 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
60084 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60085 COMMON/PYINT1/MINT(400),VINT(400)
60086 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
60087 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
60088 COMMON/PYINT4/MWID(500),WIDS(500,5)
60089 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
60090 COMMON/PYINT6/PROC(0:500)
60092 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
60093 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
60095 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
60096 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
60097 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
60098 COMMON/PYPUED/IUED(0:99),RUED(0:99)
60099 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
60100 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
60101 &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/
60102 C...Local arrays and character variables.
60103 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
60104 &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10,
60106 DIMENSION MSVAR(56,8)
60108 C...For each variable to be translated give: name,
60109 C...integer/real/character, no. of indices, lower&upper index bounds.
60110 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
60111 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
60112 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
60113 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
60114 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
60115 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
60116 &'ITCM','RTCM','IUED','RUED'/
60117 DATA ((MSVAR(I,J),J=1,8),I=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0,
60118 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
60119 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60120 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
60121 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
60122 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
60123 &1,1,1,6,4*0, 2,1,1,100,4*0,
60124 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
60125 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60126 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
60127 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
60128 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
60129 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
60130 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
60131 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
60132 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
60133 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
60134 &1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
60135 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60136 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
60138 C...Length of character variable. Subdivide it into instructions.
60139 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
60140 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
60144 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
60147 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
60149 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
60154 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
60156 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
60158 C...Send off decay-mode on/off commands to PYONOF.
60161 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
60163 IF(IONOF.EQ.1) THEN
60168 C...Peel off any text following exclamation mark.
60170 DO 140 LLOW2=LHIG2,1,-1
60171 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
60173 IF(LBIT.EQ.0) RETURN
60175 C...Identify commonblock variable.
60178 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
60179 &LNAM.LE.6) GOTO 150
60180 CHNAM=CHBIT(1:LNAM-1)//' '
60181 DO 170 LCOM=1,LNAM-1
60183 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
60184 & CHALP(2)(LALP:LALP)
60189 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
60192 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
60194 IF(LLOW.LT.LTOT) GOTO 120
60198 C...Identify any indices.
60203 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
60206 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
60208 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
60209 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
60210 & IVAR.EQ.37)) THEN
60211 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
60212 READ(CHIND,'(I8)') KF
60214 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
60216 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
60219 IF(LLOW.LT.LTOT) GOTO 120
60222 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60223 READ(CHIND,'(I8)') I1
60226 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
60229 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
60232 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
60234 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60235 READ(CHIND,'(I8)') I2
60237 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
60240 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
60243 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
60245 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60246 READ(CHIND,'(I8)') I3
60251 C...Check that indices allowed.
60253 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
60254 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
60256 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
60258 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
60260 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
60262 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
60265 IF(LLOW.LT.LTOT) GOTO 120
60269 C...Save old value of variable.
60272 ELSEIF(IVAR.EQ.2) THEN
60274 ELSEIF(IVAR.EQ.3) THEN
60276 ELSEIF(IVAR.EQ.4) THEN
60278 ELSEIF(IVAR.EQ.5) THEN
60280 ELSEIF(IVAR.EQ.6) THEN
60282 ELSEIF(IVAR.EQ.7) THEN
60284 ELSEIF(IVAR.EQ.8) THEN
60286 ELSEIF(IVAR.EQ.9) THEN
60288 ELSEIF(IVAR.EQ.10) THEN
60290 ELSEIF(IVAR.EQ.11) THEN
60292 ELSEIF(IVAR.EQ.12) THEN
60294 ELSEIF(IVAR.EQ.13) THEN
60296 ELSEIF(IVAR.EQ.14) THEN
60298 ELSEIF(IVAR.EQ.15) THEN
60300 ELSEIF(IVAR.EQ.16) THEN
60302 ELSEIF(IVAR.EQ.17) THEN
60303 CHOLD=CHAF(I1,I2)(1:8)
60304 ELSEIF(IVAR.EQ.18) THEN
60306 ELSEIF(IVAR.EQ.19) THEN
60308 ELSEIF(IVAR.EQ.20) THEN
60310 ELSEIF(IVAR.EQ.21) THEN
60312 ELSEIF(IVAR.EQ.22) THEN
60314 ELSEIF(IVAR.EQ.23) THEN
60316 ELSEIF(IVAR.EQ.24) THEN
60318 ELSEIF(IVAR.EQ.25) THEN
60320 ELSEIF(IVAR.EQ.26) THEN
60322 ELSEIF(IVAR.EQ.27) THEN
60324 ELSEIF(IVAR.EQ.28) THEN
60326 ELSEIF(IVAR.EQ.29) THEN
60328 ELSEIF(IVAR.EQ.30) THEN
60330 ELSEIF(IVAR.EQ.31) THEN
60332 ELSEIF(IVAR.EQ.32) THEN
60334 ELSEIF(IVAR.EQ.33) THEN
60335 IOLD=ICOL(I1,I2,I3)
60336 ELSEIF(IVAR.EQ.34) THEN
60338 ELSEIF(IVAR.EQ.35) THEN
60340 ELSEIF(IVAR.EQ.36) THEN
60342 ELSEIF(IVAR.EQ.37) THEN
60344 ELSEIF(IVAR.EQ.38) THEN
60346 ELSEIF(IVAR.EQ.39) THEN
60348 ELSEIF(IVAR.EQ.40) THEN
60350 ELSEIF(IVAR.EQ.41) THEN
60352 ELSEIF(IVAR.EQ.42) THEN
60353 ROLD=SIGT(I1,I2,I3)
60354 ELSEIF(IVAR.EQ.43) THEN
60356 ELSEIF(IVAR.EQ.44) THEN
60358 ELSEIF(IVAR.EQ.45) THEN
60360 ELSEIF(IVAR.EQ.46) THEN
60362 ELSEIF(IVAR.EQ.47) THEN
60364 ELSEIF(IVAR.EQ.48) THEN
60366 ELSEIF(IVAR.EQ.49) THEN
60368 ELSEIF(IVAR.EQ.50) THEN
60369 ROLD=RVLAM(I1,I2,I3)
60370 ELSEIF(IVAR.EQ.51) THEN
60371 ROLD=RVLAMP(I1,I2,I3)
60372 ELSEIF(IVAR.EQ.52) THEN
60373 ROLD=RVLAMB(I1,I2,I3)
60374 ELSEIF(IVAR.EQ.53) THEN
60376 ELSEIF(IVAR.EQ.54) THEN
60378 ELSEIF(IVAR.EQ.55) THEN
60380 ELSEIF(IVAR.EQ.56) THEN
60384 C...Print current value of variable. Loop back.
60385 IF(LNAM.GE.LBIT) THEN
60387 CHBIT(15:60)=' has the value '
60388 IF(MSVAR(IVAR,1).EQ.1) THEN
60389 WRITE(CHBIT(51:60),'(I10)') IOLD
60390 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60391 WRITE(CHBIT(47:60),'(F14.5)') ROLD
60392 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60397 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60399 IF(LLOW.LT.LTOT) GOTO 120
60403 C...Read in new variable value.
60404 IF(MSVAR(IVAR,1).EQ.1) THEN
60406 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
60407 READ(CHINI,'(I10)') INEW
60408 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60410 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
60412 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60413 CHNEW=CHBIT(LNAM+1:LBIT)//' '
60415 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
60418 C...Store new variable value.
60421 ELSEIF(IVAR.EQ.2) THEN
60423 ELSEIF(IVAR.EQ.3) THEN
60425 ELSEIF(IVAR.EQ.4) THEN
60427 ELSEIF(IVAR.EQ.5) THEN
60429 ELSEIF(IVAR.EQ.6) THEN
60431 ELSEIF(IVAR.EQ.7) THEN
60433 ELSEIF(IVAR.EQ.8) THEN
60435 ELSEIF(IVAR.EQ.9) THEN
60437 ELSEIF(IVAR.EQ.10) THEN
60439 ELSEIF(IVAR.EQ.11) THEN
60441 ELSEIF(IVAR.EQ.12) THEN
60443 ELSEIF(IVAR.EQ.13) THEN
60445 ELSEIF(IVAR.EQ.14) THEN
60447 ELSEIF(IVAR.EQ.15) THEN
60449 ELSEIF(IVAR.EQ.16) THEN
60451 ELSEIF(IVAR.EQ.17) THEN
60453 ELSEIF(IVAR.EQ.18) THEN
60455 ELSEIF(IVAR.EQ.19) THEN
60457 ELSEIF(IVAR.EQ.20) THEN
60459 ELSEIF(IVAR.EQ.21) THEN
60461 ELSEIF(IVAR.EQ.22) THEN
60463 ELSEIF(IVAR.EQ.23) THEN
60465 ELSEIF(IVAR.EQ.24) THEN
60467 ELSEIF(IVAR.EQ.25) THEN
60469 ELSEIF(IVAR.EQ.26) THEN
60471 ELSEIF(IVAR.EQ.27) THEN
60473 ELSEIF(IVAR.EQ.28) THEN
60475 ELSEIF(IVAR.EQ.29) THEN
60477 ELSEIF(IVAR.EQ.30) THEN
60479 ELSEIF(IVAR.EQ.31) THEN
60481 ELSEIF(IVAR.EQ.32) THEN
60483 ELSEIF(IVAR.EQ.33) THEN
60484 ICOL(I1,I2,I3)=INEW
60485 ELSEIF(IVAR.EQ.34) THEN
60487 ELSEIF(IVAR.EQ.35) THEN
60489 ELSEIF(IVAR.EQ.36) THEN
60491 ELSEIF(IVAR.EQ.37) THEN
60493 ELSEIF(IVAR.EQ.38) THEN
60495 ELSEIF(IVAR.EQ.39) THEN
60497 ELSEIF(IVAR.EQ.40) THEN
60499 ELSEIF(IVAR.EQ.41) THEN
60501 ELSEIF(IVAR.EQ.42) THEN
60502 SIGT(I1,I2,I3)=RNEW
60503 ELSEIF(IVAR.EQ.43) THEN
60505 ELSEIF(IVAR.EQ.44) THEN
60507 ELSEIF(IVAR.EQ.45) THEN
60509 ELSEIF(IVAR.EQ.46) THEN
60511 ELSEIF(IVAR.EQ.47) THEN
60513 ELSEIF(IVAR.EQ.48) THEN
60515 ELSEIF(IVAR.EQ.49) THEN
60517 ELSEIF(IVAR.EQ.50) THEN
60518 RVLAM(I1,I2,I3)=RNEW
60519 ELSEIF(IVAR.EQ.51) THEN
60520 RVLAMP(I1,I2,I3)=RNEW
60521 ELSEIF(IVAR.EQ.52) THEN
60522 RVLAMB(I1,I2,I3)=RNEW
60523 ELSEIF(IVAR.EQ.53) THEN
60525 ELSEIF(IVAR.EQ.54) THEN
60527 ELSEIF(IVAR.EQ.55) THEN
60529 ELSEIF(IVAR.EQ.56) THEN
60533 C...Write old and new value. Loop back.
60535 CHBIT(15:60)=' changed from to '
60536 IF(MSVAR(IVAR,1).EQ.1) THEN
60537 WRITE(CHBIT(33:42),'(I10)') IOLD
60538 WRITE(CHBIT(51:60),'(I10)') INEW
60539 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60540 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60541 WRITE(CHBIT(29:42),'(F14.5)') ROLD
60542 WRITE(CHBIT(47:60),'(F14.5)') RNEW
60543 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60544 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60547 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60549 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
60550 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
60553 IF(LLOW.LT.LTOT) GOTO 120
60555 C...Format statement for output on unit MSTU(11) (by default 6).
60556 5000 FORMAT(5X,A60)
60557 5100 FORMAT(5X,A88)
60562 C*********************************************************************
60565 C...Switches on and off decay channel by search for match.
60567 SUBROUTINE PYONOF(CHIN)
60569 C...Double precision and integer declarations.
60570 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60571 IMPLICIT INTEGER(I-N)
60572 INTEGER PYK,PYCHGE,PYCOMP
60574 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60575 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60576 SAVE /PYDAT1/,/PYDAT3/
60577 C...Local arrays and character variables.
60578 INTEGER KFCMP(10),KFTMP(10)
60579 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
60581 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60582 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
60584 C...Determine length of character variable.
60588 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
60591 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
60593 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
60595 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
60597 C...Find colon separator and particle code.
60599 120 LCOLON=LCOLON+1
60600 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
60602 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
60603 READ(CHCODE,'(I8)',ERR=300) KF
60606 C...Done if unknown code or no decay channels.
60608 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
60613 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
60614 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
60618 C...Find command name up to blank or equal sign.
60621 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
60622 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
60624 LMODE=LSEP-LCOLON-1
60625 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
60627 C...Convert to uppercase.
60628 DO 150 LCOM=1,LMODE
60630 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
60631 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
60635 C...Identify command. Failed if not identified.
60637 IF(CHMODE.EQ.'ALLOFF') MODE=1
60638 IF(CHMODE.EQ.'ALLON') MODE=2
60639 IF(CHMODE.EQ.'OFFIFANY') MODE=3
60640 IF(CHMODE.EQ.'ONIFANY') MODE=4
60641 IF(CHMODE.EQ.'OFFIFALL') MODE=5
60642 IF(CHMODE.EQ.'ONIFALL') MODE=6
60643 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
60644 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
60646 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
60650 C...Simple cases when all on or all off.
60651 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
60652 WRITE(MSTU(11),1000) KF,CHMODE
60653 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
60654 IF(MDME(IDC,1).LT.0) GOTO 160
60660 C...Identify matching list.
60664 IF(LBEG.GT.LEN) GOTO 190
60665 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
60666 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
60669 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
60670 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
60671 IF(LEND.LT.LEN) LEND=LEND-1
60673 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
60674 READ(CHCODE,'(I8)',ERR=300) KFREAD
60676 KFCMP(NCMP)=IABS(KFREAD)
60678 IF(NCMP.LT.10) GOTO 170
60680 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
60682 C...Only one matching required.
60683 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
60684 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
60685 IF(MDME(IDC,1).LT.0) GOTO 220
60687 KFNOW=IABS(KFDP(IDC,IKF))
60688 IF(KFNOW.EQ.0) GOTO 210
60690 IF(KFCMP(ICMP).EQ.KFNOW) THEN
60700 C...Multiple matchings required.
60701 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
60702 IF(MDME(IDC,1).LT.0) GOTO 260
60705 KFTMP(ITMP)=KFCMP(ITMP)
60709 KFNOW=IABS(KFDP(IDC,IKF))
60710 IF(KFNOW.EQ.0) GOTO 250
60713 IF(KFTMP(ITMP).EQ.KFNOW) THEN
60714 KFTMP(ITMP)=KFTMP(NTMP)
60720 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
60721 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
60722 & MDME(IDC,1)=MODE-7
60726 C...Error exit for impossible read of particle code.
60727 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
60730 C...Formats for output.
60731 1000 FORMAT(' Decays for',I8,' set ',A10)
60732 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
60736 C*********************************************************************
60739 C...Presets for a few specific underlying-event and min-bias tunes
60740 C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
60741 C...others require particular versions of pythia (e.g. the SCI and GAL
60742 C...models). See below for details.
60743 SUBROUTINE PYTUNE(ITUNE)
60745 C ITUNE NAME (detailed descriptions below)
60746 C 0 Default : No settings changed => defaults.
60748 C ====== Old UE, Q2-ordered showers ====================================
60749 C 100 A : Rick Field's CDF Tune A (Oct 2002)
60750 C 101 AW : Rick Field's CDF Tune AW (Apr 2006)
60751 C 102 BW : Rick Field's CDF Tune BW (Apr 2006)
60752 C 103 DW : Rick Field's CDF Tune DW (Apr 2006)
60753 C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006)
60754 C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?)
60755 C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?)
60756 C 107 ACR : Tune A modified with new CR model (Mar 2007)
60757 C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?)
60758 C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?)
60759 C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
60760 C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008)
60761 C 111 AW-Pro : Tune AW, -"- (Oct 2008)
60762 C 112 BW-Pro : Tune BW, -"- (Oct 2008)
60763 C 113 DW-Pro : Tune DW, -"- (Oct 2008)
60764 C 114 DWT-Pro : Tune DWT, -"- (Oct 2008)
60765 C 115 QW-Pro : Tune QW, -"- (Oct 2008)
60766 C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008)
60767 C 117 ACR-Pro : Tune ACR, -"- (Oct 2008)
60768 C 118 D6-Pro : Tune D6, -"- (Oct 2008)
60769 C 119 D6T-Pro : Tune D6T, -"- (Oct 2008)
60770 C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
60771 C 129 Pro-Q20 : Professor Q2-ordered tune (Feb 2009)
60773 C ====== Intermediate and Hybrid Models ================================
60774 C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
60775 C 201 APT : Tune A w. pT-ordered FSR (Mar 2007)
60776 C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008)
60777 C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009)
60778 C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
60780 C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
60781 C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006)
60782 C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006)
60783 C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006)
60784 C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006)
60785 C 304 NOCR : New UE "best try" without col. rec. (Apr 2006)
60786 C 305 Old : New UE, original (primitive) col. rec. (Aug 2004)
60787 C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
60788 C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
60789 C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008)
60790 C 311 S1-Pro : S1 -"- (Oct 2008)
60791 C 312 S2-Pro : S2 -"- (Oct 2008)
60792 C 313 S0A-Pro : S0A -"- (Oct 2008)
60793 C 314 NOCR-Pro : NOCR -"- (Oct 2008)
60794 C 315 Old-Pro : Old -"- (Oct 2008)
60795 C ---- Peter's Perugia Tunes : 320+ ------------------------------------
60796 C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009)
60797 C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
60798 C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
60799 C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
60800 C balance & different scaling to LHC & RHIC (Feb 2009)
60801 C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009)
60802 C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
60803 C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
60804 C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
60805 C 329 Pro-pT0 : Professor pT-ordered tune w. S0 CR model (Feb 2009)
60807 C ======= The Uppsala models ===========================================
60808 C ( NB! must be run with special modified Pythia 6.215 version )
60809 C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
60810 C 400 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
60811 C 401 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
60812 C 402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006)
60813 C 403 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
60817 C Quick Dictionary:
60818 C BE : Bose-Einstein
60819 C BR : Beam Remnants
60820 C CR : Colour Reconnections
60821 C HAD: Hadronization
60822 C ISR/FSR: Initial-State Radiation / Final-State Radiation
60823 C FSI: Final-State Interactions (=CR+BE)
60824 C MB : Minimum-bias
60825 C MI : Multiple Interactions
60826 C UE : Underlying Event
60828 C=======================================================================
60829 C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
60830 C=======================================================================
60832 C A (100) and AW (101). CTEQ5L parton distributions
60833 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60834 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60835 C...Key feature: extensively compared to CDF data (R.D. Field).
60836 C...* Large starting scale for ISR (PARP(67)=4)
60837 C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
60838 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60840 C BW (102). CTEQ5L parton distributions
60841 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60842 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60843 C...Key feature: extensively compared to CDF data (R.D. Field).
60844 C...NB: Can also be run with Pythia 6.2 or 6.312+
60845 C...* Small starting scale for ISR (PARP(67)=1)
60846 C...* BW has more radiation due to smaller mu_R choice in alpha_s.
60847 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60849 C DW (103) and DWT (104). CTEQ5L parton distributions
60850 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60851 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60852 C...Key feature: extensively compared to CDF data (R.D. Field).
60853 C...NB: Can also be run with Pythia 6.2 or 6.312+
60854 C...* Intermediate starting scale for ISR (PARP(67)=2.5)
60855 C...* DWT has a different reference energy, the same as the "S" models
60856 C... below, leading to more UE activity at the LHC, but less at RHIC.
60857 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60859 C QW (105). CTEQ61 parton distributions
60860 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60861 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60862 C...Key feature: uses CTEQ61 (external pdf library must be linked)
60864 C ATLAS-DC2 (106). CTEQ5L parton distributions
60865 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60866 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60867 C...Key feature: tune used by the ATLAS collaboration.
60869 C ACR (107). CTEQ5L parton distributions
60870 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
60871 C...Key feature: Tune A modified to use annealing CR.
60872 C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
60874 C D6 (108) and D6T (109). CTEQ6L parton distributions
60875 C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
60877 C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
60878 C Old UE model, Q2-ordered showers.
60879 C...Key feature: Rick Field's family of tunes revamped with the
60880 C...Professor Q2-ordered final-state shower and fragmentation tunes
60881 C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
60882 C...Key feature: improved descriptions of LEP data.
60884 C Pro-Q20 (129). CTEQ5L parton distributions
60885 C Old UE model, Q2-ordered showers.
60886 C...Key feature: Complete retune of old model by Professor, including
60887 C...large amounts of both LEP and Tevatron data.
60888 C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
60889 C...extreme in this tune, corresponding to using mu_R = pT/3 .
60891 C=======================================================================
60892 C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
60893 C=======================================================================
60895 C IM1 (200). Intermediate model, Q2-ordered showers,
60896 C CTEQ5L parton distributions
60897 C...Key feature: new UE model w Q2-ordered showers and no interleaving.
60898 C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
60899 C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
60901 C APT (201). Old UE model, pT-ordered final-state showers,
60902 C CTEQ5L parton distributions
60903 C...Key feature: Rick Field's Tune A, but with new final-state showers
60905 C APT-Pro (211). Old UE model, pT-ordered final-state showers,
60906 C CTEQ5L parton distributions
60907 C...Key feature: APT revamped with the Professor pT-ordered final-state
60908 C...shower and fragmentation tunes presented by Hendrik Hoeth at the
60909 C...Perugia MPI workshop in October 2008.
60911 C Perugia-APT (221). Old UE model, pT-ordered final-state showers,
60912 C CTEQ5L parton distributions
60913 C...Key feature: APT-Pro with final-state showers off the MPI,
60914 C...lower ISR renormalization scale to improve agreement with the
60915 C...Tevatron Drell-Yan pT measurements and with improved energy scaling
60916 C...to min-bias at 630 GeV.
60918 C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
60919 C CTEQ6L1 parton distributions.
60920 C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
60921 C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
60922 C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
60924 C=======================================================================
60925 C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
60926 C=======================================================================
60928 C S0 (300) and S0A (303). CTEQ5L parton distributions
60929 C...Key feature: large amount of multiple interactions
60930 C...* Somewhat faster than the other colour annealing scenarios.
60931 C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
60932 C... from Tune A, leading to less UE at the LHC, but more at RHIC.
60933 C...* Small amount of radiation.
60934 C...* Large amount of low-pT MI
60935 C...* Low degree of proton lumpiness (broad matter dist.)
60936 C...* CR Type S (driven by free triplets), of medium strength.
60937 C...* See: Pythia6402 update notes or later.
60939 C S1 (301). CTEQ5L parton distributions
60940 C...Key feature: large amount of radiation.
60941 C...* Large amount of low-pT perturbative ISR
60942 C...* Large amount of FSR off ISR partons
60943 C...* Small amount of low-pT multiple interactions
60944 C...* Moderate degree of proton lumpiness
60945 C...* Least aggressive CR type (S+S Type I), but with large strength
60946 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60948 C S2 (302). CTEQ5L parton distributions
60949 C...Key feature: very lumpy proton + gg string cluster formation allowed
60950 C...* Small amount of radiation
60951 C...* Moderate amount of low-pT MI
60952 C...* High degree of proton lumpiness (more spiky matter distribution)
60953 C...* Most aggressive CR type (S+S Type II), but with small strength
60954 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60956 C NOCR (304). CTEQ5L parton distributions
60957 C...Key feature: no colour reconnections (NB: "Best fit" only).
60958 C...* NB: <pT>(Nch) problematic in this tune.
60959 C...* Small amount of radiation
60960 C...* Small amount of low-pT MI
60961 C...* Low degree of proton lumpiness
60962 C...* Large BR composite x enhancement factor
60963 C...* Most clever colour flow without CR ("Lambda ordering")
60965 C ATLAS-CSC (306). CTEQ6L parton distributions
60966 C...Key feature: 11-parameter ATLAS tune of the new framework.
60967 C...* Old (pre-annealing) colour reconnections a la 305.
60968 C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
60970 C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
60971 C...Key feature: the S0 family of tunes revamped with the Professor
60972 C...pT-ordered final-state shower and fragmentation tunes presented by
60973 C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
60974 C...Key feature: improved descriptions of LEP data.
60976 C Perugia-0 (320). CTEQ5L parton distributions.
60977 C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
60978 C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
60979 C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
60980 C...beam-remnant breakup (more baryon number transport), and suppression
60981 C...of CR in high-pT string pieces.
60983 C Perugia-HARD (321). CTEQ5L parton distributions.
60984 C...Key feature: More ISR, More FSR, Less MPI, Less BR
60985 C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
60986 C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
60987 C...baryon number transport), and more fragmentation pT.
60988 C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
60989 C...DY pT spectrum is HARD.
60991 C Perugia-SOFT (322). CTEQ5L parton distributions.
60992 C...Key feature: Less ISR, Less FSR, More MPI, More BR
60993 C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
60994 C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
60995 C...number transport), and less fragmentation pT.
60996 C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
60997 C...DY pT spectrum is SOFT
60999 C Perugia-3 (323). CTEQ5L parton distributions.
61000 C...Key feature: variant of Perugia-0 with more extreme energy scaling
61001 C...properties while still agreeing with Tevatron data from 630 to 1960.
61002 C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
61003 C...allows FSR off the active end of dipoles stretched to the remnant.
61005 C Perugia-NOCR (324). CTEQ5L parton distributions.
61006 C...Key feature: Retune of NOCR-Pro with better scaling properties to
61007 C...lower energies and somewhat better agreement with Tevatron data
61010 C Perugia-* (325). MRST LO* parton distributions for generators
61011 C...Key feature: first attempt at using the LO* distributions
61012 C...(external pdf library must be linked).
61014 C Perugia-6 (326). CTEQ6L1 parton distributions
61015 C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
61017 C Pro-pT0 (329). CTEQ5L parton distributions
61018 C...Key feature: Complete retune of new model by Professor, including
61019 C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
61021 C=======================================================================
61023 C=======================================================================
61025 C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
61026 C...with an unmodified Pythia distribution.
61027 C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
61029 C ::: + Future improvements?
61030 C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
61031 C (problem: K-factor affects everything so only works as
61032 C intended for min-bias, not for UE ... probably need a
61033 C better long-term solution to handle UE as well. Anyway,
61034 C Mark uses MSTP(33) and PARP(31)-PARP(33).)
61036 C...Global statements
61037 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61038 INTEGER PYK,PYCHGE,PYCOMP
61041 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61042 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
61044 C...SCI and GAL Commonblocks
61045 COMMON /SCIPAR/MSWI(2),PARSCI(2)
61047 C...SAVE statements
61048 SAVE /PYDAT1/,/PYPARS/
61051 C...Internal parameters
61052 PARAMETER(MXTUNS=500)
61053 CHARACTER*8 CHVERS, CHDOC
61054 PARAMETER (CHVERS='1.015 ',CHDOC='Jan 2009')
61055 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
61056 CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
61057 & CHPARJ(1:100), CH40
61060 DATA (CHNAMS(I),I=0,1)/'Default',' '/
61061 DATA (CHNAMS(I),I=100,119)/
61062 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
61063 & 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
61064 1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
61065 1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
61066 1 'Tune D6-Pro','Tune D6T-Pro'/
61067 DATA (CHNAMS(I),I=120,129)/
61069 DATA (CHNAMS(I),I=300,309)/
61070 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
61071 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
61072 DATA (CHNAMS(I),I=310,315)/
61073 & 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
61074 & 'NOCR-Pro','Old-Pro'/
61075 DATA (CHNAMS(I),I=320,329)/
61076 & 'Perugia 0','Perugia HARD','Perugia SOFT',
61077 & 'Perugia 3','Perugia NOCR','Perugia LO*',
61078 & 'Perugia 6',2*' ','Pro-pT0'/
61079 DATA (CHNAMS(I),I=200,229)/
61080 & 'IM Tune 1','Tune APT',8*' ',
61081 & ' ','Tune APT-Pro',8*' ',
61082 & ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
61083 DATA (CHNAMS(I),I=400,409)/
61084 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
61085 DATA (CHMSTJ(I),I=11,20)/
61086 & 'HAD choice of fragmentation function(s)',4*' ',
61087 & 'HAD treatment of small-mass systems',4*' '/
61088 DATA (CHMSTJ(I),I=41,50)/
61089 & 'FSR type (Q2 or pT) for old framework',9*' '/
61090 DATA (CHMSTP(I),I=51,100)/
61091 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
61092 6 'ISR master switch',2*' ','ISR alphaS type',2*' ',
61093 6 'ISR coherence option for 1st emission',
61094 6 'ISR phase space choice & ME corrections',' ',
61095 7 'ISR IR regularization scheme',' ',
61096 7 'ISR scheme for FSR off ISR',8*' ',
61098 8 'UE hadron transverse mass distribution',5*' ',
61099 8 'BR composite scheme','BR colour scheme',
61100 9 'BR primordial kT compensation',
61101 9 'BR primordial kT distribution',
61102 9 'BR energy partitioning scheme',2*' ',
61103 9 'FSI colour (re-)connection model',5*' '/
61104 DATA (CHPARP(I),I=61,100)/
61105 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
61106 6 2*' ','ISR Q2max factor',3*' ',
61107 7 'FSR Q2max factor for non-s-channel procs',5*' ',
61108 7 'FSI colour reco high-pT dampening strength',
61109 7 'FSI colour reconnection strength',
61110 7 'BR composite x enhancement','BR breakup suppression',
61111 8 2*'UE IR cutoff at reference ecm',
61112 8 2*'UE mass distribution parameter',
61113 8 'UE gg colour correlated fraction','UE total gg fraction',
61115 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
61116 9 'BR primordial kT width <|kT|>',' ',
61117 9 'BR primordial kT UV cutoff',7*' '/
61118 DATA (CHPARJ(I),I=1,30)/
61119 & 'HAD diquark suppression','HAD strangeness suppression',
61120 & 'HAD strange diquark suppression',
61121 & 'HAD vector diquark suppression',6*' ',
61122 1 'HAD P(vector meson), u and d only',
61123 1 'HAD P(vector meson), contains s',
61124 1 'HAD P(vector meson), heavy quarks',7*' ',
61125 2 'HAD fragmentation pT',' ',' ',' ',
61126 2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
61127 DATA (CHPARJ(I),I=41,90)/
61128 4 'HAD string parameter a','HAD string parameter b',3*' ',
61129 4 'HAD Lund(=0)-Bowler(=1) rQ (rc)',
61130 4 'HAD Lund(=0)-Bowler(=1) rb',3*' ',
61131 5 3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
61133 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
61135 C...1) Shorthand notation
61138 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
61139 CHNAME=CHNAMS(ITUNE)
61140 IF (ITUNE.EQ.0) GOTO 9999
61142 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
61147 IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
61149 C...3) Tune parameters
61151 C=======================================================================
61152 C...S0, S1, S2, S0A, NOCR, Rap,
61153 C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
61154 C...Perugia 0, HARD, SOFT, Perugia 3, Perugia LO*, Perugia 6
61156 IF ((ITUNE.GE.300.AND.ITUNE.LE.305)
61157 & .OR.(ITUNE.GE.310.AND.ITUNE.LE.315)
61158 & .OR.(ITUNE.GE.320.AND.ITUNE.LE.326).OR.ITUNE.EQ.329) THEN
61159 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
61160 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
61161 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61163 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326.AND.ITUNE.NE.324.AND.
61164 & (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419)))
61166 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61170 C...Use Professor's LEP pars if ITUNE >= 310
61171 C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
61172 IF (ITUNE.LT.310) THEN
61175 C...# Old default flavour parameters
61182 ELSEIF (ITUNE.GE.310) THEN
61183 C...# Tuned flavour parameters:
61193 C...# Always use pT-ordered shower:
61195 C...# Switch on Bowler:
61197 C...# Fragmentation
61206 C...Remove middle digit now for Professor variants, since identical pars
61208 IF (ITUNE.GE.310.AND.ITUNE.LE.319) THEN
61209 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
61212 C...PDFs: all use CTEQ5L as starting point
61215 IF (ITUNE.EQ.325) THEN
61216 C...MRST LO* for 325
61219 ELSEIF (ITUNE.EQ.326) THEN
61220 C...CTEQ6L1 for 326
61225 C...ISR: use Lambda_MSbar with default scale for S0(A)
61228 IF (ITUNE.EQ.320.OR.ITUNE.EQ.323.OR.ITUNE.EQ.324.OR.
61229 & ITUNE.EQ.326) THEN
61230 C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
61233 ELSEIF (ITUNE.EQ.321) THEN
61234 C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
61237 ELSEIF (ITUNE.EQ.322) THEN
61238 C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
61241 ELSEIF (ITUNE.EQ.325) THEN
61242 C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
61245 ELSEIF (ITUNE.EQ.329) THEN
61246 C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
61251 C...ISR : power-suppressed power showers above s_color (since 6.4.19)
61254 C...Perugia tunes have stronger suppression, except HARD
61255 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61257 IF (ITUNE.EQ.321) PARP(67)=4D0
61258 IF (ITUNE.EQ.322) PARP(67)=0.5D0
61261 C...ISR IR cutoff type and FSR off ISR setting:
61262 C...Smooth ISR, low FSR-off-ISR
61265 IF (ITUNEB.EQ.301) THEN
61266 C...S1, S1-Pro: sharp ISR, high FSR
61269 ELSEIF (ITUNE.EQ.320.OR.ITUNE.EQ.324.OR.ITUNE.EQ.326
61270 & .OR.ITUNE.EQ.325) THEN
61271 C...Perugia default is smooth ISR, high FSR-off-ISR
61274 ELSEIF (ITUNE.EQ.321) THEN
61275 C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
61279 ELSEIF (ITUNE.EQ.322) THEN
61280 C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
61284 ELSEIF (ITUNE.EQ.323) THEN
61285 C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
61291 C...FSR activity: Perugia tunes use a lower PARP(71) as indicated
61292 C...by Professor tunes (with HARD and SOFT variations)
61294 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61296 IF (ITUNE.EQ.321) PARP(71)=4D0
61297 IF (ITUNE.EQ.322) PARP(71)=1D0
61299 IF (ITUNE.EQ.329) PARP(71)=2D0
61301 C...FSR: Lambda_FSR scale (only if not using professor)
61302 IF (ITUNE.LT.310) PARJ(81)=0.23D0
61303 IF (ITUNE.EQ.321) PARJ(81)=0.30D0
61304 IF (ITUNE.EQ.322) PARJ(81)=0.20D0
61306 C...UE on, new model
61309 C...UE: hadron-hadron overlap profile (expOfPow for all)
61311 C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
61313 IF (ITUNEB.EQ.301) PARP(83)=1.4D0
61314 IF (ITUNEB.EQ.302) PARP(83)=1.2D0
61315 C...NOCR variants have very smooth distributions
61316 IF (ITUNEB.EQ.304) PARP(83)=1.8D0
61317 IF (ITUNEB.EQ.305) PARP(83)=2.0D0
61318 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61319 C...Perugia variants have slightly smoother profiles by default
61320 C...(to compensate for more tail by added radiation)
61321 C...Perugia-SOFT has more peaked distribution, NOCR less peaked
61323 IF (ITUNE.EQ.322) PARP(83)=1.5D0
61324 IF (ITUNE.EQ.324) PARP(83)=1.8D0
61326 C...Professor-pT0 also has very smooth distribution
61327 IF (ITUNE.EQ.329) PARP(83)=1.8
61329 C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
61331 IF (ITUNEB.EQ.301) PARP(82)=2.1D0
61332 IF (ITUNEB.EQ.302) PARP(82)=1.9D0
61333 IF (ITUNEB.EQ.304) PARP(82)=2.05D0
61334 IF (ITUNEB.EQ.305) PARP(82)=1.9D0
61335 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61336 C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
61337 C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
61338 C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
61339 C...slightly higher, due to increased activity.
61341 IF (ITUNE.EQ.321) PARP(82)=2.3D0
61342 IF (ITUNE.EQ.322) PARP(82)=1.9D0
61343 IF (ITUNE.EQ.323) PARP(82)=2.2D0
61344 IF (ITUNE.EQ.324) PARP(82)=1.95D0
61345 IF (ITUNE.EQ.325) PARP(82)=2.2D0
61346 IF (ITUNE.EQ.326) PARP(82)=1.95D0
61348 C...Professor-pT0 maintains low pT0 vaue
61349 IF (ITUNE.EQ.329) PARP(82)=1.85D0
61351 C...UE: IR cutoff reference energy and default energy scaling pace
61354 C...S0A, S0A-Pro have tune A energy scaling
61355 IF (ITUNEB.EQ.303) PARP(90)=0.25D0
61356 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61357 C...Perugia tunes explicitly include MB at 630 to fix energy scaling
61359 IF (ITUNE.EQ.321) PARP(90)=0.30D0
61360 IF (ITUNE.EQ.322) PARP(90)=0.24D0
61361 IF (ITUNE.EQ.323) PARP(90)=0.32D0
61362 IF (ITUNE.EQ.324) PARP(90)=0.24D0
61363 C...LO* and CTEQ6L1 tunes have slower energy scaling
61364 IF (ITUNE.EQ.325) PARP(90)=0.23D0
61365 IF (ITUNE.EQ.326) PARP(90)=0.22D0
61367 C...Professor-pT0 has intermediate scaling
61368 IF (ITUNE.EQ.329) PARP(90)=0.22D0
61370 C...BR: MPI initiator color connections rap-ordered by default
61371 C...NOCR variants are Lambda-ordered, Perugia SOFT is random-ordered
61373 IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89)=2
61374 IF (ITUNE.EQ.322) MSTP(89)=0
61376 C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
61378 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61379 C...Perugia tunes have more beam blowup by default
61381 IF (ITUNE.EQ.321) PARP(80)=0.01
61382 IF (ITUNE.EQ.323) PARP(80)=0.03
61383 IF (ITUNE.EQ.324) PARP(80)=0.01
61386 C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
61389 IF (ITUNEB.EQ.304) PARP(79)=3D0
61390 IF (ITUNE.EQ.329) PARP(79)=1.18
61392 C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
61396 C...Perugia-HARD only uses 1.0 GeV
61397 IF (ITUNE.EQ.321) PARP(91)=1.0D0
61398 C...Perugia-3 only uses 1.5 GeV
61399 IF (ITUNE.EQ.323) PARP(91)=1.5D0
61400 C...Professor-pT0 uses 7-GeV cutoff
61401 IF (ITUNE.EQ.329) PARP(93)=7.0
61403 C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
61405 C...S1, S1-Pro: use S1
61406 IF (ITUNEB.EQ.301) MSTP(95)=2
61407 C...S2, S2-Pro: use S2
61408 IF (ITUNEB.EQ.302) MSTP(95)=4
61409 C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
61410 IF (ITUNE.EQ.304.OR.ITUNE.EQ.314.OR.ITUNE.EQ.324) MSTP(95)=0
61411 C..."Old" and "Old"-Pro: use old CR
61412 IF (ITUNEB.EQ.305) MSTP(95)=1
61414 C...FSI: CR strength and high-pT dampening, default is S0
61415 IF (ITUNE.LT.320.OR.ITUNE.EQ.329) THEN
61418 IF (ITUNEB.EQ.301) PARP(78)=0.35D0
61419 IF (ITUNEB.EQ.302) PARP(78)=0.15D0
61420 IF (ITUNEB.EQ.304) PARP(78)=0.0D0
61421 IF (ITUNEB.EQ.305) PARP(78)=1.0D0
61422 IF (ITUNE.EQ.329) PARP(78)=0.17D0
61424 C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
61427 IF (ITUNE.EQ.321) THEN
61428 C...HARD has HIGH amount of CR
61431 ELSEIF (ITUNE.EQ.322) THEN
61432 C...SOFT has LOW amount of CR
61435 ELSEIF (ITUNE.EQ.323) THEN
61436 C...Scaling variant appears to need slightly more than default
61439 ELSEIF (ITUNE.EQ.324) THEN
61446 C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
61447 IF (ITUNE.EQ.321) PARJ(21)=0.34D0
61448 IF (ITUNE.EQ.322) PARJ(21)=0.28D0
61450 C...Switch off trial joinings
61453 C...S0 (300), S0A (303)
61454 IF (ITUNEB.EQ.300.OR.ITUNEB.EQ.303) THEN
61456 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
61457 WRITE(M11,5030) CH60
61458 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
61459 WRITE(M11,5030) CH60
61460 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61461 WRITE(M11,5030) CH60
61462 IF (ITUNE.GE.310) THEN
61463 CH60='LEP parameters tuned by Professor'
61464 WRITE(M11,5030) CH60
61469 ELSEIF(ITUNEB.EQ.301) THEN
61471 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61472 WRITE(M11,5030) CH60
61473 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61474 WRITE(M11,5030) CH60
61475 IF (ITUNE.GE.310) THEN
61476 CH60='LEP parameters tuned with Professor'
61477 WRITE(M11,5030) CH60
61482 ELSEIF(ITUNEB.EQ.302) THEN
61484 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61485 WRITE(M11,5030) CH60
61486 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61487 WRITE(M11,5030) CH60
61488 IF (ITUNE.GE.310) THEN
61489 CH60='LEP parameters tuned by Professor'
61490 WRITE(M11,5030) CH60
61495 ELSEIF(ITUNEB.EQ.304) THEN
61497 CH60='"best try" without colour reconnections'
61498 WRITE(M11,5030) CH60
61499 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
61500 WRITE(M11,5030) CH60
61501 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61502 WRITE(M11,5030) CH60
61503 IF (ITUNE.GE.310) THEN
61504 CH60='LEP parameters tuned by Professor'
61505 WRITE(M11,5030) CH60
61509 C..."Lo FSR" retune (305)
61510 ELSEIF(ITUNEB.EQ.305) THEN
61512 CH60='"Lo FSR retune" with primitive colour reconnections'
61513 WRITE(M11,5030) CH60
61514 CH60='see T. Sjostrand & P. Skands, hep-ph/0408302'
61515 WRITE(M11,5030) CH60
61516 IF (ITUNE.GE.310) THEN
61517 CH60='LEP parameters tuned by Professor'
61518 WRITE(M11,5030) CH60
61522 C...Perugia Tunes (320-326)
61523 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61525 CH60='P. Skands, Perugia MPI workshop October 2008'
61526 WRITE(M11,5030) CH60
61527 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61528 WRITE(M11,5030) CH60
61529 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
61530 WRITE(M11,5030) CH60
61531 CH60='LEP parameters tuned by Professor'
61532 WRITE(M11,5030) CH60
61533 IF (ITUNE.EQ.325) THEN
61534 CH70='NB! This tune requires MRST LO* pdfs to be '//
61535 & 'externally linked'
61536 WRITE(M11,5035) CH70
61537 ELSEIF (ITUNE.EQ.326) THEN
61538 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
61539 & 'externally linked'
61540 WRITE(M11,5035) CH70
61541 ELSEIF (ITUNE.EQ.321) THEN
61542 CH60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
61543 WRITE(M11,5030) CH60
61544 ELSEIF (ITUNE.EQ.322) THEN
61545 CH60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
61546 WRITE(M11,5030) CH60
61550 C...Professor-pT0 (329)
61551 ELSEIF(ITUNE.EQ.329) THEN
61553 CH60='See T. Sjostrand & P. Skands, hep-ph/0408302'
61554 WRITE(M11,5030) CH60
61555 CH60='and M. Sandhoff & P. Skands, in hep-ph/0604120'
61556 WRITE(M11,5030) CH60
61557 CH60='LEP/Tevatron parameters tuned by Professor'
61558 WRITE(M11,5030) CH60
61565 WRITE(M11,5030) ' '
61566 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
61567 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
61568 IF (MSTP(70).EQ.0) THEN
61569 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
61570 ELSEIF (MSTP(70).EQ.1) THEN
61571 WRITE(M11,5050) 81, PARP(81), CHPARP(62)
61572 CH60='(Note: PARP(81) replaces PARP(62).)'
61573 WRITE(M11,5030) CH60
61575 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
61576 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
61577 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
61578 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
61579 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
61580 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61581 WRITE(M11,5030) CH60
61582 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
61583 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
61584 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
61585 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
61586 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
61587 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
61588 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
61589 IF (MSTP(70).EQ.2) THEN
61590 CH60='(Note: PARP(82) replaces PARP(62).)'
61591 WRITE(M11,5030) CH60
61593 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
61594 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
61595 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
61596 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
61597 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
61598 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
61599 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
61600 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
61601 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
61602 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
61603 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
61604 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
61605 IF (MSTP(95).GE.1) THEN
61606 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
61607 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
61609 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
61610 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
61611 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
61612 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
61613 IF (MSTJ(11).LE.3) THEN
61614 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
61615 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
61617 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
61619 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
61622 C=======================================================================
61623 C...ATLAS-CSC 11-parameter tune (By A. Moraes)
61624 ELSEIF (ITUNE.EQ.306) THEN
61625 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
61626 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
61627 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61638 C...UE on, new model.
61643 C...Switch off trial joinings
61645 C...Primordial kT cutoff
61648 CH60='see presentations by A. Moraes (ATLAS),'
61649 WRITE(M11,5030) CH60
61650 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61651 WRITE(M11,5030) CH60
61652 WRITE(M11,5030) ' '
61653 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
61654 & 'externally linked'
61655 WRITE(M11,5035) CH70
61657 C...Smooth ISR, low FSR
61662 C...Transverse density profile.
61666 C...ISR & FSR in interactions after the first (default)
61669 C...No double-counting (default)
61671 C...Companion quark parent gluon (1-x) power
61673 C...Primordial kT compensation along chaings (default = 0 : uniform)
61675 C...Colour Reconnections
61678 C...Lambda_FSR scale.
61680 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
61685 C...Peterson charm frag, and c and b hadr parameters
61691 WRITE(M11,5030) ' '
61692 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
61693 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
61694 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
61695 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
61696 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61697 WRITE(M11,5030) CH60
61698 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
61699 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
61700 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
61701 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
61702 CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
61703 WRITE(M11,5030) CH60
61704 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
61705 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
61706 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
61707 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
61708 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
61709 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
61710 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
61711 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
61712 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
61713 WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
61714 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
61715 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
61716 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
61717 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
61718 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
61719 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
61720 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
61721 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
61722 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
61723 IF (MSTJ(11).LE.3) THEN
61724 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
61725 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
61727 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
61729 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
61732 C=======================================================================
61733 C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
61734 C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
61735 C...A-Pro, DW-Pro, etc (100-119), and Pro-Q20 (129)
61736 ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
61737 & ITUNE.EQ.109.OR.(ITUNE.GE.110.AND.ITUNE.LE.116).OR.
61738 & ITUNE.EQ.118.OR.ITUNE.EQ.119.OR.ITUNE.EQ.129) THEN
61739 IF (M13.GE.1.AND.ITUNE.NE.106.AND.ITUNE.NE.129) THEN
61740 WRITE(M11,5010) ITUNE, CHNAME
61741 CH60='see R.D. Field, in hep-ph/0610012'
61742 WRITE(M11,5030) CH60
61743 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61744 WRITE(M11,5030) CH60
61745 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
61746 CH60='LEP parameters tuned by Professor'
61747 WRITE(M11,5030) CH60
61749 ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN
61750 WRITE(M11,5010) ITUNE, CHNAME
61751 CH60='See T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61752 WRITE(M11,5030) CH60
61753 CH60='LEP/Tevatron parameters tuned by Professor'
61754 WRITE(M11,5030) CH60
61757 C...Make sure we start from old default fragmentation parameters
61761 C...Use Professor's LEP pars if ITUNE >= 110
61762 C...(i.e., for A-Pro, DW-Pro etc)
61763 IF (ITUNE.LT.110) THEN
61766 C...# Old default flavour parameters
61773 C...# Tuned flavour parameters:
61783 C...# Switch on Bowler:
61785 C...# Fragmentation
61794 C...Remove middle digit now for Professor variants, since identical pars
61796 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
61797 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
61800 C...Multiple interactions on, old framework
61802 C...Fast IR cutoff energy scaling by default
61805 C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
61808 IF (ITUNEB.EQ.105) THEN
61811 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
61817 C...Double Gaussian matter distribution.
61823 C...Fragmentation functions and c and b parameters
61824 C...(only if not using Professor)
61825 IF (ITUNE.LE.109) THEN
61832 IF(ITUNEB.EQ.100.OR.ITUNEB.EQ.101) THEN
61835 c...String drawing almost completely minimizes string length.
61838 C...ISR cutoff, muR scale factor, and phase space size
61842 C...Intrinsic kT, size, and max
61846 C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
61847 IF (ITUNEB.EQ.101) THEN
61854 C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
61855 ELSEIF (ITUNEB.EQ.102) THEN
61858 c...String drawing completely minimizes string length.
61861 C...ISR cutoff, muR scale factor, and phase space size
61865 C...Intrinsic kT, size, and max
61871 ELSEIF (ITUNEB.EQ.103) THEN
61874 c...String drawing completely minimizes string length.
61877 C...ISR cutoff, muR scale factor, and phase space size
61881 C...Intrinsic kT, size, and max
61887 ELSEIF (ITUNEB.EQ.104) THEN
61890 C...Run II ref scale and slow scaling
61893 c...String drawing completely minimizes string length.
61896 C...ISR cutoff, muR scale factor, and phase space size
61900 C...Intrinsic kT, size, and max
61906 ELSEIF(ITUNEB.EQ.105) THEN
61908 WRITE(M11,5030) ' '
61909 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
61910 & 'externally linked'
61911 WRITE(M11,5035) CH70
61915 c...String drawing completely minimizes string length.
61918 C...ISR cutoff, muR scale factor, and phase space size
61922 C...Intrinsic kT, size, and max
61927 C...Tune D6 and D6T
61928 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
61930 WRITE(M11,5030) ' '
61931 CH70='NB! This tune requires CTEQ6L pdfs to be '//
61932 & 'externally linked'
61933 WRITE(M11,5035) CH70
61935 C...The "Rick" proton, double gauss with 0.5/0.4
61939 c...String drawing completely minimizes string length.
61942 IF (ITUNEB.EQ.108) THEN
61943 C...D6: pT0, Run I ref scale, and fast energy scaling
61948 C...D6T: pT0, Run II ref scale, and slow energy scaling
61953 C...ISR cutoff, muR scale factor, and phase space size
61957 C...Intrinsic kT, size, and max
61962 C...Old ATLAS-DC2 5-parameter tune
61963 ELSEIF(ITUNEB.EQ.106) THEN
61965 WRITE(M11,5010) ITUNE, CHNAME
61966 CH60='see A. Moraes et al., SN-ATLAS-2006-057,'
61967 WRITE(M11,5030) CH60
61968 CH60=' R. Field in hep-ph/0610012,'
61969 WRITE(M11,5030) CH60
61970 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61971 WRITE(M11,5030) CH60
61975 C... Different ref and rescaling pacee
61978 C... Parameters of mass distribution
61981 C... Old default string drawing
61984 C... ISR, phase space equivalent to Tune B
61995 C...Professor's Pro-Q20 Tune
61996 ELSEIF(ITUNE.EQ.129) THEN
61998 CH60='see H. Hoeth, Perugia MPI workshop, Oct 2008'
61999 WRITE(M11,5030) CH60
62019 WRITE(M11,5030) ' '
62020 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62021 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62022 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62023 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62024 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62025 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62026 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62027 WRITE(M11,5030) CH60
62028 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62029 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62030 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62031 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62032 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62033 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62034 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62035 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62036 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62037 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62038 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62039 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62040 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62041 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62042 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62043 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62044 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62045 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62046 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62047 IF (MSTJ(11).LE.3) THEN
62048 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62049 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62051 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62053 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62056 C=======================================================================
62057 C... ACR, tune A with new CR (107)
62058 ELSEIF(ITUNE.EQ.107.OR.ITUNE.EQ.117) THEN
62060 WRITE(M11,5010) ITUNE, CHNAME
62061 CH60='Tune A modified with new colour reconnections'
62062 WRITE(M11,5030) CH60
62063 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
62064 WRITE(M11,5030) CH60
62065 CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
62066 WRITE(M11,5030) CH60
62067 CH60=' R. Field, in hep-ph/0610012 (Tune A),'
62068 WRITE(M11,5030) CH60
62069 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62070 WRITE(M11,5030) CH60
62071 IF (ITUNE.EQ.117) THEN
62072 CH60='LEP parameters tuned by Professor'
62073 WRITE(M11,5030) CH60
62076 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
62077 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62078 & ' with tune. Using defaults.')
62082 C...Make sure we start from old default fragmentation parameters
62086 C...Use Professor's LEP pars if ITUNE >= 110
62087 C...(i.e., for A-Pro, DW-Pro etc)
62088 IF (ITUNE.LT.110) THEN
62091 C...# Old default flavour parameters
62098 C...# Tuned flavour parameters:
62108 C...# Switch on Bowler:
62110 C...# Fragmentation
62138 C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
62140 C...Frag functions (only if not using Professor)
62141 IF (ITUNE.LE.109) THEN
62149 WRITE(M11,5030) ' '
62150 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62151 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62152 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62153 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62154 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62155 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62156 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62157 WRITE(M11,5030) CH60
62158 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62159 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62160 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62161 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62162 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62163 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62164 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62165 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62166 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62167 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62168 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62169 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62170 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62171 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62172 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62173 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62174 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62175 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62176 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62177 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62178 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62179 IF (MSTJ(11).LE.3) THEN
62180 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62181 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62183 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62185 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62188 C=======================================================================
62189 C...Intermediate model. Rap tune
62190 C...(retuned to post-6.406 IR factorization)
62191 ELSEIF(ITUNE.EQ.200) THEN
62193 WRITE(M11,5010) ITUNE, CHNAME
62194 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
62195 WRITE(M11,5030) CH60
62197 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62198 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62216 C... ExpOfPow(1.8) overlap profile
62223 C... Default diquark, BR-g-BR supp
62226 C... Final state reconnect.
62229 C...Fragmentation functions and c and b parameters
62235 WRITE(M11,5030) ' '
62236 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62237 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62238 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62239 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62240 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62241 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62242 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62243 WRITE(M11,5030) CH60
62244 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62245 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62246 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62247 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62248 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62249 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62250 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62251 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62252 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
62253 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
62254 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
62255 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
62256 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62257 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62258 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62259 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62260 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62261 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62262 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62263 IF (MSTJ(11).LE.3) THEN
62264 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62265 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62267 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62269 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62272 C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
62273 C...Old model for ISR and UE, new pT-ordered model for FSR
62274 ELSEIF(ITUNE.EQ.201.OR.ITUNE.EQ.211.OR.ITUNE.EQ.221.OR
62275 & .ITUNE.EQ.226) THEN
62277 WRITE(M11,5010) ITUNE, CHNAME
62278 CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
62279 WRITE(M11,5030) CH60
62280 CH60=' R.D. Field, in hep-ph/0610012 (Tune A)'
62281 WRITE(M11,5030) CH60
62282 CH60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62283 WRITE(M11,5030) CH60
62284 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
62285 WRITE(M11,5030) CH60
62286 IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN
62287 CH60='LEP parameters tuned by Professor'
62288 WRITE(M11,5030) CH60
62291 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
62292 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62295 C...First set as if Pythia tune A
62296 C...Multiple interactions on, old framework
62298 C...Fast IR cutoff energy scaling by default
62301 C...Default CTEQ5L (internal)
62304 C...Double Gaussian matter distribution.
62310 c...String drawing almost completely minimizes string length.
62313 C...ISR cutoff, muR scale factor, and phase space size
62317 C...Intrinsic kT, size, and max
62321 C...Use 2 GeV of primordial kT for "Perugia" version
62322 IF (ITUNE.EQ.221) THEN
62326 C...Use pT-ordered FSR
62328 C...Lambda_FSR scale for pT-ordering
62330 C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
62332 C...Fragmentation functions and c and b parameters
62333 C...(overwritten for 211, i.e., if using Professor pars)
62337 C...Use Professor's LEP pars if ITUNE == 211, 221, 226
62338 IF (ITUNE.LT.210) THEN
62341 C...# Old default flavour parameters
62348 C...# Tuned flavour parameters:
62358 C...# Always use pT-ordered shower:
62360 C...# Switch on Bowler:
62362 C...# Fragmentation
62363 PARJ(21) = 3.1327e-01
62364 PARJ(41) = 4.8989e-01
62365 PARJ(42) = 1.2018e+00
62366 PARJ(47) = 1.0000e+00
62367 PARJ(81) = 2.5696e-01
62368 PARJ(82) = 8.0000e-01
62371 C...221, 226 : Perugia-APT and Perugia-APT6
62372 IF (ITUNE.EQ.221.OR.ITUNE.EQ.226) THEN
62378 C...The Perugia variants use Steve's showers off the old MPI
62380 C...And use a lower PARP(71) as suggested by Professor tunings
62381 C...(although not certain that applies to Q2-pT2 hybrid)
62384 C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
62385 IF (ITUNE.EQ.226) THEN
62386 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
62387 & 'externally linked'
62388 WRITE(M11,5035) CH70
62398 WRITE(M11,5030) ' '
62399 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62400 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62401 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62402 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62403 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62404 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62405 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62406 WRITE(M11,5030) CH60
62407 WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
62408 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62409 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62410 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62411 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62412 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62413 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62414 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62415 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62416 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62417 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62418 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62419 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62420 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62421 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62422 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62423 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62424 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62425 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62426 IF (MSTJ(11).LE.3) THEN
62427 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62428 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62430 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62432 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62435 C======================================================================
62436 C...Uppsala models: Generalized Area Law and Soft Colour Interactions
62437 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
62439 WRITE(M11,5010) ITUNE, CHNAME
62440 CH60='see J. Rathsman, PLB452(1999)364'
62441 WRITE(M11,5030) CH60
62442 C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
62443 C ? WRITE(M11,5030)
62444 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62445 WRITE(M11,5030) CH60
62446 WRITE(M11,5030) ' '
62447 CH70='NB! The GAL model must be run with modified '//
62449 WRITE(M11,5035) CH70
62450 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
62451 WRITE(M11,5035) CH70
62452 WRITE(M11,5030) ' '
62454 C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
62467 IF(CHNAME.EQ.'GAL Tune 1') THEN
62468 C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
62474 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62475 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62476 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62477 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62478 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62482 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62483 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
62484 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62489 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62490 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62491 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
62492 CH40='FSI SCI/GAL selection'
62493 WRITE(M11,6040) 1, MSWI(1), CH40
62494 CH40='FSI SCI/GAL sea quark treatment'
62495 WRITE(M11,6040) 2, MSWI(2), CH40
62496 CH40='FSI SCI/GAL sea quark treatment parm'
62497 WRITE(M11,6050) 1, PARSCI(1), CH40
62498 CH40='FSI SCI/GAL string reco probability R_0'
62499 WRITE(M11,6050) 2, PARSCI(2), CH40
62500 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62501 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
62503 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
62505 WRITE(M11,5010) ITUNE, CHNAME
62506 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
62507 WRITE(M11,5030) CH60
62508 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62509 WRITE(M11,5030) CH60
62510 WRITE(M11,5030) ' '
62511 CH70='NB! The SCI model must be run with modified '//
62513 WRITE(M11,5035) CH70
62514 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
62515 WRITE(M11,5035) CH70
62516 WRITE(M11,5030) ' '
62518 C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
62528 IF (CHNAME.EQ.'SCI Tune 1') THEN
62529 C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
62537 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62538 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62539 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62540 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62541 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62545 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62546 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
62547 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62552 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
62553 CH40='FSI SCI/GAL selection'
62554 WRITE(M11,6040) 1, MSWI(1), CH40
62555 CH40='FSI SCI/GAL sea quark treatment'
62556 WRITE(M11,6040) 2, MSWI(2), CH40
62557 CH40='FSI SCI/GAL sea quark treatment parm'
62558 WRITE(M11,6050) 1, PARSCI(1), CH40
62559 CH40='FSI SCI/GAL string reco probability R_0'
62560 WRITE(M11,6050) 2, PARSCI(2), CH40
62561 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
62565 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
62569 100 IF (MSTU(13).GE.1) WRITE(M11,6000)
62573 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
62574 & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
62575 & 20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
62576 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
62577 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
62578 5030 FORMAT(' *',3x,10x,A60,3x,'*')
62579 5035 FORMAT(' *',3x,A70,3x,'*')
62580 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
62581 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
62582 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
62583 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
62584 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
62585 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
62586 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
62587 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
62588 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
62592 C*********************************************************************
62595 C...Administrates the fragmentation and decay chain.
62599 C...Double precision and integer declarations.
62600 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62601 IMPLICIT INTEGER(I-N)
62602 INTEGER PYK,PYCHGE,PYCOMP
62604 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62605 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62606 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62607 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62608 COMMON/PYINT1/MINT(400),VINT(400)
62609 COMMON/PYINT4/MWID(500),WIDS(500,5)
62610 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
62612 DIMENSION PS(2,6),IJOIN(100)
62614 C...Initialize and reset.
62616 IF(MSTU(12).NE.12345) CALL PYLIST(0)
62618 MSTU(31)=MSTU(31)+1
62622 IF(MSTU(17).LE.0) MSTU(90)=0
62625 C...Sum up momentum, energy and charge for starting entries.
62633 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
62635 PS(1,J)=PS(1,J)+P(I,J)
62637 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
62641 C...Start by all decays of coloured resonances involved in shower.
62644 IF(K(I,1).EQ.3) THEN
62646 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
62650 C...Prepare system for subsequent fragmentation/decay.
62652 IF(MINT(51).NE.0) RETURN
62654 C...Loop through jet fragmentation and particle decays.
62660 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
62663 C...Deal with any remaining undecayed resonance
62664 C...(normally the task of PYEVNT, so seldom used).
62665 ELSEIF(MWID(KC).NE.0) THEN
62667 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
62670 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
62671 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
62674 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
62675 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
62678 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
62686 IF(MINT(51).NE.0) RETURN
62688 C...Particle decay if unstable and allowed. Save long-lived particle
62689 C...decays until second pass after Bose-Einstein effects.
62690 ELSEIF(KCHG(KC,2).EQ.0) THEN
62691 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
62692 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
62695 C...Decay products may develop a shower.
62696 IF(MSTJ(92).GT.0) THEN
62698 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
62699 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
62701 CALL PYSHOW(IP1,IP1+1,QMAX)
62703 IF(MINT(51).NE.0) RETURN
62705 ELSEIF(MSTJ(92).LT.0) THEN
62708 CALL PYSHOW(IP1,-3,P(IP,5))
62710 IF(MINT(51).NE.0) RETURN
62714 C...Jet fragmentation: string or independent fragmentation.
62715 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
62717 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
62718 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
62719 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
62720 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
62721 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
62724 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
62725 IF(MFRAG.EQ.2) CALL PYINDF(IP)
62726 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
62727 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
62730 C...Loop back if enough space left in PYJETS and no error abort.
62731 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
62732 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
62734 ELSEIF(IP.LT.N) THEN
62735 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
62738 C...Include simple Bose-Einstein effect parametrization if desired.
62739 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
62744 C...Check that momentum, energy and charge were conserved.
62746 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
62748 PS(2,J)=PS(2,J)+P(I,J)
62750 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
62752 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
62753 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
62754 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
62755 &'(PYEXEC:) four-momentum was not conserved')
62756 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
62757 &'(PYEXEC:) charge was not conserved')
62762 C*********************************************************************
62765 C...Rearranges partons along strings.
62766 C...Special considerations for systems with junctions, with
62767 C...possibility of junction-antijunction annihilation.
62768 C...Allows small systems to collapse into one or two particles.
62769 C...Checks flavours and colour singlet invariant masses.
62771 SUBROUTINE PYPREP(IP)
62773 C...Double precision and integer declarations.
62774 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62775 INTEGER PYK,PYCHGE,PYCOMP
62777 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62778 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62779 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
62780 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62781 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62782 COMMON/PYINT1/MINT(400),VINT(400)
62783 C...The common block of colour tags.
62784 COMMON/PYCTAG/NCT,MCT(4000,2)
62785 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
62790 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
62791 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
62792 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
62793 &IJCP(0:6),TJUOLD(5)
62796 C...Function to give four-product.
62797 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)
62799 C...Rearrange parton shower product listing along strings: begin loop.
62807 DO 100 I=MAX(1,IP),N
62808 C...First store junction positions.
62809 IF(K(I,1).EQ.42) THEN
62817 DO 240 I=MAX(1,IP),N
62818 C...Special treatment for junctions
62819 IF (K(I,1).LE.0) GOTO 240
62820 IF(K(I,1).EQ.42) THEN
62821 C...MQGST=2: Look for junction-junction strings (not detected in the
62822 C...main search below).
62823 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
62824 IF (NJJSTR.EQ.0) THEN
62825 NJJSTR = (3*NJUNC-NPIECE)/2
62827 C...Check how many already identified strings end on this junction
62830 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
62832 C...If less than 3, remaining must be to another junction
62835 C...Multiple j-j connections not handled yet.
62837 & '(PYPREP:) Too many junction-junction strings.')
62841 C...The colour information in the junction is unreadable for the
62842 C...colour space search further down in this routine, so we must
62843 C...start on the colour mother of this junction and then "artificially"
62844 C...prevent the colour mother from connecting here again.
62845 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
62847 IF (MOD(ITJUNC,2).EQ.0) KCS=5
62848 C...Switch colour if the junction-junction leg is presumably a
62849 C...junction mother leg rather than a junction daughter leg.
62850 IF (ITJUNC.GE.3) KCS=9-KCS
62851 IF (MINT(33).EQ.0) THEN
62852 C...Find the unconnected leg and reorder junction daughter pointers so
62853 C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
62855 IA=MOD(K(I,4),MSTU(5))
62856 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
62857 ITMP=MOD(K(I,5),MSTU(5))
62858 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
62859 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
62860 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
62862 K(I,5)=K(I,5)+(IA-ITMP)
62864 K(I,4)=K(I,4)+(ITMP-IA)
62867 IF (ITJUNC.LE.2) THEN
62868 C...Beam baryon junction
62869 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
62870 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
62871 C...Else 1 -> 2 decay junction
62873 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
62874 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
62879 C...Alternatively use colour tag information.
62881 C...Find a final state parton with appropriate dangling colour tag.
62885 DO 140 J1=MAX(1,IP),N
62886 IF (K(J1,1).NE.3) GOTO 140
62887 C...Check for matching final-state colour tag
62889 DO 120 J2=MAX(1,IP),N
62890 IF (K(J2,1).NE.3) GOTO 120
62891 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
62893 IF (IMATCH.EQ.1) GOTO 140
62894 C...Check whether this colour tag belongs to the present junction
62895 C...by seeing whether any parton with this colour tag has the same
62896 C...mother as the junction.
62899 DO 130 J2=MINT(84)+1,N
62901 C...First scattering partons have IMO1 = 3 and 4.
62902 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
62904 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
62907 IF (IMATCH.EQ.0) GOTO 140
62910 C...Check for junction-junction strings without intermediate final state
62911 C...glue (not detected above).
62915 IF (IJU2.EQ.I) GOTO 160
62916 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
62917 C...Only opposite types of junctions can connect to each other.
62918 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
62921 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
62923 IF (IS.EQ.3) GOTO 160
62928 C...Switch to other side of adjacent parton and step from there.
62934 ELSE IF (ILC.NE.3) THEN
62939 C...Look for coloured string endpoint, or (later) leftover gluon.
62940 IF(K(I,1).NE.3) GOTO 240
62942 IF(KC.EQ.0) GOTO 240
62944 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
62946 C...Pick up loose string end.
62948 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
62954 IF(NSTP.GT.4*N) THEN
62955 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
62960 C...Copy undecayed parton. Finished if reached string endpoint.
62961 IF(K(IA,1).EQ.3) THEN
62962 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
62963 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
62970 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
62980 IF(K(I1,1).EQ.1) GOTO 240
62983 C...Also finished (for now) if reached junction; then copy to end.
62984 IF(K(IA,1).EQ.42) THEN
62986 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
62987 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
62992 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
62993 DO 200 ICOPY=1,NCOPY
62995 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
62996 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
62997 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
63001 C...For junction-junction strings, find end leg and reorder junction
63002 C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
63003 C...junction-junction string piece.
63004 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
63005 ITMP=MOD(K(IA,4),MSTU(5))
63006 IF (ITMP.NE.IB) THEN
63007 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
63008 K(IA,5)=K(IA,5)+(ITMP-IB)
63010 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
63012 K(IA,4)=K(IA,4)+(IB-ITMP)
63017 C...0: endpoint in original ER
63020 C...3: Parton immediately next to junction
63023 IPIECE(NPIECE,1)=MSTU32+1
63024 IPIECE(NPIECE,2)=MSTU32+NCOPY
63025 IPIECE(NPIECE,3)=IB
63026 IPIECE(NPIECE,4)=IA
63027 MSTU32=MSTU32+NCOPY
63032 C...GOTO next parton in colour space.
63034 IF (MINT(33).EQ.0) THEN
63035 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
63037 IA=MOD(K(IB,KCS),MSTU(5))
63038 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
63041 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
63042 & MSTU(5)).EQ.0) KCS=9-KCS
63043 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
63044 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
63047 IF(IA.LE.0.OR.IA.GT.N) THEN
63048 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
63049 IF(NERRPR.LT.5) THEN
63051 WRITE(MSTU(11),*) 'started at:', I
63052 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
63053 WRITE(MSTU(11),*) 'MQGST =',MQGST
63059 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
63060 & ,MSTU(5)).EQ.IB) THEN
63061 IF(MREV.EQ.1) KCS=9-KCS
63062 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
63063 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
63065 IF(MREV.EQ.0) KCS=9-KCS
63066 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
63067 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
63069 IF(IA.NE.I) GOTO 170
63070 C...Use colour tag information
63072 C...First create colour tags starting on IB if none already present.
63073 IF (MCT(IB,KCS-3).EQ.0) THEN
63074 CALL PYCTTR(IB,KCS,IB)
63075 IF(MINT(51).NE.0) RETURN
63079 C...Find final state tag partner
63080 DO 210 IT=MAX(1,IP),N
63081 IF (IT.EQ.IB) GOTO 210
63082 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
63088 C...Just copy and goto next if exactly one partner found.
63089 IF (IFOUND.EQ.1) THEN
63091 C...When no match found, match is presumably junction.
63092 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
63093 C...Check whether this colour tag matches a junction
63094 C...by seeing whether any parton with this colour tag has the same
63095 C...mother as a junction.
63096 C...NB: Only type 1 and 2 junctions handled presently.
63098 IJUMO=K(IJUNC(IJU,0),3)
63099 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
63100 C...Colours only connect to junctions, anti-colours to antijunctions:
63101 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
63103 DO 220 J1=MAX(1,IP),N
63104 IF (K(J1,1).LE.0) GOTO 220
63105 C...First scattering partons have IMO1 = 3 and 4.
63107 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
63109 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
63110 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
63112 C...Attempt at handling type > 3 junctions also. Not tested.
63113 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
63116 IF (IMATCH.EQ.0) GOTO 230
63121 IF (IFOUND.EQ.1) THEN
63123 ELSEIF (IFOUND.EQ.0) THEN
63125 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
63127 IF(NERRPR.LT.5) THEN
63134 ELSEIF (IFOUND.GE.2) THEN
63137 & ,'(PYPREP:) too many occurences of colour line: '//
63139 IF(NERRPR.LT.5) THEN
63151 C...Junction systems remain.
63157 260 IJUCNT=IJUCNT+1
63158 IF (IJUCNT.LE.NJUNC) THEN
63159 C...If we are not processing a j-j string, treat this junction as new.
63160 IF (IJJSTR.EQ.0) THEN
63161 IJU=IJUNC(IJUCNT,0)
63163 C...If junction has already been read, ignore it.
63164 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
63165 C...If we are on a j-j string, goto second j-j junction.
63170 C...Mark selected junction read.
63172 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
63174 C...Determine junction type
63175 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
63176 C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
63177 C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
63178 C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
63179 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
63182 C...Find which quarks belong to given junction.
63184 DO 290 IPC=1,NPIECE
63185 IF (IPIECE(IPC,4).EQ.IJU) THEN
63187 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
63189 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
63191 C...IHK = 3 is special. Either normal string piece, or j-j string.
63193 IF (MREV.NE.1) THEN
63194 DO 300 IPC=1,NPIECE
63195 C...If there is a j-j string starting on the present junction which has
63196 C...zero length, insert next junction immediately.
63197 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
63198 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
63204 C...If MREV is 1 and IHK is 3 we are finished with this system.
63211 C...If we've gotten this far, then either IHK < 3, or
63212 C...an interjunction string exists, or just a third normal string.
63213 IJUNC(IJUCNT,IHK)=0
63215 C..Order pieces belonging to this junction. Also look for j-j.
63216 DO 310 IPC=1,NPIECE
63217 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
63218 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
63219 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
63220 IJUNC(IJUCNT,IHK)=IPC
63225 C...Copy back chains in proper order. MREV=0/1 : descending/ascending
63226 IPC=IJUNC(IJUCNT,IHK)
63227 C...Temporary solution to cover for bug.
63229 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
63233 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
63236 K(I1,J)=K(MSTU(4)-ICP,J)
63237 P(I1,J)=P(MSTU(4)-ICP,J)
63238 V(I1,J)=V(MSTU(4)-ICP,J)
63242 C...Mark last quark.
63243 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
63244 C...Do not insert junctions at wrong places.
63245 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
63246 C...Insert junction.
63249 C...Shift to end junction if a j-j string has been processed.
63250 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
63260 K(IJUS,1)=K(IJUS,1)+10
63263 360 IF (IHK.LT.3) GOTO 280
63265 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
63269 IF (IJUCNT.NE.NJUNC) GOTO 260
63273 C...Rearrange three strings from junction, e.g. in case one has been
63274 C...shortened by shower, so the last is the largest-energy one.
63275 IF(NJUNC.GE.1) THEN
63276 C...Find systems with exactly one junction.
63280 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
63281 ELSEIF(K(I,1).EQ.41) THEN
63283 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
63288 C...Sum up energy-momentum in each junction string.
63295 DO 390 I1=NBEG,NEND
63296 IF(K(I1,2).NE.21) THEN
63301 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
63304 C...Find which of them has highest energy (minus mass) in rest frame.
63306 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
63308 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
63311 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
63312 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
63314 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
63315 C...Decide how to rearrange so that new last has highest energy.
63316 IF(PJU(1,6).LT.PJU(2,6)) THEN
63318 IRNG(1,2)=IJUR(2)-1
63320 IRNG(2,2)=IJUR(3)+1
63321 IRNG(4,1)=IJUR(3)-1
63325 IRNG(1,2)=IJUR(3)+1
63327 IRNG(2,2)=IJUR(3)-1
63328 IRNG(4,1)=IJUR(2)-1
63333 C...Copy in correct order below bottom of current event record.
63336 DO 430 I1=IRNG(II,1),IRNG(II,2),
63337 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
63339 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
63341 & '(PYPREP:) no more memory left in PYJETS')
63351 IF(K(I2,1).EQ.1) K(I2,1)=2
63355 C...Copy back up, overwriting but now in correct order.
63356 DO 460 I1=NBEG,NEND
63370 C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
63371 C...to two q-qbar systems.
63372 C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
63373 IF (MSTJ(19).NE.1) THEN
63377 C...Force collapse when MSTJ(19)=2.
63378 IF (MSTJ(19).EQ.2) THEN
63382 C...Find systems with exactly two junctions.
63384 C...Count junctions
63385 IF (K(I,1).EQ.41) THEN
63387 C...Check for interjunction gluons
63388 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
63391 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
63392 C...If end of system reached with either zero or one junction, restart
63393 C...with next system.
63397 ELSEIF(K(I,1).EQ.1) THEN
63398 C...If end of system reached with exactly two junctions, compute string
63399 C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
63400 C...length measure for the (q-qbar)(q-qbar) topology.
63402 C...Loop down through chain.
63404 DO 480 I1=NBEG,NEND
63405 C...Store string piece division locations in event record
63406 IF (K(I1,2).NE.21) THEN
63411 C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
63413 IF (PYR(0).LT.0.5D0) ISW=1
63414 C...Randomly choose which qqbar string gets the jj gluons.
63416 IF (PYR(0).GT.0.5D0) IGS=2
63417 C...Only compute string lengths when no topology forced.
63418 IF (MSTJ(19).EQ.0) THEN
63419 C...Repeat following for each junction
63421 C...Initialize iterative procedure for finding JRF
63427 C...Start iteration. Sum up momenta in string pieces
63429 C...JD=-1 for first junction, +1 for second junction.
63430 C...Find out where piece starts and ends and which direction to go.
63433 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
63434 IB = IJCP((IJU-1)*7 - JD*IJS)
63435 ELSEIF (IJS.EQ.3) THEN
63437 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
63438 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
63440 C...Initialize junction pull 4-vector.
63444 C...Initialize weight
63447 C...Sum up (weighted) momenta along each string piece
63448 DO 530 ISP=IA,IB,JD
63449 C...If present parton not last in chain
63450 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
63451 C...If last parton was a junction, store present weight
63452 IF (K(ISP-JD,2).EQ.88) THEN
63454 C...If last parton was a quark, reset to stored weight.
63455 ELSEIF (K(ISP-JD,2).NE.21) THEN
63459 C...Skip next parton if weight already large
63460 IF (PWT.GT.10D0) GOTO 530
63461 C...Compute momentum in TJUOLD frame:
63462 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
63464 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
63466 TMP=P(ISP,J)+TJUOLD(J)*BFC
63467 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
63470 TMP=TJUOLD(4)*P(ISP,4)+TDP
63471 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
63473 PWT=PWT+TMP/PARJ(48)
63474 C...Put |p| rather than m in 5th slot
63475 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
63482 C...Combine new boost (T) with old boost (TJUOLD)
63483 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
63485 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
63488 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
63490 C...If last boost small, accept JRF, else iterate.
63491 C...Also prevent possibility of infinite loop.
63492 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
63493 & IJRFIT.LT.MSTJ(18))THEN
63495 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
63496 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
63498 C...Store final boost, with change of sign since TJJ motion vector.
63500 TJJ(IJU,IX)=-TJUOLD(IX)
63502 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
63505 C...String length measure for (q-qbar)(q-qbar) topology.
63506 C...Note only momenta of nearest partons used (since rest of system
63508 IF (JJGLUE.EQ.0) THEN
63509 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
63510 & -1,IJCP(5-ISW)+1)
63512 C...Put jj gluons on selected string (IGS selected randomly above).
63514 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
63515 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
63517 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
63518 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
63522 C...String length measure for q-q-j-j-q-q topology.
63531 C...Note only momenta of nearest partons used (since rest of system
63534 IF (IX.EQ.4) ISGN=1
63535 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
63536 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
63537 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
63538 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
63539 IF (JJGLUE.EQ.0) THEN
63540 C...Junction motion vector dot product gives length when inter-junction
63542 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
63544 C...Junction motion vector dot products with gluon momenta give length
63545 C...when inter-junction gluons present.
63546 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
63547 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
63550 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
63551 IF (JJGLUE.EQ.0) THEN
63552 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
63554 DELMJJ=DELMJJ*4D0*T1G1*T2G2
63557 C...If delmjj > delmqq collapse string system to q-qbar q-qbar
63558 C...(Always the case for MSTJ(19)=2 due to initialization above)
63559 IF (DELMJJ.GT.DELMQQ) THEN
63560 C...Put new system at end of event record
63563 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
63566 P(NCOP,IX)=P(ICOP,IX)
63567 K(NCOP,IX)=K(ICOP,IX)
63570 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
63571 C...Insert inter-junction gluon string piece (reversed)
63573 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
63577 P(NCOP,IX)=P(ICOP,IX)
63578 K(NCOP,IX)=K(ICOP,IX)
63583 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
63586 P(NCOP,IX)=P(ICOP,IX)
63587 K(NCOP,IX)=K(ICOP,IX)
63592 C...Copy system back in right order
63593 DO 670 ICOP=NBEG,NEND-2
63595 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
63596 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
63599 C...Shift down rest of event record
63600 DO 690 ICOP=NEND+1,N
63602 P(ICOP-2,IX)=P(ICOP,IX)
63603 K(ICOP-2,IX)=K(ICOP,IX)
63606 C...Update length of event record.
63616 C...Done if no checks on small-mass systems.
63617 IF(MSTJ(14).LT.0) RETURN
63618 IF(MSTJ(14).EQ.0) GOTO 1140
63620 C...Find lowest-mass colour singlet jet system.
63625 DO 770 I=MAX(1,IP),N
63626 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
63627 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
63634 DPS(5)=PYMASS(K(I,2))
63635 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
63637 DPS(J)=DPS(J)+P(I,J)
63640 DPS(5)=DPS(5)+PYMASS(K(I,2))
63641 ELSEIF(K(I,1).EQ.2) THEN
63643 DPS(J)=DPS(J)+P(I,J)
63645 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
63647 DPS(J)=DPS(J)+P(I,J)
63650 DPS(5)=DPS(5)+PYMASS(K(I,2))
63651 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
63653 IF(PD.LT.PDMIN) THEN
63667 C...Done if lowest-mass system above threshold for string frag.
63668 IF(PDMIN.GE.PARJ(32)) GOTO 1140
63670 C...Fill small-mass system as cluster.
63672 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
63682 C...Set up history, assuming cluster -> 2 hadrons.
63688 IF(MSTU(16).NE.2) THEN
63703 C...Find total flavour content - complicated by presence of junctions.
63707 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
63710 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
63714 C...If several diquarks, split up one to give even number of flavours.
63715 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
63717 IF(IABS(KFQ(3)).LT.1000) I1=1
63718 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
63719 KFQ(I1)=KFQ(I1)/1000
63724 C...If four quark ends, join two to diquark.
63725 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
63728 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
63729 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
63730 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
63731 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
63732 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
63733 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
63739 C...If two quark ends, plus quark or diquark, join quarks to diquark.
63743 IF(IABS(KFQ(I1)).GT.1000) I1=3
63744 IF(IABS(KFQ(I2)).GT.1000) I2=3
63745 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
63746 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
63747 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
63748 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
63754 C...Form two particles from flavours of lowest-mass system, if feasible.
63756 790 NTRY = NTRY + 1
63758 C...Open string with two specified endpoint flavours.
63762 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
63763 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
63764 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
63765 IF(KQ1+KQ2.NE.0) GOTO 1140
63766 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
63768 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
63770 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
63771 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
63772 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
63774 C...Open string with four specified flavours.
63775 ELSEIF(NQ.EQ.4) THEN
63780 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
63781 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
63782 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
63783 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
63784 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
63785 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
63786 C...Combine flavours pairwise to form two hadrons.
63789 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
63790 & IABS(KFQ(2)).GT.1000)) I2=3
63791 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
63792 & IABS(KFQ(3)).GT.1000))) I2=4
63796 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
63797 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
63798 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
63802 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
63803 C...No room for popcorn mesons in closed string -> 2 hadrons.
63805 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
63806 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
63807 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
63808 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
63810 P(N+2,5)=PYMASS(K(N+2,2))
63811 P(N+3,5)=PYMASS(K(N+3,2))
63813 C...If it does not work: try again (a number of times), give up (if no
63814 C...place to shuffle momentum or too many flavours), or form one hadron.
63815 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
63816 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
63818 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
63825 C...Perform two-particle decay of jet system.
63826 C...First step: find reference axis in decaying system rest frame.
63827 C...(Borrow slot N+2 for temporary direction.)
63831 DO 850 I=IC1+1,IC2-1
63832 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
63833 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
63834 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
63836 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
63840 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
63842 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
63843 PHI1=PYANGL(P(N+2,1),P(N+2,2))
63845 C...Second step: generate isotropic/anisotropic decay.
63846 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
63847 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
63849 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
63850 PT2=(1D0-UE(3)**2)*PA**2
63851 IF(MSTJ(16).LE.0) THEN
63854 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
63855 PR1=P(N+2,5)**2+PT2
63856 PR2=P(N+3,5)**2+PT2
63857 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
63859 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
63860 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
63862 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
63864 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
63865 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
63870 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
63871 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
63873 C...Third step: move back to event frame and set production vertex.
63874 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
63884 C...Else form one particle, if possible.
63892 C...Select hadron flavour from available quark flavours.
63893 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
63895 ELSEIF(NQ.EQ.2) THEN
63896 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
63898 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
63899 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
63901 IF(K(N+2,2).EQ.0) GOTO 910
63902 P(N+2,5)=PYMASS(K(N+2,2))
63904 C...Use old algorithm for E/p conservation? (EN)
63905 IF (MSTJ(16).LE.0) GOTO 1080
63907 C...Find the string piece closest to the cluster by a loop
63908 C...over the undecayed partons not in present cluster. (EN)
63913 DO 940 I1=MAX(1,IP),N-1
63914 IF(K(I1,1).EQ.1) NJUNC=0
63915 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
63916 IF(K(I1,1).EQ.41) GOTO 940
63917 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
63919 ELSEIF(K(I1,1).EQ.2) THEN
63923 IF(K(I2,1).EQ.41) GOTO 940
63924 IF(K(I2,1).GT.10) GOTO 920
63925 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
63926 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
63927 & NJUNC.EQ.0) GOTO 940
63928 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
63929 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
63930 & K(I2,1).NE.1)) GOTO 940
63932 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
63934 E1(J)=P(I1,J)/P(I1,4)
63935 E2(J)=P(I2,J)/P(I2,4)
63936 ECL(J)=P(N+1,J)/P(N+1,4)
63941 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
63942 E3S=E3(1)**2+E3(2)**2+E3(3)**2
63943 E4S=E4(1)**2+E4(2)**2+E4(3)**2
63944 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
63945 IF(E34.LE.0D0) THEN
63947 ELSEIF(E34.LT.E3S) THEN
63948 DDMIN=E4S-E34**2/E3S
63950 DDMIN=E4S-2D0*E34+E3S
63953 C...Is this the smallest so far?
63954 IF(DDMIN.LT.DGLOMI) THEN
63959 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
63964 C... Check if there are any strings to connect to the new gluon. (EN)
63965 IF (IBEG.EQ.0) GOTO 1080
63967 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
63968 IF (P(N+1,5).GE.P(N+2,5)) THEN
63970 C...Construct 'gluon' that is needed to put hadron on the mass shell.
63971 FRAC=P(N+2,5)/P(N+1,5)
63973 P(N+2,J)=FRAC*P(N+1,J)
63974 PG(J)=(1D0-FRAC)*P(N+1,J)
63977 C... Copy string with new gluon put in.
63981 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
63982 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
64003 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
64006 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
64007 C...from string piece endpoints.
64010 C...Begin by copying string that should give energy to cluster.
64014 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
64015 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
64027 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
64030 C...Set initial Phad.
64032 P(NSAV+2,J)=P(NSAV+1,J)
64035 C...Calculate Pg, a part of which will be added to Phad later. (EN)
64036 1020 IF(MSTJ(16).EQ.1) THEN
64040 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
64041 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
64044 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
64046 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
64048 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
64049 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
64051 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
64052 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
64053 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
64055 C...If all gluon energy eaten, zero it and take a step back.
64057 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
64060 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
64066 IF(K(I1,1).EQ.41) ITER=-1
64068 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
64071 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
64077 IF(K(I2,1).EQ.41) ITER=-1
64079 IF(ITER.EQ.1) GOTO 1020
64081 C...If also all endpoint energy eaten, revert to old procedure.
64082 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
64083 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
64094 C... Construct the collapsed hadron and modified string partons.
64096 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
64097 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
64098 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
64100 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
64101 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
64103 C...Finished with string collapse in new scheme.
64107 C... Use old algorithm; by choice or when in trouble.
64109 C...Find parton/particle which combines to largest extra mass.
64114 IF(IR.NE.0) GOTO 1100
64115 DO 1090 I=MAX(1,IP),N
64116 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
64117 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
64118 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
64119 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
64120 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
64121 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
64123 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
64124 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
64125 IF(HSR.GT.HSM) THEN
64133 C...Shuffle energy and momentum to put new particle on mass shell.
64138 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
64139 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
64140 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
64142 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
64143 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
64147 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
64151 C...Mark collapsed system and store daughter pointers. Iterate.
64152 1120 DO 1130 I=IC1,IC2
64153 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
64154 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
64156 IF(MSTU(16).NE.2) THEN
64161 K(I,5)=NSAV+1+NBODY
64164 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
64166 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
64168 C...Check flavours and invariant masses in parton systems.
64176 DO 1180 I=MAX(1,IP),N
64177 IF(K(I,1).EQ.41) NJU=NJU+1
64178 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
64180 IF(KC.EQ.0) GOTO 1180
64181 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
64182 IF(KQ.EQ.0) GOTO 1180
64188 DPS(5)=DPS(5)+PYMASS(K(I,2))
64191 DPS(J)=DPS(J)+P(I,J)
64193 IF(K(I,1).EQ.1) THEN
64195 IF(NJU.EQ.0.AND.NP.NE.1) THEN
64196 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
64197 ELSEIF(NJU.EQ.1) THEN
64198 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
64199 ELSEIF(NJU.EQ.2) THEN
64200 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
64201 ELSEIF(NJU.GE.3) THEN
64204 IF(NFERR.EQ.1) THEN
64205 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
64209 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
64210 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
64211 & '(PYPREP:) too small mass in jet system')
64225 C*********************************************************************
64228 C...Handles the fragmentation of an arbitrary colour singlet
64229 C...jet system according to the Lund string fragmentation model.
64231 SUBROUTINE PYSTRF(IP)
64233 C...Double precision and integer declarations.
64234 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64235 IMPLICIT INTEGER(I-N)
64236 INTEGER PYK,PYCHGE,PYCOMP
64238 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64239 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64240 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64241 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
64242 C...Local arrays. All MOPS variables ends with MO
64243 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
64244 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
64245 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
64246 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
64247 &PBST(3,5),TJUOLD(5)
64249 C...Function: four-product of two vectors.
64250 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)
64251 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
64254 C...Reset counters.
64269 C...Identify parton system.
64272 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
64273 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
64274 IF(MSTU(21).GE.1) RETURN
64276 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
64278 IF(KC.EQ.0) GOTO 110
64279 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
64280 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
64281 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
64282 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
64283 IF(MSTU(21).GE.1) RETURN
64286 C...Take copy of partons to be considered. Check flavour sum.
64291 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
64293 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
64295 IF(KQ.NE.2) KQSUM=KQSUM+KQ
64296 IF(K(I,1).EQ.41) THEN
64297 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
64305 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
64306 IF(MOD(KQSUM,3).NE.0) THEN
64307 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
64308 IF(MSTU(21).GE.1) RETURN
64310 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
64312 C...Boost copied system to CM frame (for better numerical precision).
64313 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
64316 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
64320 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
64322 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
64323 IF(P(I,3).GT.0D0) THEN
64324 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
64325 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
64326 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
64328 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
64329 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
64330 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
64335 C...Search for very nearby partons that may be recombined.
64344 IF(MJU(1).GT.0) NRMIN=NRMIN+2
64345 IF(MJU(2).GT.0) NRMIN=NRMIN+2
64346 140 IF(NR.GT.NRMIN) THEN
64349 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
64351 IF(I.EQ.N+NR) I1=N+1
64352 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
64353 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
64355 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
64357 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
64358 & P(I1,2)**2+P(I1,3)**2))
64359 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
64360 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
64361 IF(PDR.LT.PDRMIN) THEN
64367 C...Recombine very nearby partons to avoid machine precision problems.
64368 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
64370 P(N+1,J)=P(N+1,J)+P(N+NR,J)
64372 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
64376 ELSEIF(PDRMIN.LT.PARU12) THEN
64378 P(IR,J)=P(IR,J)+P(IR+1,J)
64380 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
64382 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
64383 DO 190 I=IR+1,N+NR-1
64390 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
64392 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
64393 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
64399 C...Reset particle counter. Skip ahead if no junctions are present;
64400 C...this is usually the case!
64401 NRS=MAX(5*NR+11,NP)
64404 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64408 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
64409 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64410 IF(MSTU(21).GE.1) RETURN
64414 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
64415 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
64416 & ' junction strings not handled by MSTJ(12)>3 options')
64419 IF(MJU(JT).EQ.0) GOTO 640
64423 C...Find and sum up momentum on three sides of junction.
64424 C...Begin with previous boost = zero.
64429 C...Prevent IJU (specifically IJU(5)) from containing junk below
64435 C...Beginning and end of string system in event record.
64436 I1BEG=N+1+(JT-1)*(NR-1)
64437 I1END=N+NR+(JT-1)*(1-NR)
64438 C...Look for junction string piece end points
64439 DO 230 I1=I1BEG,I1END,JS
64440 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
64441 C...Store junction string piece end points.
64442 C 1-junction systems 2-junction systems
64443 C IU : 1 2 3 4 1 2 3 4 5 6
64444 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
64448 C...Sum over momenta, from junction outwards.
64452 C...Initialize junction drag and string piece 4-vectors.
64457 C...First two branches. Inwards out means opposite direction to JS.
64458 C...(JS is 1 for JT=1, -1 for JT=2)
64463 C...Last branch (gq or gjgqgq). Direction now reversed.
64469 DO 270 I1=I1A,I1B,IDIR
64470 C...Sum up momentum directions with exponential suppression
64471 C...for use in finding junction rest frame below.
64472 IF (K(I1,2).EQ.88) THEN
64473 C...gjgqgq type system encountered. Use current PWT as start
64474 C...for both strings.
64477 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
64478 C...Sum up string piece (boosted) 4-momenta.
64480 PJU(IU,J)=PJU(IU,J)+P(I1,J)
64482 C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
64483 C...boost is zero, see above). Skip parton if suppression factor large.
64484 IF (PWT.GT.10D0) GOTO 270
64485 C...Compute momentum in current frame:
64486 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
64487 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
64489 PTMP=P(I1,J)+TJUOLD(J)*BFC
64490 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
64493 PTMP=TJUOLD(4)*P(I1,4)+TDP
64494 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
64495 PWT=PWT+PTMP/PARJ(48)
64498 C...Put |p| rather than m in 5th slot.
64499 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
64500 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
64503 C...Calculate boost from present frame to next JRF candidate.
64505 CALL PYJURF(PBST,TJU)
64507 C...After some iterations do not take full step in new direction.
64508 IF(IJRFIT.GT.5) THEN
64509 REDUCE=0.8D0**(IJRFIT-5)
64510 TJU(1)=REDUCE*TJU(1)
64511 TJU(2)=REDUCE*TJU(2)
64512 TJU(3)=REDUCE*TJU(3)
64513 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
64516 C...Combine new boost (TJU) with old boost (TJUOLD)
64517 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
64519 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
64521 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
64523 C...If last boost small, accept JRF, else iterate.
64524 C...Also prevent possibility of infinite loop.
64525 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
64526 & IJRFIT.LT.MSTJ(18)) THEN
64528 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
64529 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
64532 C...Now store total boost in TJU and change perception.
64533 C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
64534 C...TJU = junction motion vector in string CM, so the sign changes.
64538 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
64542 C...Calculate string piece energies in junction rest frame.
64544 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
64546 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
64547 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
64550 C...Start preparing for fragmentation of two strings from junction.
64553 320 NTRYER=NTRYER+1
64556 NS=IABS(IJU(IU+1)-IJU(IU))
64558 C...Junction strings: find longitudinal string directions.
64560 IS1=IJU(IU)+JS*(IS-1)
64563 DP(1,J)=0.5D0*P(IS1,J)
64564 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
64565 DP(2,J)=0.5D0*P(IS2,J)
64566 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
64567 & (PJU(IU,5)/PBST(IU,5))
64569 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
64570 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
64574 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
64575 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64576 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64581 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
64582 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
64583 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
64585 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
64587 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
64588 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
64592 C...Junction strings: initialize flavour, momentum and starting pos.
64596 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64600 ELSEIF(NTRY.GT.100) THEN
64601 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64602 IF(MSTU(21).GE.1) RETURN
64607 IE(1)=K(N+1+(JT/2)*(NP-1),3)
64608 IF (MOD(JT+IU,2).NE.0) THEN
64610 IF (NP-NR.NE.0) THEN
64611 C...If gluons have disappeared. Original IJU must be used.
64615 IF (K(IT,2).NE.21) THEN
64618 IF (NE.EQ.IU+4*(JT-1)) THEN
64620 ELSEIF (IT.LE.IP+NP) THEN
64623 CALL PYERRM(14,'(PYSTRF:) '//
64624 & 'Original IJU could not be reconstructed!')
64632 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
64638 KFL(1)=K(IJU(IU),2)
64646 C...Junction strings: find initial transverse directions.
64649 DP(2,J)=P(IN(4)+1,J)
64653 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64654 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64655 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
64656 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
64657 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
64658 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
64659 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
64660 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
64661 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
64663 DHCX1=DFOUR(3,1)/DHC12
64664 DHCX2=DFOUR(3,2)/DHC12
64665 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
64666 DHCY1=DFOUR(4,1)/DHC12
64667 DHCY2=DFOUR(4,2)/DHC12
64668 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
64669 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
64671 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
64673 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
64677 C...Junction strings: produce new particle, origin.
64679 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
64680 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
64681 IF(MSTU(21).GE.1) RETURN
64689 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
64690 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
64691 IF(K(I,2).EQ.0) GOTO 360
64692 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
64693 & IABS(KFL(3)).GT.10) THEN
64694 IF(PYR(0).GT.PARJ(19)) GOTO 440
64696 P(I,5)=PYMASS(K(I,2))
64697 CALL PYPTDI(KFL(1),PX(3),PY(3))
64698 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
64699 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
64700 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
64701 & MSTU(90).LT.8) THEN
64702 MSTU(90)=MSTU(90)+1
64703 MSTU(90+MSTU(90))=I
64704 PARU(90+MSTU(90))=Z
64706 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
64711 C...Junction strings: stepping within 'low' string region.
64712 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
64713 & P(IN(1),5)**2.GE.PR(1)) THEN
64714 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
64715 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
64717 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
64720 C...Has used up energy of junction string, i.e. no more hadrons in it.
64721 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
64726 C...Stepping from 'low' string region
64727 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
64728 P(IN(2)+2,4)=P(IN(2)+2,3)
64731 IF(IN(2).GT.N+NR+4*NS) GOTO 360
64732 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
64733 P(IN(1)+2,4)=P(IN(1)+2,3)
64739 C...Junction strings: find new transverse directions.
64740 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
64741 & IN(1).GT.IN(2)) GOTO 360
64742 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
64749 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64750 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64752 IF(DHC12.LE.1D-2) THEN
64753 P(IN(1)+2,4)=P(IN(1)+2,3)
64759 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
64760 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
64761 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
64762 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
64763 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
64764 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
64765 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
64766 DHCX1=DFOUR(3,1)/DHC12
64767 DHCX2=DFOUR(3,2)/DHC12
64768 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
64769 DHCY1=DFOUR(4,1)/DHC12
64770 DHCY2=DFOUR(4,2)/DHC12
64771 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
64772 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
64774 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
64776 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
64779 C...Express pT with respect to new axes, if sensible.
64780 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
64781 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
64782 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
64788 C...Junction strings: sum up known four-momentum, coefficients for m2.
64791 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
64792 & PY(3)*P(IN(3)+1,J)
64793 DO 510 IN1=IN(4),IN(1)-4,4
64794 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
64796 DO 520 IN2=IN(5),IN(2)-4,4
64797 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
64801 DHM(2)=2D0*FOUR(I,IN(1))
64802 DHM(3)=2D0*FOUR(I,IN(2))
64803 DHM(4)=2D0*FOUR(IN(1),IN(2))
64805 C...Junction strings: find coefficients for Gamma expression.
64806 DO 550 IN2=IN(1)+1,IN(2),4
64807 DO 540 IN1=IN(1),IN2-1,4
64808 DHC=2D0*FOUR(IN1,IN2)
64809 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
64810 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
64811 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
64812 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
64816 C...Junction strings: solve (m2, Gamma) equation system for energies.
64817 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
64818 IF(ABS(DHS1).LT.1D-4) GOTO 360
64819 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
64820 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
64821 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
64822 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
64823 & ABS(DHS1)-DHS2/DHS1)
64824 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
64825 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
64826 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
64828 C...Junction strings: step to new region if necessary.
64829 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
64830 P(IN(2)+2,4)=P(IN(2)+2,3)
64833 IF(IN(2).GT.N+NR+4*NS) GOTO 360
64834 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
64835 P(IN(1)+2,4)=P(IN(1)+2,3)
64840 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
64841 P(IN(1)+2,4)=P(IN(1)+2,3)
64847 C...Junction strings: particle four-momentum, remainder, loop back.
64849 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
64850 & P(IN(2)+2,4)*P(IN(2),J)
64851 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
64853 IF(P(I,4).LT.P(I,5)) GOTO 360
64854 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
64855 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
64856 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
64861 IF(IN(3).NE.IN(6)) THEN
64863 P(IN(6),J)=P(IN(3),J)
64864 P(IN(6)+1,J)=P(IN(3)+1,J)
64869 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
64870 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
64875 C...Junction strings: save quantities left after each string.
64876 IF(IABS(KFL(1)).GT.10) GOTO 360
64880 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
64883 C...Junction strings: loopback if much unused energy in both strings.
64884 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
64885 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
64886 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
64888 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
64889 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
64890 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
64891 & .AND.NTRYER.LT.10) GOTO 320
64893 C...Junction strings: put together to new effective string endpoint.
64895 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
64896 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
64897 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
64898 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
64900 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
64901 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
64903 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
64908 C...Open versus closed strings. Choose breakup region for latter.
64909 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
64912 ELSEIF(MJU(1).NE.0) THEN
64915 ELSEIF(MJU(2).NE.0) THEN
64918 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
64925 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
64926 W2SUM=W2SUM+P(N+NR+IS,1)
64931 W2SUM=W2SUM-P(N+NR+NB,1)
64932 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
64935 C...Find longitudinal string directions (i.e. lightlike four-vectors).
64937 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
64938 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
64941 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
64942 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
64944 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
64945 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
64947 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
64948 & DP(1,2)**2-DP(1,3)**2))
64949 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
64950 & DP(2,2)**2-DP(2,3)**2))
64954 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
64955 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
64956 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
64957 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
64959 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
64961 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
64962 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
64966 C...Begin initialization: sum up energy, set starting position.
64970 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64974 ELSEIF(NTRY.GT.100) THEN
64975 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64976 IF(MSTU(21).GE.1) RETURN
64983 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
64988 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
64989 IF(NS.GT.NR) IRANK(JT)=1
64991 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
64992 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
64993 IN(3*JT+2)=IN(3*JT+1)+1
64994 IN(3*JT+3)=N+NR+4*NS+2*JT-1
64995 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
65002 C.. MOPS variables and switches
65008 C...Initialize flavour and pT variables for open string.
65012 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
65016 KFL(JT)=K(IE(JT),2)
65017 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
65018 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
65020 PMQ(JT)=PYMASS(KFL(JT))
65024 C...Closed string: random initial breakup flavour, pT and vertex.
65026 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65028 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
65029 C.. Closed string: first vertex diq attempt => enforced second
65031 IF(IABS(KFL(1)).GT.10)THEN
65036 IF(IBMO.EQ.1) MSTU(121)=-1
65038 CALL PYPTDI(KFL(1),PX(1),PY(1))
65041 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
65042 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
65043 ZR=PR3/(Z*P(N+NR+1,5)**2)
65044 IF(ZR.GE.1D0) GOTO 780
65047 PMQ(JT)=PYMASS(KFL(JT))
65048 GAM(JT)=PR3*(1D0-Z)/Z
65049 IN1=N+NR+3+4*(JT/2)*(NS-1)
65052 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
65055 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
65061 PM2QMO(JT)=PMQ(JT)**2
65062 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
65065 C...Find initial transverse directions (i.e. spacelike four-vectors).
65067 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
65076 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
65077 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
65078 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
65079 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
65080 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
65081 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
65082 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
65083 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
65084 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
65086 DHCX1=DFOUR(3,1)/DHC12
65087 DHCX2=DFOUR(3,2)/DHC12
65088 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
65089 DHCY1=DFOUR(4,1)/DHC12
65090 DHCY2=DFOUR(4,2)/DHC12
65091 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
65092 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
65094 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
65096 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
65101 P(IN3+2,J)=P(IN3,J)
65102 P(IN3+3,J)=P(IN3+1,J)
65107 C...Remove energy used up in junction string fragmentation.
65108 IF(MJU(1)+MJU(2).GT.0) THEN
65110 IF(NJS(JT).EQ.0) GOTO 860
65112 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
65116 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
65117 WMIN=PARJST+PMQ(1)+PMQ(2)
65118 WREM2=FOUR(N+NRS,N+NRS)
65119 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
65121 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
65126 C...Produce new particle: side, origin.
65128 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
65129 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
65130 IF(MSTU(21).GE.1) RETURN
65132 C.. New side priority for popcorn systems
65133 IF(MSTU(121).LE.0)THEN
65135 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
65136 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
65140 IRANK(JT)=IRANK(JT)+1
65145 C...Generate flavour, hadron and pT.
65147 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
65148 IF(K(I,2).EQ.0) GOTO 710
65150 IF(MSTU(121).EQ.-1) GOTO 910
65151 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
65152 &IABS(KFL(3)).GT.10) THEN
65153 IF(PYR(0).GT.PARJ(19)) GOTO 880
65155 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65157 P(I,5)=PYMASS(K(I,2))
65158 CALL PYPTDI(KFL(JT),PX(3),PY(3))
65159 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
65161 C...Final hadrons for small invariant mass.
65163 PMQ(3)=PYMASS(KFL(3))
65165 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
65166 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
65167 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
65168 &WMIN-0.5D0*PARJ(36)*PMQ(3)
65169 WREM2=FOUR(N+NRS,N+NRS)
65170 IF(WREM2.LT.0.10D0) GOTO 710
65171 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
65172 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
65174 C...Choose z, which gives Gamma. Shift z for heavy flavours.
65175 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
65176 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
65177 &MSTU(90).LT.8) THEN
65178 MSTU(90)=MSTU(90)+1
65179 MSTU(90+MSTU(90))=I
65180 PARU(90+MSTU(90))=Z
65184 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
65185 &MOD(KFL2A/1000,10)).GE.4) THEN
65186 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65187 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
65188 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
65189 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65190 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
65192 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
65194 C.. MOPS baryon model modification
65195 XTMO3=(1D0-Z)*XTMO(JT)
65196 IF(IABS(KFL(3)).LE.10) NRVMO=0
65197 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
65201 IF(IABS(KFL(JT)).LE.10)THEN
65202 XBMO=MIN(XTMO3,1D0-(2D-10))
65205 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
65206 GTSTMO=1D0-PARF(192)**PGMO
65208 IF(IRANK(JT).EQ.1) THEN
65213 IF(XBMO.LT.1D0-(1D-10))THEN
65214 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
65215 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
65218 IF(MSTJ(12).GE.5)THEN
65219 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
65220 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
65221 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
65226 C.. MOPS Accepting popcorn system hadron.
65227 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
65228 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
65230 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
65232 & '(PYSTRF:) no more memory left in PYJETS')
65233 IF(MSTU(21).GE.1) RETURN
65245 DO 890 LINE=1,I-N-NR
65246 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
65247 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
65254 C..Reject popcorn system, flag=-1 if enforcing new one
65256 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
65261 C..Lift restoring string outside MOPS block
65262 910 IF(MSTU(121).LT.0) THEN
65263 IF(MSTU(121).EQ.-2) MSTU(121)=0
65266 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
65277 DO 920 LINE=1,I-N-NR
65278 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
65279 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
65287 C.. MOPS end of modification
65293 C...Stepping within or from 'low' string region easy.
65294 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
65295 &P(IN(1),5)**2.GE.PR(JT)) THEN
65296 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
65297 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
65299 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
65302 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
65303 P(IN(JR)+2,4)=P(IN(JR)+2,3)
65306 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
65307 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
65308 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65314 C...Find new transverse directions (i.e. spacelike string vectors).
65315 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
65316 &IN(1).GT.IN(2)) GOTO 710
65317 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
65324 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
65325 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
65327 IF(DHC12.LE.1D-2) THEN
65328 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65334 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
65335 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
65336 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
65337 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
65338 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
65339 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
65340 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
65341 DHCX1=DFOUR(3,1)/DHC12
65342 DHCX2=DFOUR(3,2)/DHC12
65343 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
65344 DHCY1=DFOUR(4,1)/DHC12
65345 DHCY2=DFOUR(4,2)/DHC12
65346 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
65347 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
65349 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
65351 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
65354 C...Express pT with respect to new axes, if sensible.
65355 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
65356 & FOUR(IN(3*JT+3)+1,IN(3)))
65357 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
65358 & FOUR(IN(3*JT+3)+1,IN(3)+1))
65359 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
65365 C...Sum up known four-momentum. Gives coefficients for m2 expression.
65368 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
65369 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
65370 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
65371 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
65373 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
65374 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
65378 DHM(2)=2D0*FOUR(I,IN(1))
65379 DHM(3)=2D0*FOUR(I,IN(2))
65380 DHM(4)=2D0*FOUR(IN(1),IN(2))
65382 C...Find coefficients for Gamma expression.
65383 DO 1030 IN2=IN(1)+1,IN(2),4
65384 DO 1020 IN1=IN(1),IN2-1,4
65385 DHC=2D0*FOUR(IN1,IN2)
65386 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
65387 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
65388 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
65389 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
65393 C...Solve (m2, Gamma) equation system for energies taken.
65394 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
65395 IF(ABS(DHS1).LT.1D-4) GOTO 710
65396 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
65397 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
65398 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
65399 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
65400 &ABS(DHS1)-DHS2/DHS1)
65401 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
65402 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
65403 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
65405 C...Step to new region if necessary.
65406 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
65407 P(IN(JR)+2,4)=P(IN(JR)+2,3)
65410 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
65411 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
65412 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65417 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
65418 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65424 C...Four-momentum of particle. Remaining quantities. Loop back.
65426 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
65427 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
65429 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
65430 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
65432 IF(P(I,4).LT.P(I,5)) GOTO 710
65438 IF(IN(3).NE.IN(3*JT+3)) THEN
65440 P(IN(3*JT+3),J)=P(IN(3),J)
65441 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
65446 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
65447 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
65449 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65453 C...Final hadron: side, flavour, hadron, mass.
65459 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
65460 IF(K(I,2).EQ.0) GOTO 710
65461 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
65463 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65465 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65467 P(I,5)=PYMASS(K(I,2))
65468 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65470 C...Final two hadrons: find common setup of four-vectors.
65472 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
65473 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
65474 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
65475 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
65476 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
65477 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
65478 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
65479 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
65480 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
65481 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
65484 C...Solve kinematics for final two hadrons, if possible.
65485 WREM2=2D0*DHR1*DHR2*DHC12
65486 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
65487 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
65488 IF(FD.GE.1D0) GOTO 710
65489 FA=WREM2+PR(JT)-PR(JR)
65490 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
65492 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
65493 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
65494 FB=SIGN(FB,JS*(PYR(0)-PREV))
65497 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
65498 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
65499 &4D0*WREM2*PR(JT))),DBLE(JS))
65501 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
65502 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
65503 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
65504 P(I,J)=P(N+NRS,J)-P(I-1,J)
65506 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
65507 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
65508 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
65509 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
65511 IF(NTRYFN.LT.100) GOTO 140
65512 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
65515 C...Mark jets as fragmented and give daughter pointers.
65517 DO 1100 I=NSAV+1,NSAV+NP
65520 IF(MSTU(16).NE.2) THEN
65529 C...Document string system. Move up particles.
65540 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
65544 K(I,J)=K(I+NRS-1,J)
65545 P(I,J)=P(I+NRS-1,J)
65550 DO 1140 IZ=MSTU90+1,MSTU91
65551 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
65552 PARU9T(IZ)=PARU(90+IZ)
65556 C...Order particles in rank along the chain. Update mother pointer.
65559 K(I-NSAV+N,J)=K(I,J)
65560 P(I-NSAV+N,J)=P(I,J)
65564 DO 1190 I=N+1,2*N-NSAV
65565 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
65571 IF(MSTU(16).NE.2) K(I1,3)=NSAV
65572 DO 1180 IZ=MSTU90+1,MSTU91
65573 IF(MSTU9T(IZ).EQ.I) THEN
65574 MSTU(90)=MSTU(90)+1
65575 MSTU(90+MSTU(90))=I1
65576 PARU(90+MSTU(90))=PARU9T(IZ)
65580 DO 1220 I=2*N-NSAV,N+1,-1
65581 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
65587 IF(MSTU(16).NE.2) K(I1,3)=NSAV
65588 DO 1210 IZ=MSTU90+1,MSTU91
65589 IF(MSTU9T(IZ).EQ.I) THEN
65590 MSTU(90)=MSTU(90)+1
65591 MSTU(90+MSTU(90))=I1
65592 PARU(90+MSTU(90))=PARU9T(IZ)
65597 C...Boost back particle system. Set production vertices.
65600 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
65604 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
65605 IF(P(I,3).GT.0D0) THEN
65606 HHPEZ=(P(I,4)+P(I,3))*HHBZ
65607 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
65608 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65610 HHPEZ=(P(I,4)-P(I,3))/HHBZ
65611 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
65612 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65625 C*********************************************************************
65628 C...From three given input vectors in PJU the boost VJU from
65629 C...the "lab frame" to the junction rest frame is constructed.
65631 SUBROUTINE PYJURF(PJU,VJU)
65633 C...Double precision and integer declarations.
65634 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65635 IMPLICIT INTEGER(I-N)
65637 C...Input, output and local arrays.
65638 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
65639 DATA TWOPI/6.283186D0/
65641 C...Calculate masses and other invariants.
65643 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
65645 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
65646 PSUM(5)=SQRT(PSUM2)
65649 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
65650 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
65654 C...Pick I to be most massive parton and J to be the one closest to I.
65657 IF(A(2,2).GT.A(1,1)) I=2
65658 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
65662 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
65673 C...Trivial find new parton energies if all three partons are massless.
65674 IF(PMI2.LT.1D-4) THEN
65675 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
65676 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
65677 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
65679 C...Else find momentum range for parton I and values at extremes.
65685 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
65686 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
65687 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
65688 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
65689 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
65690 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
65691 HI=PEIMAX**2-0.25D0*PAIMAX**2
65692 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
65693 & 0.5D0*PAIMAX*AIJ)/HI
65694 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
65695 & 0.5D0*PAIMAX*AIK)/HI
65696 PEJMAX=SQRT(PAJMAX**2+PMJ2)
65697 PEKMAX=SQRT(PAKMAX**2+PMK2)
65698 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
65700 C...If unexpected values at upper endpoint then pick another parton.
65701 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
65703 IF(A(I1,I1).GE.1D-4) THEN
65709 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
65715 C..Start binary + linear search to find solution inside range.
65719 PAI=0.5D0*(PAIMIN+PAIMAX)
65722 C...Derive momentum of other two partons and distance to root.
65723 PEI=SQRT(PAI**2+PMI2)
65724 HI=PEI**2-0.25D0*PAI**2
65725 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
65726 PEJ=SQRT(PAJ**2+PMJ2)
65727 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
65728 PEK=SQRT(PAK**2+PMK2)
65729 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
65731 C...Pick next I momentum to explore, hopefully closer to root.
65732 IF(FNOW.GT.0D0) THEN
65741 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
65743 PAI=0.5D0*(PAIMIN+PAIMAX)
65745 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
65746 & ABS(FNOW).GT.1D-12*PSUM2) THEN
65747 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
65752 C...Now know energies in junction rest frame.
65757 C...Boost (copy of) partons to their rest frame.
65758 VXCM=-PSUM(1)/PSUM(5)
65759 VYCM=-PSUM(2)/PSUM(5)
65760 VZCM=-PSUM(3)/PSUM(5)
65761 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
65763 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
65764 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
65765 PCM(I,1)=PJU(I,1)+FAC2*VXCM
65766 PCM(I,2)=PJU(I,2)+FAC2*VYCM
65767 PCM(I,3)=PJU(I,3)+FAC2*VZCM
65768 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
65769 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
65772 C...Construct difference vectors and boost to junction rest frame.
65774 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
65775 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
65777 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
65778 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
65779 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
65780 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
65781 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
65782 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
65783 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
65784 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
65785 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
65786 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
65787 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
65789 C...Add two boosts, giving final result.
65790 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
65791 VJU(1)=VXJU+FCM*VXCM
65792 VJU(2)=VYJU+FCM*VYCM
65793 VJU(3)=VZJU+FCM*VZCM
65794 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
65797 C...In case of error in reconstruction: revert to CM frame of system.
65798 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
65799 &(PCM(1,5)*PCM(2,5))
65800 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
65801 &(PCM(1,5)*PCM(3,5))
65802 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
65803 &(PCM(2,5)*PCM(3,5))
65804 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
65805 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
65807 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
65808 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
65809 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
65810 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
65811 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
65812 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
65813 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
65815 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
65816 &(PCM(1,5)*PCM(2,5))
65817 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
65818 &(PCM(1,5)*PCM(3,5))
65819 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
65820 &(PCM(2,5)*PCM(3,5))
65821 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
65822 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
65823 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
65833 C*********************************************************************
65836 C...Handles the fragmentation of a jet system (or a single
65837 C...jet) according to independent fragmentation models.
65839 SUBROUTINE PYINDF(IP)
65841 C...Double precision and integer declarations.
65842 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65843 IMPLICIT INTEGER(I-N)
65844 INTEGER PYK,PYCHGE,PYCOMP
65846 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65847 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65848 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65849 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
65851 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
65852 &KFLO(2),PXO(2),PYO(2),WO(2)
65854 C.. MOPS error message
65855 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
65856 &' are not treated as expected in independent fragmentation')
65858 C...Reset counters. Identify parton system and take copy. Check flavour.
65868 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
65869 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
65870 IF(MSTU(21).GE.1) RETURN
65872 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
65874 IF(KC.EQ.0) GOTO 110
65875 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
65876 IF(KQ.EQ.0) GOTO 110
65878 IF(KQ.NE.2) KQSUM=KQSUM+KQ
65880 K(NSAV+NJET,J)=K(I,J)
65881 P(NSAV+NJET,J)=P(I,J)
65882 DPS(J)=DPS(J)+P(I,J)
65885 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
65886 &K(I+1,1).EQ.2)) GOTO 110
65887 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
65888 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
65889 IF(MSTU(21).GE.1) RETURN
65892 C...Boost copied system to CM frame. Find CM energy and sum flavours.
65895 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
65896 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
65902 DO 140 I=NSAV+1,NSAV+NJET
65906 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
65907 ELSEIF(KFA.GT.1000) THEN
65908 KFLA=MOD(KFA/1000,10)
65909 KFLB=MOD(KFA/100,10)
65910 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
65911 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
65915 C...Loop over attempts made. Reset counters.
65918 IF(NTRY.GT.200) THEN
65919 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
65920 IF(MSTU(21).GE.1) RETURN
65930 C...Loop over jets to be fragmented.
65931 DO 230 IP1=NSAV+1,NSAV+NJET
65936 C...Initial flavour and momentum values. Jet along +z axis.
65937 KFLH=IABS(K(IP1,2))
65938 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
65940 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
65942 C...Initial values for quark or diquark jet.
65943 170 IF(IABS(K(IP1,2)).NE.21) THEN
65946 CALL PYPTDI(0,PXO(1),PYO(1))
65949 C...Initial values for gluon treated like random quark jet.
65950 ELSEIF(MSTJ(2).LE.2) THEN
65952 IF(MSTJ(2).EQ.2) MSTJ(91)=1
65953 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65954 CALL PYPTDI(0,PXO(1),PYO(1))
65957 C...Initial values for gluon treated like quark-antiquark jet pair,
65958 C...sharing energy according to Altarelli-Parisi splitting function.
65961 IF(MSTJ(2).EQ.4) MSTJ(91)=1
65962 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65964 CALL PYPTDI(0,PXO(1),PYO(1))
65967 WO(1)=WF*PYR(0)**(1D0/3D0)
65971 C...Initial values for rank, flavour, pT and W+.
65981 C...New hadron. Generate flavour and hadron species.
65983 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
65984 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
65985 IF(MSTU(21).GE.1) RETURN
65992 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
65993 IF(K(I,2).EQ.0) GOTO 180
65994 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
65995 IF(PYR(0).GT.PARJ(19)) GOTO 200
65998 C...Find hadron mass. Generate four-momentum.
65999 P(I,5)=PYMASS(K(I,2))
66000 CALL PYPTDI(KFL1,PX2,PY2)
66003 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
66004 CALL PYZDIS(KFL1,KFL2,PR,Z)
66006 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
66008 MSTU(90)=MSTU(90)+1
66009 MSTU(90+MSTU(90))=I
66010 PARU(90+MSTU(90))=Z
66012 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
66013 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
66014 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
66015 & P(I,3).LE.0.001D0) THEN
66016 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
66022 C...Remaining flavour and momentum.
66031 C...Check if pL acceptable. Go back for new hadron if enough energy.
66032 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
66034 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
66036 IF(W.GT.PARJ(31)) GOTO 190
66039 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
66040 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
66042 C...Rotate jet to new direction.
66043 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
66044 PHI=PYANGL(P(IP1,1),P(IP1,2))
66046 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
66047 K(K(IP1,3),4)=NSAV1+1
66050 C...End of jet generation loop. Skip conservation in some cases.
66052 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
66053 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
66055 C...Subtract off produced hadron flavours, finished if zero.
66056 DO 240 I=NSAV+NJET+1,N
66058 KFLA=MOD(KFA/1000,10)
66059 KFLB=MOD(KFA/100,10)
66060 KFLC=MOD(KFA/10,10)
66062 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
66063 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
66065 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
66066 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
66067 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
66070 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66071 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66072 IF(NREQ.EQ.0) GOTO 320
66074 C...Take away flavour of low-momentum particles until enough freedom.
66078 DO 260 I=NSAV+NJET+1,N
66079 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
66080 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
66081 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
66083 IF(IREM.EQ.0) GOTO 150
66085 KFA=IABS(K(IREM,2))
66086 KFLA=MOD(KFA/1000,10)
66087 KFLB=MOD(KFA/100,10)
66088 KFLC=MOD(KFA/10,10)
66089 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
66090 IF(K(IREM,1).EQ.8) GOTO 250
66092 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
66093 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
66094 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
66096 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
66097 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
66098 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
66101 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66102 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66103 IF(NREQ.GT.NREM) GOTO 250
66104 DO 270 I=NSAV+NJET+1,N
66105 IF(K(I,1).EQ.8) K(I,1)=1
66108 C...Find combination of existing and new flavours for hadron.
66110 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
66111 IF(NREQ.LT.NREM) NFET=1
66112 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
66114 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
66115 KFLF(J)=ISIGN(1,NFL(1))
66116 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
66117 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
66119 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
66121 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
66122 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
66123 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
66124 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
66125 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
66126 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
66127 IF(NFET.LE.2) KFLF(3)=0
66128 IF(KFLF(3).NE.0) THEN
66129 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
66130 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
66131 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
66132 & KFLFC=KFLFC+ISIGN(2,KFLFC)
66136 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
66137 IF(KF.EQ.0) GOTO 280
66138 DO 300 J=1,MAX(2,NFET)
66139 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
66142 C...Store hadron at random among free positions.
66143 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
66144 DO 310 I=NSAV+NJET+1,N
66145 IF(K(I,1).EQ.7) NPOS=NPOS-1
66146 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
66149 P(I,5)=PYMASS(K(I,2))
66150 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66153 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66154 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66155 IF(NREM.GT.0) GOTO 280
66157 C...Compensate for missing momentum in global scheme (3 options).
66158 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
66161 DO 330 I=NSAV+NJET+1,N
66162 PSI(J)=PSI(J)+P(I,J)
66165 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
66167 DO 350 I=NSAV+NJET+1,N
66168 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
66169 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
66170 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
66171 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
66173 DO 370 I=NSAV+NJET+1,N
66174 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
66175 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
66176 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
66177 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
66179 P(I,J)=P(I,J)-PSI(J)*PW/PWS
66181 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66184 C...Compensate for missing momentum withing each jet separately.
66185 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
66186 DO 390 I=N+1,N+NJET
66192 DO 410 I=NSAV+NJET+1,N
66195 K(IR2,1)=K(IR2,1)+1
66196 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
66197 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
66199 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
66201 P(IR2,4)=P(IR2,4)+P(I,4)
66202 P(IR2,5)=P(IR2,5)+PLS
66205 DO 420 I=N+1,N+NJET
66206 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
66208 DO 440 I=NSAV+NJET+1,N
66211 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
66212 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
66214 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
66217 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66221 C...Scale momenta for energy conservation.
66222 IF(MOD(MSTJ(3),5).NE.0) THEN
66226 DO 450 I=NSAV+NJET+1,N
66229 PQS=PQS+P(I,5)**2/P(I,4)
66231 IF(PMS.GE.PECM) GOTO 150
66234 PFAC=(PECM-PQS)/(PES-PQS)
66237 DO 480 I=NSAV+NJET+1,N
66241 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66243 PQS=PQS+P(I,5)**2/P(I,4)
66245 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
66248 C...Origin of produced particles and parton daughter pointers.
66249 490 DO 500 I=NSAV+NJET+1,N
66250 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
66251 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
66253 DO 510 I=NSAV+1,NSAV+NJET
66256 IF(MSTU(16).NE.2) THEN
66260 K(I1,4)=K(I1,4)-NJET+1
66261 K(I1,5)=K(I1,5)-NJET+1
66262 IF(K(I1,5).LT.K(I1,4)) THEN
66269 C...Document independent fragmentation system. Remove copy of jets.
66280 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
66282 DO 540 I=NSAV+NJET,N
66284 K(I-NJET+1,J)=K(I,J)
66285 P(I-NJET+1,J)=P(I,J)
66286 V(I-NJET+1,J)=V(I,J)
66290 DO 550 IZ=MSTU90+1,MSTU(90)
66291 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
66294 C...Boost back particle system. Set production vertices.
66295 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
66296 &DPS(2)/DPS(4),DPS(3)/DPS(4))
66306 C*********************************************************************
66309 C...Handles the decay of unstable particles.
66311 SUBROUTINE PYDECY(IP)
66313 C...Double precision and integer declarations.
66314 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
66315 IMPLICIT INTEGER(I-N)
66316 INTEGER PYK,PYCHGE,PYCOMP
66318 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
66319 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
66320 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
66321 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
66322 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
66324 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
66325 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
66327 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
66329 C...Functions: momentum in two-particle decays and four-product.
66330 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
66331 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)
66333 C...Initial values.
66337 KFS=ISIGN(1,K(IP,2))
66341 C...Choose lifetime and determine decay vertex.
66342 IF(K(IP,1).EQ.5) THEN
66344 ELSEIF(K(IP,1).NE.4) THEN
66345 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
66348 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
66351 C...Determine whether decay allowed or not.
66353 IF(MSTJ(22).EQ.2) THEN
66354 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
66355 ELSEIF(MSTJ(22).EQ.3) THEN
66356 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
66357 ELSEIF(MSTJ(22).EQ.4) THEN
66358 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
66359 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
66361 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
66366 C...Interface to external tau decay library (for tau polarization).
66367 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
66369 C...Starting values for pointers and momenta.
66373 PCMTAU(J)=P(ITAU,J)
66376 C...Iterate to find position and code of mother of tau.
66378 120 IMTAU=K(IMTAU,3)
66380 IF(IMTAU.EQ.0) THEN
66381 C...If no known origin then impossible to do anything further.
66385 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
66386 C...If tau -> tau + gamma then add gamma energy and loop.
66387 IF(K(K(IMTAU,4),2).EQ.22) THEN
66389 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
66391 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
66393 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
66398 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
66399 C...If coming from weak decay of hadron then W is not stored in record,
66400 C...but can be reconstructed by adding neutrino momentum.
66401 KFORIG=-ISIGN(24,K(ITAU,2))
66403 DO 160 II=K(IMTAU,4),K(IMTAU,5)
66404 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
66406 PCMTAU(J)=PCMTAU(J)+P(II,J)
66412 C...If coming from resonance decay then find latest copy of this
66413 C...resonance (may not completely agree).
66416 DO 170 II=IMTAU+1,IP-1
66417 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
66418 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
66421 PCMTAU(J)=P(IORIG,J)
66425 C...Boost tau to rest frame of production process (where known)
66426 C...and rotate it to sit along +z axis.
66428 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
66430 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
66431 & -DBETAU(2),-DBETAU(3))
66432 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
66433 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
66434 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
66435 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
66437 C...Call tau decay routine (if meaningful) and fill extra info.
66438 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
66439 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
66440 DO 200 II=NSAV+1,NSAV+NDECAY
66449 C...Boost back decay tau and decay products.
66453 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
66454 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
66455 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
66456 & DBETAU(2),DBETAU(3))
66458 C...Skip past ordinary tau decay treatment.
66466 C...B-Bbar mixing: flip sign of meson appropriately.
66468 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
66470 IF(KFA.EQ.531) XBBMIX=PARJ(77)
66471 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
66472 IF(MMIX.EQ.1) KFS=-KFS
66475 C...Check existence of decay channels. Particle/antiparticle rules.
66477 IF(MDCY(KC,2).GT.0) THEN
66478 MDMDCY=MDME(MDCY(KC,2),2)
66479 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
66481 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
66482 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
66485 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
66486 IF(KCHG(KC,3).EQ.0) THEN
66489 IF(PYR(0).GT.0.5D0) KFS=-KFS
66490 ELSEIF(KFS.GT.0) THEN
66498 C...Sum branching ratios of allowed decay channels.
66501 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
66502 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
66503 & KFSN*MDME(IDL,1).NE.3) GOTO 230
66504 IF(MDME(IDL,2).GT.100) GOTO 230
66506 BRSU=BRSU+BRAT(IDL)
66509 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
66513 C...Select decay channel among allowed ones.
66514 240 RBR=BRSU*PYR(0)
66517 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
66518 &KFSN*MDME(IDL,1).NE.3) THEN
66519 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
66520 ELSEIF(MDME(IDL,2).GT.100) THEN
66521 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
66525 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
66528 C...Start readout of decay channel: matrix element, reset counters.
66531 IF(MOD(NTRY,200).EQ.0) THEN
66532 WRITE(CIDC,'(I4)') IDC
66533 C...Do not print warning for some well-known special cases.
66534 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
66535 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
66539 IF(NTRY.GT.1000) THEN
66540 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
66541 IF(MSTU(21).GE.1) RETURN
66547 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
66550 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
66552 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
66558 IF(KFA.GT.80) MHADDY=1
66559 C.. Random flavour and popcorn system memory.
66565 C...Read out decay products. Convert to standard flavour code.
66567 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
66569 IF(JT.LE.5) KP=KFDP(IDC,JT)
66570 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
66571 IF(KP.EQ.0) GOTO 280
66574 IF(KPA.GT.80) MHADDY=1
66575 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
66577 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
66579 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
66580 KFP=-KFS*MOD(KFA/10,10)
66581 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
66582 KFP=KFS*(100*MOD(KFA/10,100)+3)
66583 ELSEIF(KPA.EQ.81) THEN
66584 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
66585 ELSEIF(KP.EQ.82) THEN
66586 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
66587 IF(KFP.EQ.0) GOTO 260
66591 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
66592 ELSEIF(KP.EQ.-82) THEN
66595 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
66597 C...Add decay product to event record or to quark flavour list.
66600 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
66603 C...set rndmflav popcorn system pointer
66604 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
66606 PSQ=PSQ+PYMASS(KFLO(NQ))
66607 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
66608 & MOD(NQ,2).EQ.1) THEN
66613 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
66614 IF(K(I,2).EQ.0) GOTO 260
66616 P(I,5)=PYMASS(K(I,2))
66621 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
66622 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
66624 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
66625 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
66635 C...Check masses for resonance decays.
66636 IF(MHADDY.EQ.0) THEN
66637 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
66640 C...Choose decay multiplicity in phase space model.
66641 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
66643 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
66644 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
66646 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
66647 IF(IRNDMO.EQ.0) THEN
66650 ELSEIF(IRNDMO.EQ.1) THEN
66655 IF(NTRY.GT.1000) THEN
66656 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
66657 IF(MSTU(21).GE.1) RETURN
66659 IF(MMAT.LE.20) THEN
66660 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
66661 & SIN(PARU(2)*PYR(0))
66662 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
66663 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
66664 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
66665 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
66666 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
66670 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
66672 IF(MSTU(121).GT.MSTU(125)) GOTO 300
66674 C...Form hadrons from flavour content.
66678 IF(ND.EQ.NP+NQ/2) GOTO 330
66679 DO 320 I=N+NP+1,N+ND-NQ/2
66680 C.. Stick to started popcorn system, else pick side at random
66682 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
66683 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
66684 IF(K(I,2).EQ.0) GOTO 300
66685 MSTU(125)=MSTU(125)-1
66687 IF(MSTU(121).GT.0) JTMO=JT
66693 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
66694 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
66695 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
66698 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
66699 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
66700 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
66701 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
66703 C...Check that sum of decay product masses not too large.
66705 DO 340 I=N+NP+1,N+ND
66710 P(I,5)=PYMASS(K(I,2))
66713 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
66715 C...Rescale energy to subtract off spectator quark mass.
66716 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
66717 & .AND.NP.GE.3) THEN
66719 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
66721 P(N+NP,J)=PQT*PV(1,J)
66722 PV(1,J)=(1D0-PQT)*PV(1,J)
66724 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
66728 C...Fully specified final state: check mass broadening effects.
66730 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
66734 C...Determine position of grandmother, number of sisters.
66740 IF(IM.LT.0.OR.IM.GE.IP) IM=0
66741 IF(IM.NE.0) KFAM=IABS(K(IM,2))
66743 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
66744 IF(K(IL,3).EQ.IM) NM=NM+1
66745 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
66747 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
66748 & MOD(KFAM/1000,10).NE.0) NM=0
66750 KFAS=IABS(K(ISIS,2))
66751 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
66752 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
66757 C...Kinematics of one-particle decays.
66765 C...Calculate maximum weight ND-particle decay.
66768 WTMAX=1D0/WTCOR(ND-2)
66769 PMAX=PV(1,5)-PS+P(N+ND,5)
66771 DO 380 IL=ND-1,1,-1
66772 PMAX=PMAX+P(N+IL,5)
66773 PMIN=PMIN+P(N+IL+1,5)
66774 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
66778 C...Find virtual gamma mass in Dalitz decay.
66779 390 IF(ND.EQ.2) THEN
66780 ELSEIF(MMAT.EQ.2) THEN
66781 PMES=4D0*PMAS(11,1)**2
66782 PMRHO2=PMAS(131,1)**2
66783 PGRHO2=PMAS(131,2)**2
66784 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
66785 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
66786 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
66787 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
66788 IF(WT.LT.PYR(0)) GOTO 400
66789 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
66791 C...M-generator gives weight. If rejected, try again.
66796 DO 420 IL2=IL1-1,1,-1
66797 IF(RSAV.LE.RORD(IL2)) GOTO 430
66798 RORD(IL2+1)=RORD(IL2)
66800 430 RORD(IL2+1)=RSAV
66804 DO 450 IL=ND-1,1,-1
66805 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
66807 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
66809 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
66812 C...Perform two-particle decays in respective CM frame.
66813 460 DO 480 IL=1,ND-1
66814 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
66815 UE(3)=2D0*PYR(0)-1D0
66817 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
66818 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
66821 PV(IL+1,J)=-PA*UE(J)
66823 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
66824 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
66827 C...Lorentz transform decay products to lab frame.
66831 DO 530 IL=ND-1,1,-1
66833 BE(J)=PV(IL,J)/PV(IL,4)
66835 GA=PV(IL,4)/PV(IL,5)
66837 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
66839 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
66841 P(I,4)=GA*(P(I,4)+BEP)
66845 C...Check that no infinite loop in matrix element weight.
66847 IF(NTRY.GT.800) GOTO 560
66849 C...Matrix elements for omega and phi decays.
66851 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
66852 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
66853 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
66854 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
66856 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
66857 ELSEIF(MMAT.EQ.2) THEN
66858 FOUR12=FOUR(N+1,N+2)
66859 FOUR13=FOUR(N+1,N+3)
66860 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
66861 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
66862 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
66864 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
66865 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
66866 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
66867 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
66869 FOUR12=FOUR(IP,N+1)
66870 FOUR02=FOUR(IM,N+1)
66874 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
66875 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
66876 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
66877 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
66878 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
66879 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
66881 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
66882 ELSEIF(MMAT.EQ.4) THEN
66883 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
66884 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
66885 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
66886 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
66887 & ((1D0-HX3)/(HX1*HX2))**2
66888 IF(WT.LT.2D0*PYR(0)) GOTO 390
66889 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
66892 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
66893 ELSEIF(MMAT.EQ.41) THEN
66894 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
66895 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
66896 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
66897 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
66899 C...Matrix elements for weak decays (only semileptonic for c and b)
66900 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
66901 & .AND.ND.EQ.3) THEN
66902 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
66903 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
66904 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
66905 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
66909 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
66912 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
66913 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
66914 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
66917 C...Scale back energy and reattach spectator.
66918 560 IF(MREM.EQ.1) THEN
66920 PV(1,J)=PV(1,J)/(1D0-PQT)
66926 C...Low invariant mass for system with spectator quark gives particle,
66927 C...not two jets. Readjust momenta accordingly.
66928 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
66930 PM2=PYMASS(K(N+2,2))
66932 PM3=PYMASS(K(N+3,2))
66933 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
66934 & (PARJ(32)+PM2+PM3)**2) GOTO 630
66937 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
66938 IF(K(N+2,2).EQ.0) GOTO 260
66939 P(N+2,5)=PYMASS(K(N+2,2))
66940 PS=P(N+1,5)+P(N+2,5)
66945 ELSEIF(MMAT.EQ.44) THEN
66947 PM3=PYMASS(K(N+3,2))
66949 PM4=PYMASS(K(N+4,2))
66950 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
66951 & (PARJ(32)+PM3+PM4)**2) GOTO 600
66954 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
66955 IF(K(N+3,2).EQ.0) GOTO 260
66956 P(N+3,5)=PYMASS(K(N+3,2))
66958 P(N+3,J)=P(N+3,J)+P(N+4,J)
66960 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)
66961 HA=P(N+1,4)**2-P(N+2,4)**2
66962 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
66963 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
66964 & (P(N+1,3)-P(N+2,3))**2
66965 HD=(PV(1,4)-P(N+3,4))**2
66966 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
66969 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
66971 PCOR=HH*(P(N+1,J)-P(N+2,J))
66972 P(N+1,J)=P(N+1,J)+PCOR
66973 P(N+2,J)=P(N+2,J)-PCOR
66975 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)
66976 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)
66980 C...Check invariant mass of W jets. May give one particle or start over.
66981 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
66982 &.AND.IABS(K(N+1,2)).LT.10) THEN
66983 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
66985 PM1=PYMASS(K(N+1,2))
66987 PM2=PYMASS(K(N+2,2))
66988 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
66989 KFLDUM=INT(1.5D0+PYR(0))
66990 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
66991 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
66992 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
66993 PSM=PYMASS(KF1)+PYMASS(KF2)
66994 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
66995 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
66996 IF(MMAT.EQ.48) GOTO 390
66997 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
67000 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
67001 IF(K(N+1,2).EQ.0) GOTO 260
67002 P(N+1,5)=PYMASS(K(N+1,2))
67005 PS=P(N+1,5)+P(N+2,5)
67006 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
67013 C...Phase space decay of partons from W decay.
67014 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
67020 PV(1,J)=P(N+1,J)+P(N+2,J)
67029 PSQ=PYMASS(KFLO(1))
67031 PSQ=PSQ+PYMASS(KFLO(2))
67036 C...Boost back for rapidly moving particle.
67040 BE(J)=P(IP,J)/P(IP,4)
67044 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
67046 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
67048 P(I,4)=GA*(P(I,4)+BEP)
67052 C...Fill in position of decay vertex.
67060 C...Set up for parton shower evolution from jets.
67061 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
67065 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
67066 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
67067 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
67068 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
67069 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
67070 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
67072 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
67075 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
67076 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
67077 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
67078 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
67080 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
67081 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
67084 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
67085 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
67086 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
67087 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
67089 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
67090 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
67092 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
67097 KCP=PYCOMP(K(NSAV+1,2))
67098 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
67100 IF(KQP.LT.0) JCON=5
67101 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
67102 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
67103 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
67104 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
67106 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
67109 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
67110 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
67111 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
67112 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
67116 C...Mark decayed particle; special option for B-Bbar mixing.
67117 IF(K(IP,1).EQ.5) K(IP,1)=15
67118 IF(K(IP,1).LE.10) K(IP,1)=11
67119 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
67127 C*********************************************************************
67130 C...Handles flavour production in the decay of unstable particles
67131 C...and small string clusters.
67133 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
67135 C...Double precision and integer declarations.
67136 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67137 IMPLICIT INTEGER(I-N)
67138 INTEGER PYK,PYCHGE,PYCOMP
67140 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67141 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67142 SAVE /PYDAT1/,/PYDAT2/
67145 C.. Call PYKFDI directly if no popcorn option is on
67146 IF(MSTJ(12).LT.2) THEN
67147 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
67154 IF(KFL1.EQ.0) RETURN
67159 NMAX=MIN(MSTU(125),10)
67161 C.. Identify rank 0 cluster qq
67163 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
67166 C.. Join jets: Fails if store not empty
67167 IF(MSTU(121).GT.0) THEN
67171 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
67172 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
67173 C.. Pick popcorn meson from store, return same qq, decrease store
67174 KF=MSTU(NSTO+MSTU(121))
67176 MSTU(121)=MSTU(121)-1
67178 C.. Generate new flavour. Then done if no diquark is generated
67179 100 CALL PYKFDI(KFL1,0,KFL3,KF)
67180 IF(MSTU(121).EQ.-1) GOTO 100
67182 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
67184 C.. Simple case if no dynamical popcorn suppressions are considered
67185 IF(MSTJ(12).LT.4) THEN
67186 IF(MSTU(121).EQ.0) RETURN
67189 CALL PYKFDI(KFPREV,0,KFL3,KFM)
67190 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
67191 IF(IABS(KFL3).LE.10)THEN
67198 C test output qq against fake Gamma, then return if no popcorn.
67201 CALL PYZDIS(1,2103,5D0,Z)
67203 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
67208 IF(MSTU(121).EQ.0) RETURN
67210 C..Set store size memory. Pick fake dynamical variables of qq.
67212 CALL PYPTDI(1,PX3,PY3)
67218 C.. Pick next popcorn meson, test with fake dynamical variables
67222 CALL PYKFDI(KFPREV,0,KFL3,KFM)
67223 IF(MSTU(121).EQ.-1) GOTO 100
67224 CALL PYPTDI(KFL3,PX3,PY3)
67225 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
67226 CALL PYZDIS(KFPREV,KFL3,PM,Z)
67233 IF(MSTJ(12).GT.4)THEN
67234 POPMN=SQRT((1D0-X)*(G/X-GB))
67235 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
67236 PTST=EXP((POPM-POPMN)*PARF(193))
67241 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
67244 IF(RTST.GT.PTST*GTST)THEN
67246 IF(RTST.GT.PTST) MSTU(121)=-1
67251 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
67252 IF(MSTU(121).GT.0) GOTO 110
67254 C.. Test accepted system size. If OK set global popcorn size variable.
67255 IF(NMES.GT.NMAX)THEN
67266 C********************************************************************
67269 C...Generates a new flavour pair and combines off a hadron
67271 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
67273 C...Double precision and integer declarations.
67274 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67275 IMPLICIT INTEGER(I-N)
67276 INTEGER PYK,PYCHGE,PYCOMP
67278 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67279 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67280 SAVE /PYDAT1/,/PYDAT2/
67284 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
67286 C...Default flavour values. Input consistency checks.
67291 IF(KF1A.EQ.0) RETURN
67293 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
67294 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
67295 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
67298 C...Check if tabulated flavour probabilities are to be used.
67299 IF(MSTJ(15).EQ.1) THEN
67300 IF(MSTJ(12).GE.5) CALL PYERRM(29,
67301 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
67302 & ' together with MSTJ(12)>=5 modification')
67304 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
67305 KFL1A=MOD(KF1A/1000,10)
67306 KFL1B=MOD(KF1A/100,10)
67308 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
67309 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
67310 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
67311 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
67315 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
67316 KFL2A=MOD(KF2A/1000,10)
67317 KFL2B=MOD(KF2A/100,10)
67319 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
67320 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
67321 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
67323 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
67326 C.. Recognize rank 0 diquark case
67328 KFDIQ=MAX(KF1A,KF2A)
67329 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
67331 C.. Join two flavours to meson or baryon. Test for popcorn.
67334 IF(KFDIQ.GT.10) THEN
67335 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
67336 & CALL PYNMES(KFDIQ)
67337 IF(MSTU(121).NE.0) THEN
67348 C.. Separate incoming flavours, curtain flavour consistency check
67354 KFL1A=MOD(KF1A/1000,10)
67355 KFL1B=MOD(KF1A/100,10)
67358 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
67359 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
67360 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
67362 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
67366 KFQOLD=KFL1A+KFL1B-KFQPOP
67369 C...Meson/baryon choice. Set number of mesons if starting a popcorn
67372 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
67373 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
67377 ELSEIF(KF1A.GT.10)THEN
67379 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
67380 IF(MSTU(121).GT.0) MBARY=-1
67383 C..x->H+q: Choose single vertex quark. Jump to form hadron.
67384 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
67385 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
67386 KFL3=ISIGN(KFQVER,-KFIN)
67390 C..x->H+qq: (IDW=proper PARF position for diquark weights)
67393 IF(MSTU(121).EQ.0) IDW=150
67395 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
67396 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
67397 C.. Shift to s-curtain parameters if needed
67398 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
67399 PARF(194)=PARF(138)*PARF(139)
67400 PARF(193)=PARJ(8)+PARJ(9)
67404 C.. x->H+qq: Get vertex quark
67405 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
67407 MSTU(121)=MSTU(121)-1
67408 IF(IDW.EQ.170) THEN
67409 IF(MSTU(121).EQ.0)THEN
67410 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
67412 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
67415 IF(MSTU(121).EQ.0)THEN
67416 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
67418 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
67424 RMES=PYR(0)*PARF(194)
67426 RMES=RMES-PARF(IPOS+IMES)
67427 IF(IMES.EQ.30) THEN
67432 IF(RMES.GT.0D0) GOTO 120
67435 IF(KMUL.EQ.2) KFJ=10003
67436 IF(KMUL.EQ.3) KFJ=10001
67437 IF(KMUL.EQ.4) KFJ=20003
67438 IF(KMUL.EQ.5) KFJ=5
67440 KFQVER=MOD(IMES,5)+1
67441 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
67442 IF(KFQVER.GT.3)THEN
67447 IF(MBARY.EQ.-1) IDW=170
67449 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
67450 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
67451 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
67452 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
67454 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
67458 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
67460 IF(KFQPOP.NE.KFQVER)THEN
67462 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
67463 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
67464 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
67466 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
67468 KFL3=ISIGN(KFDIQ,KFIN)
67470 C..x->M+y: flavour for meson.
67471 130 IF(MBARY.LE.0)THEN
67472 KFLA=MAX(KFQOLD,KFQVER)
67473 KFLB=MIN(KFQOLD,KFQVER)
67475 IF(KFLA.NE.KFQOLD) KFS=-KFS
67476 C... Form meson, with spin and flavour mixing for diagonal states.
67477 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
67478 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
67479 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
67482 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
67483 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
67484 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
67485 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
67486 IF(PYR(0).LT.PARJ(14)) KMUL=2
67487 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
67489 IF(RMUL.LT.PARJ(15)) KMUL=3
67490 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
67491 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
67494 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
67495 IF(KMUL.EQ.5) KFLS=5
67496 IF(KFLA.NE.KFLB)THEN
67497 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
67500 IMIX=2*KFLA+10*KMUL
67501 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
67502 & INT(RMIX+PARF(IMIX)))+KFLS
67503 IF(KFLA.GE.4) KF=110*KFLA+KFLS
67505 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
67506 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
67508 C..Optional extra suppression of eta and eta'.
67509 C..Allow shift to qq->B+q in old version (set IRANK to 0)
67510 IF(KF.EQ.221.OR.KF.EQ.331)THEN
67511 IF(PYR(0).GT.PARJ(25+KF/300))THEN
67512 IF(KF2A.GT.0) GOTO 130
67513 IF(MSTJ(12).LT.4) IRANK=0
67519 C.. x->B+y: Flavour for baryon
67522 IF(KF1A.LE.10) KFLA=KFQOLD
67523 KFLB=MOD(KFDIQ/1000,10)
67524 KFLC=MOD(KFDIQ/100,10)
67525 KFLDS=MOD(KFDIQ,10)
67526 KFLD=MAX(KFLA,KFLB,KFLC)
67527 KFLF=MIN(KFLA,KFLB,KFLC)
67528 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
67530 C... SU(6) factors for formation of baryon.
67534 IF(KFLB.NE.KFLC)THEN
67537 IF(KFLB.GT.2) KDMAX=KDMAX+2
67539 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
67544 SU6MAX=PARF(140+KDMAX)
67547 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
67552 SU6OCT=PARF(60+KBARY)
67553 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
67554 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
67555 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
67557 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
67559 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
67561 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
67562 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
67564 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
67568 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
67571 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
67572 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
67574 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
67576 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
67577 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
67581 C...Use tabulated probabilities to select new flavour and hadron.
67582 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
67585 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
67588 ELSEIF(KTAB2.EQ.0) THEN
67597 DO 150 KT3=KT3L,KT3U
67598 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
67604 DO 170 KT3=KT3L,KT3U
67606 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
67607 IF(RFL.LE.0D0) GOTO 190
67612 C...Reconstruct flavour of produced quark/diquark.
67613 IF(KTAB3.LE.6) THEN
67616 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
67619 IF(KTAB3.GE.8) KFL3A=2
67620 IF(KTAB3.GE.11) KFL3A=3
67621 IF(KTAB3.GE.16) KFL3A=4
67622 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
67623 KFL3=1000*KFL3A+100*KFL3B+1
67624 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
67626 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
67629 C...Reconstruct meson code.
67630 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
67632 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
67633 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
67635 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
67636 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
67637 & 25*KTABS)) KF=330+2*KTABS+1
67638 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
67639 KFLA=MAX(KTAB1,KTAB3)
67640 KFLB=MIN(KTAB1,KTAB3)
67642 IF(KFLA.NE.KF1A) KFS=-KFS
67643 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
67644 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
67646 IF(KFL1A.EQ.KFL3A) THEN
67647 KFLA=MAX(KFL1B,KFL3B)
67648 KFLB=MIN(KFL1B,KFL3B)
67649 IF(KFLA.NE.KFL1B) KFS=-KFS
67650 ELSEIF(KFL1A.EQ.KFL3B) THEN
67654 ELSEIF(KFL1B.EQ.KFL3A) THEN
67657 ELSEIF(KFL1B.EQ.KFL3B) THEN
67658 KFLA=MAX(KFL1A,KFL3A)
67659 KFLB=MIN(KFL1A,KFL3A)
67660 IF(KFLA.NE.KFL1A) KFS=-KFS
67662 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
67665 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
67667 C...Reconstruct baryon code.
67669 IF(KTAB1.GE.7) THEN
67678 KFLD=MAX(KFLA,KFLB,KFLC)
67679 KFLF=MIN(KFLA,KFLB,KFLC)
67680 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
67681 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
67682 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
67685 C...Check that constructed flavour code is an allowed one.
67686 IF(KFL2.NE.0) KFL3=0
67689 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
67697 C*********************************************************************
67700 C...Generates number of popcorn mesons and stores some relevant
67703 SUBROUTINE PYNMES(KFDIQ)
67705 C...Double precision and integer declarations.
67706 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67707 IMPLICIT INTEGER(I-N)
67708 INTEGER PYK,PYCHGE,PYCOMP
67710 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67711 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67712 SAVE /PYDAT1/,/PYDAT2/
67715 IF(MSTJ(12).LT.2) RETURN
67717 C..Old version: Get 1 or 0 popcorn mesons
67718 IF(MSTJ(12).LT.5)THEN
67720 IF(KFDIQ.NE.0) THEN
67722 KFA=MOD(KFDIQA/1000,10)
67723 KFB=MOD(KFDIQA/100,10)
67726 IF(KFA.EQ.3) POPWT=PARF(133)
67727 IF(KFB.EQ.3) POPWT=PARF(134)
67728 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
67730 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
67734 C..New version: Store popcorn- or rank 0 diquark parameters
67737 PARF(194)=PARF(139)
67738 IF(KFDIQ.NE.0) THEN
67741 PARF(194)=PARF(140)
67743 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
67744 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
67745 & '(PYNMES:) Neglecting too large popcorn possibility')
67749 C..New version: Get number of popcorn mesons
67752 110 MSTU(121)=MSTU(121)+1
67753 RTST=RTST/PARF(194)
67754 IF(RTST.LT.1D0) GOTO 110
67755 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
67756 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
67760 C***************************************************************
67763 C...Precalculates a set of diquark and popcorn weights.
67767 C...Double precision and integer declarations.
67768 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67769 IMPLICIT INTEGER(I-N)
67770 INTEGER PYK,PYCHGE,PYCOMP
67772 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67774 SAVE /PYDAT1/,/PYDAT2/
67776 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
67780 C..Diquark indices for dimensional variables
67789 C.. *** SU(6) factors **
67790 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
67792 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
67793 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
67794 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
67797 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
67799 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
67800 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
67802 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
67803 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
67806 C..SU(6)max q q' s,c,b
67807 SU6MUD =MAX(SU6(1) , SU6(8) )
67808 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
67809 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
67810 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
67811 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
67812 SU6M(IUS0)=SU6M(ISU0)
67813 SU6M(ISS1)=SU6M(IUU1)
67814 SU6M(IUS1)=SU6M(ISU1)
67816 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
67818 PARF(142)=SU6M(IUD1)
67819 PARF(143)=SU6M(ISU0)
67820 PARF(144)=SU6M(ISU1)
67821 PARF(145)=SU6M(ISS1)
67823 C..diquark SU(6) survival =
67824 C..sum over quark (quark tunnel weight)*(SU(6)).
67825 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
67826 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
67827 DMB(IUS0)=DMB(ISU0)
67828 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
67829 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
67830 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
67831 DMB(IUS1)=DMB(ISU1)
67832 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
67834 C.. *** Tunneling factors for Diquark production***
67835 C.. T: half a curtain pair = sqrt(curtain pair factor)
67836 IF(MSTJ(12).GE.5) THEN
67838 PMUD1=PYMASS(2103)-PMUD0
67839 PMUS0=PYMASS(3201)-PMUD0
67840 PMUS1=PYMASS(3203)-PMUS0-PMUD0
67841 PMSS1=PYMASS(3303)-PMUS0-PMUD0
67842 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
67843 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
67844 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
67845 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
67846 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
67847 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
67848 QBB(IUD1)=QBB(IUU1)
67850 PAR2M=SQRT(PARJ(2))
67851 PAR3M=SQRT(PARJ(3))
67852 PAR4M=SQRT(PARJ(4))
67853 QBB(ISU0)=PAR2M*PAR3M
67855 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
67857 QBB(ISU1)=PAR4M*QBB(ISU0)
67858 QBB(IUS1)=PAR4M*QBB(IUS0)
67862 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
67863 QBM(ISU0)=QBB(ISU0)
67864 QBM(IUS0)=PARJ(2)*QBB(IUS0)
67865 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
67866 QBM(IUU1)=6D0*QBB(IUU1)
67867 QBM(ISU1)=3D0*QBB(ISU1)
67868 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
67869 QBM(IUD1)=3D0*QBB(IUD1)
67871 C.. Combine T and tau to diquark weight for q-> B+B+..
67873 QBB(I)=QBB(I)*QBM(I)
67876 IF(MSTJ(12).GE.5)THEN
67877 C..New version: tau for rank 0 diquark.
67878 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
67879 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
67880 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
67881 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
67882 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
67883 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
67884 DMB(7+IUD1)=DMB(7+IUU1)/2D0
67886 C..New version: curtain flavour ratios.
67887 C.. s/u for q->B+M+...
67888 C.. s/u for rank 0 diquark: su -> ...M+B+...
67889 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67890 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
67891 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
67892 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
67893 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
67894 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
67895 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
67897 C..Old version: reset unused rank 0 diquark weights and
67898 C.. unused diquark SU(6) survival weights
67900 IF(MSTJ(12).LT.3) DMB(I)=1D0
67904 C..Old version: Shuffle PARJ(7) into tau
67905 QBM(IUS0)=QBM(IUS0)*PARJ(7)
67906 QBM(ISS1)=QBM(ISS1)*PARJ(7)
67907 QBM(IUS1)=QBM(IUS1)*PARJ(7)
67909 C..Old version: curtain flavour ratios.
67910 C.. s/u for q->B+M+...
67911 C.. s/u for rank 0 diquark: su -> ...M+B+...
67912 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67913 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
67914 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
67915 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
67916 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
67919 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
67920 C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
67922 DMB(7+I)=DMB(7+I)*DMB(I)
67923 DMB(I)=DMB(I)*QBM(I)
67924 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
67925 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
67928 C.. *** Popcorn factors ***
67930 IF(MSTJ(12).LT.5)THEN
67931 C.. Old version: Resulting popcorn weights.
67933 WS=PARF(135)*PARF(138)
67935 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
67937 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
67938 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
67939 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
67940 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
67941 & (1D0+QBB(IUD1)+QBB(IUU1)+
67942 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
67944 C..New version: Store weights for popcorn mesons,
67945 C..get prel. popcorn weights.
67946 DO 150 IPOS=201,1400
67955 IF(MR.EQ.7) PARF(193)=PARJ(10)
67956 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
67957 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
67958 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
67960 IF(NMES.EQ.1) SQWT=PARJ(2)
67962 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
67963 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
67964 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
67966 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
67967 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
67970 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
67972 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
67973 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
67979 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
67980 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
67981 IF(PJWT.LE.0D0) GOTO 190
67982 IF(PJWT.GT.1D0) PJWT=1D0
67984 IMIX=2*KFQOLD+10*KMUL
67986 IF(KMUL.EQ.2) KFJ=10003
67987 IF(KMUL.EQ.3) KFJ=10001
67988 IF(KMUL.EQ.4) KFJ=20003
67989 IF(KMUL.EQ.5) KFJ=5
67991 KFLA=MAX(KFQOLD,KFQVER)
67992 KFLB=MIN(KFQOLD,KFQVER)
67993 SWT=PARJ(11+KFLA/3+KFLA/4)
67994 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
67996 QWT=SQWT/(2D0+SQWT)
67997 IF(KFQVER.LT.3)THEN
67998 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
67999 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
68001 IF(KFQVER.NE.KFQOLD)THEN
68003 KFM=100*KFLA+10*KFLB+KFJ
68004 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68005 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
68006 WTTOT=WTTOT+PARF(IPOS+IMES)
68009 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
68010 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
68011 IF(ID.EQ.5) DWT=PARF(IMIX)
68013 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68014 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
68015 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
68016 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
68017 PARF(IPOS+5*KMUL+ID)=
68018 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
68020 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
68026 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
68028 IF(MR.EQ.7) PARF(140)=
68029 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
68030 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
68031 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
68037 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
68042 C..Recombine diquark weights to flavour and spin ratios
68043 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
68044 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
68045 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
68046 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
68047 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
68048 PARF(155)=QBB(ISU1)/QBB(ISU0)
68049 PARF(156)=QBB(IUS1)/QBB(IUS0)
68050 PARF(157)=QBB(IUD1)
68052 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
68053 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
68054 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
68055 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
68056 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
68057 PARF(165)=QBM(ISU1)/QBM(ISU0)
68058 PARF(166)=QBM(IUS1)/QBM(IUS0)
68059 PARF(167)=QBM(IUD1)
68061 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
68062 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
68063 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
68064 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
68065 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
68066 PARF(175)=DMB(ISU1)/DMB(ISU0)
68067 PARF(176)=DMB(IUS1)/DMB(IUS0)
68068 PARF(177)=DMB(IUD1)
68070 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
68071 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
68072 PARF(187)=DMB(7+IUD1)
68078 C*********************************************************************
68081 C...Generates transverse momentum according to a Gaussian.
68083 SUBROUTINE PYPTDI(KFL,PX,PY)
68085 C...Double precision and integer declarations.
68086 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68087 IMPLICIT INTEGER(I-N)
68088 INTEGER PYK,PYCHGE,PYCOMP
68090 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68093 C...Generate p_T and azimuthal angle, gives p_x and p_y.
68095 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
68096 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
68097 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
68098 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
68106 C*********************************************************************
68109 C...Generates the longitudinal splitting variable z.
68111 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
68113 C...Double precision and integer declarations.
68114 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68115 IMPLICIT INTEGER(I-N)
68116 INTEGER PYK,PYCHGE,PYCOMP
68118 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68119 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68120 SAVE /PYDAT1/,/PYDAT2/
68122 C...Check if heavy flavour fragmentation.
68126 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
68128 C...Lund symmetric scaling function: determine parameters of shape.
68129 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
68130 &MSTJ(11).GE.4) THEN
68132 IF(MSTJ(91).EQ.1) FA=PARJ(43)
68133 IF(KFLB.GE.10) FA=FA+PARJ(45)
68135 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
68138 IF(KFLA.GE.10) FC=FC-PARJ(45)
68139 IF(KFLB.GE.10) FC=FC+PARJ(45)
68140 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
68142 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
68143 FC=FC+FRED*FBB*PARF(100+KFLH)**2
68146 IF(ABS(FC-1D0).GT.0.01D0) MC=2
68148 C...Determine position of maximum. Special cases for a = 0 or a = c.
68149 IF(FA.LT.0.02D0) THEN
68152 IF(FC.GT.FB) ZMAX=FB/FC
68153 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
68158 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
68159 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
68162 C...Subdivide z range if distribution very peaked near endpoint.
68164 IF(ZMAX.LT.0.1D0) THEN
68170 ZDIVC=ZDIV**(1D0-FC)
68171 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
68173 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
68175 FSCB=SQRT(4D0+(FC/FB)**2)
68176 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
68177 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
68178 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
68179 FINT=1D0+FB*(1D0-ZDIV)
68182 C...Choice of z, preweighted for peaks at low or high z.
68186 IF(FINT*PYR(0).LE.1D0) THEN
68188 ELSEIF(MC.EQ.1) THEN
68192 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
68195 ELSEIF(MMAX.EQ.3) THEN
68196 IF(FINT*PYR(0).LE.1D0) THEN
68198 FPRE=EXP(FB*(Z-ZDIV))
68200 Z=ZDIV+Z*(1D0-ZDIV)
68204 C...Weighting according to correct formula.
68205 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
68206 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
68207 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
68208 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
68209 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
68211 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
68213 FC=PARJ(50+MAX(1,KFLH))
68214 IF(MSTJ(91).EQ.1) FC=PARJ(59)
68216 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
68217 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
68218 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
68219 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
68222 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
68223 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
68230 C*********************************************************************
68233 C...Generates timelike parton showers from given partons.
68235 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
68237 C...Double precision and integer declarations.
68238 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68239 IMPLICIT INTEGER(I-N)
68240 INTEGER PYK,PYCHGE,PYCOMP
68241 C...Parameter statement to help give large particle numbers.
68242 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
68243 &KEXCIT=4000000,KDIMEN=5000000)
68244 PARAMETER (MAXNUR=1000)
68246 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
68247 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
68248 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68249 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68250 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
68251 COMMON/PYINT1/MINT(400),VINT(400)
68252 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
68254 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
68255 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
68256 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
68257 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
68260 C...Check that QMAX not too low.
68261 IF(MSTJ(41).LE.0) THEN
68263 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
68264 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
68266 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
68270 C...Store positions of shower initiating partons.
68272 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
68275 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
68280 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
68281 & .AND.IP2.GE.-80) THEN
68286 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
68294 & '(PYSHOW:) failed to reconstruct showering system')
68295 IF(MSTU(21).GE.1) RETURN
68298 C...Send off to PYPTFS for pT-ordered evolution if requested,
68299 C...if at least 2 partons, and without predefined shower branchings.
68300 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
68305 PTPART(II)=0.5D0*QMAX
68307 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
68311 C...Initialization of cutoff masses etc.
68319 PMTH(1,21)=PYMASS(21)
68320 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
68321 PMTH(3,21)=2D0*PMTH(2,21)
68322 PMTH(4,21)=PMTH(3,21)
68323 PMTH(5,21)=PMTH(3,21)
68324 PMTH(1,22)=PYMASS(22)
68325 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
68326 PMTH(3,22)=2D0*PMTH(2,22)
68327 PMTH(4,22)=PMTH(3,22)
68328 PMTH(5,22)=PMTH(3,22)
68330 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
68331 PMQT1E=MIN(PMQTH1,PARJ(90))
68333 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
68334 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
68337 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
68339 PMTH(1,IFL)=PYMASS(IFL)
68340 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
68341 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
68342 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
68343 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
68346 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
68347 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
68348 PMTH(1,IFL)=PYMASS(IFL)
68349 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
68350 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
68351 PMTH(4,IFL)=PMTH(3,IFL)
68352 PMTH(5,IFL)=PMTH(3,IFL)
68354 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
68356 ALFM=LOG(PT2MIN/ALAMS)
68358 C...Check on phase space available for emission.
68366 KFLA(I)=IABS(K(IPA(I),2))
68368 C...Special cutoff masses for initial partons (may be a heavy quark,
68369 C...squark, ..., and need not be on the mass shell).
68371 IF(NPA.LE.1) IREF(I)=IR
68372 IF(NPA.GE.2) IREF(I+1)=IR
68376 IF(KFLA(I).LE.8) THEN
68378 IF(MSTJ(41).GE.2) ISCHG(IR)=1
68379 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
68380 & KFLA(I).EQ.17) THEN
68381 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
68382 ELSEIF(KFLA(I).EQ.21) THEN
68384 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
68385 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
68387 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
68390 C...same for QQ~[3S18]
68391 ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
68392 & KFLA(I).EQ.9900553)) THEN
68397 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
68398 C...(only intended for studying the effects of switching such rad on/off)
68399 IF (MSTJ(39).GT.0.AND.KFLA(I).EQ.MSTJ(39)) THEN
68404 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
68406 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
68407 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
68408 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
68409 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
68410 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
68411 ELSEIF(ISCOL(IR).EQ.1) THEN
68412 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
68413 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
68414 PMTH(4,IR)=PMTH(3,IR)
68415 PMTH(5,IR)=PMTH(3,IR)
68416 ELSEIF(ISCHG(IR).EQ.1) THEN
68417 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
68418 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
68419 PMTH(4,IR)=PMTH(3,IR)
68420 PMTH(5,IR)=PMTH(3,IR)
68422 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
68424 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
68426 PS(J)=PS(J)+P(IPA(I),J)
68429 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
68430 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
68431 IF(NPA.EQ.1) PS(5)=PS(4)
68432 IF(PS(5).LE.PM+PMQT1E) RETURN
68434 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
68437 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
68438 KFSRCE=IABS(K(K(IP1,3),2))
68440 IPAR1=MAX(1,K(IP1,3))
68441 IPAR2=MAX(1,K(IP2,3))
68442 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
68443 & KFSRCE=IABS(K(K(IPAR1,3),2))
68446 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
68447 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
68448 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
68449 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
68450 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
68451 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
68452 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
68453 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
68455 C...Identify two primary showerers.
68457 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
68458 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
68459 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
68460 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
68461 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
68462 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
68463 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
68464 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
68466 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
68467 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
68468 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
68469 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
68470 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
68471 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
68472 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
68473 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
68475 C...Order of showerers. Presence of gluino.
68476 ITYPMN=MIN(ITYPE1,ITYPE2)
68477 ITYPMX=MAX(ITYPE1,ITYPE2)
68479 IF(ITYPE1.GT.ITYPE2) IORD=2
68481 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
68483 C...Check if 3-jet matrix elements to be used.
68486 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
68487 IF(MSTJ(38).NE.0) THEN
68491 ELSEIF(MSTJ(47).GE.6) THEN
68497 C...Vector/axial vector -> q + qbar; q -> q + V.
68498 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
68499 & ITYPES.EQ.3)) THEN
68501 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
68503 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
68504 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
68505 C...gamma*/Z0: assume e+e- initial state if unknown.
68507 IF(KFSRCE.EQ.23) THEN
68508 IANNFL=K(K(IP1,3),3)
68509 IF(IANNFL.NE.0) THEN
68510 KANNFL=IABS(K(IANNFL,2))
68511 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
68514 AI=SIGN(1D0,EI+0.1D0)
68515 VI=AI-4D0*EI*PARU(102)
68516 EF=KCHG(KFLA(1),1)/3D0
68517 AF=SIGN(1D0,EF+0.1D0)
68518 VF=AF-4D0*EF*PARU(102)
68519 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
68522 SQWZ=PS(5)*PMAS(23,2)
68523 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
68524 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
68525 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
68526 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
68528 ALPHA=VECT/(VECT+AXIV)
68529 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
68532 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
68533 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
68535 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
68536 & ITYPES.EQ.1)) THEN
68539 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
68540 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
68542 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
68544 ELSEIF(KFSRCE.EQ.36) THEN
68547 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
68548 & ITYPES.EQ.1)) THEN
68551 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
68552 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
68553 & ITYPES.EQ.3)) THEN
68555 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
68556 & ITYPES.EQ.2)) THEN
68558 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
68560 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
68561 & ITYPES.EQ.2)) THEN
68564 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
68565 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
68566 & ITYPES.EQ.5)) THEN
68568 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
68569 & ITYPES.EQ.2)) THEN
68571 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
68572 & ITYPES.EQ.1)) THEN
68575 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
68576 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
68578 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
68579 & ITYPES.EQ.2)) THEN
68581 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
68582 & ITYPES.EQ.1)) THEN
68585 C...g -> ~g + ~g (eikonal approximation).
68586 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
68589 M3JC=5*ICLASS+ICOMBI
68593 C...Find if interference with initial state partons.
68595 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
68596 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
68597 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
68602 KCA=PYCOMP(KFLA(I))
68603 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
68605 IF(KCII(I).NE.0) THEN
68607 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
68608 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
68609 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
68611 IIIS(I,NIIS(I))=ICSI
68616 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
68619 C...Boost interfering initial partons to rest frame
68620 C...and reconstruct their polar and azimuthal angles.
68624 K(N+I,J)=K(IPA(I),J)
68625 P(N+I,J)=P(IPA(I),J)
68629 DO 230 I=3,2+NIIS(1)
68631 K(N+I,J)=K(IIIS(1,I-2),J)
68632 P(N+I,J)=P(IIIS(1,I-2),J)
68636 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
68638 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
68639 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
68643 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
68644 & -PS(2)/PS(4),-PS(3)/PS(4))
68645 PHI=PYANGL(P(N+1,1),P(N+1,2))
68646 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
68647 THE=PYANGL(P(N+1,3),P(N+1,1))
68648 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
68649 DO 260 I=3,2+NIIS(1)
68650 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
68651 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
68653 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
68654 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
68655 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
68656 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
68660 C...Boost 3 or more partons to their rest frame.
68661 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
68662 &-PS(2)/PS(4),-PS(3)/PS(4))
68664 C...Define imagined single initiator of shower for parton system.
68666 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
68667 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
68668 IF(MSTU(21).GE.1) RETURN
68687 C...Loop over partons that may branch.
68690 IF(NPA.EQ.1) IM=NS-1
68693 IF(IM.GT.N) GOTO 600
68696 IF(KSH(IR).EQ.0) GOTO 290
68697 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
68702 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
68703 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
68704 IF(MSTU(21).GE.1) RETURN
68707 C...Position of aunt (sister to branching parton).
68708 C...Origin and flavour of daughters.
68711 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
68712 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
68724 K(N+I,2)=K(IPA(I),2)
68726 ELSEIF(KFLM.NE.21) THEN
68729 IREF(N+1-NS)=IREF(IM-NS)
68730 IREF(N+2-NS)=IABS(K(N+2,2))
68731 ELSEIF(K(IM,5).EQ.21) THEN
68739 IREF(N+1-NS)=IABS(K(N+1,2))
68740 IREF(N+2-NS)=IABS(K(N+2,2))
68743 C...Reset flags on daughters and tries made.
68748 KFLD(IP)=IABS(K(N+IP,2))
68749 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
68753 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
68757 C...Maximum virtuality of daughters.
68760 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
68761 P(N+I,5)=MIN(QMAX,PS(5))
68763 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
68764 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
68767 IF(MSTJ(43).LE.2) PEM=V(IM,2)
68768 IF(MSTJ(43).GE.3) PEM=P(IM,4)
68769 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
68770 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
68771 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
68775 IF(ISI(I).EQ.1) THEN
68777 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
68779 V(N+I,5)=P(N+I,5)**2
68782 C...Choose one of the daughters for evolution.
68784 IF(NEP.EQ.1) INUM=1
68786 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
68789 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
68791 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
68797 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
68798 RPM=P(N+I,5)/PMSD(I)
68800 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
68808 C...Cancel choice of predetermined daughter already treated.
68811 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
68812 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
68813 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
68814 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
68815 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
68818 C...Store information on choice of evolving daughter.
68822 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
68825 KFL(I)=IABS(K(IEP(I),2))
68827 ITRY(INUM)=ITRY(INUM)+1
68828 IF(ITRY(INUM).GT.200) THEN
68829 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
68830 IF(MSTU(21).GE.1) RETURN
68834 IF(KSH(IR).EQ.0) GOTO 450
68835 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
68837 C...Check if evolution already predetermined for daughter.
68839 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
68840 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
68841 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
68842 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
68843 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
68845 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
68847 IF(IPSPD.NE.0) ISSET(INUM)=1
68850 C...Select side for interference with initial state partons.
68851 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
68854 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
68856 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
68857 IF(PYR(0).GT.0.5D0) ISII(III)=1
68858 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
68860 IF(PYR(0).GT.0.5D0) ISII(III)=2
68864 C...Calculate allowed z range.
68867 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
68870 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
68871 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
68873 IF(MOD(MSTJ(43),2).EQ.1) THEN
68875 ZCE=PMTH(2,22)/PMED
68876 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
68878 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
68879 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
68881 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
68882 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
68883 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
68886 ZCE=MIN(ZCE,0.49991D0)
68887 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
68888 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
68889 P(IEP(1),5)=PMTH(1,IR)
68890 V(IEP(1),5)=P(IEP(1),5)**2
68894 C...Integral of Altarelli-Parisi z kernel for QCD.
68895 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
68896 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
68897 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
68899 C...Evolution of QQ~[3S18] state if MSTP(148)=1.
68900 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
68901 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
68902 FBR=6D0*LOG((1D0-ZC)/ZC)
68904 ELSEIF(MSTJ(49).EQ.0) THEN
68905 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
68906 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
68908 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
68909 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
68910 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
68911 ELSEIF(MSTJ(49).EQ.1) THEN
68912 FBR=(1D0-2D0*ZC)/3D0
68913 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
68915 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
68916 ELSEIF(KFL(1).EQ.21) THEN
68917 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
68919 FBR=2D0*LOG((1D0-ZC)/ZC)
68922 C...Reset QCD probability for colourless.
68923 IF(ISCOL(IR).EQ.0) FBR=0D0
68925 C...Integral of Altarelli-Parisi kernel for photon emission.
68927 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
68928 IF(KFL(1).LE.18) THEN
68929 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
68931 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
68934 C...Inner veto algorithm starts. Find maximum mass for evolution.
68935 410 PMS=V(IEP(1),5)
68940 IRI=IREF(IEP(I)-NS)
68941 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
68944 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
68947 C...Select mass for daughter in QCD evolution.
68949 DO 430 IFF=4,MSTJ(45)
68950 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
68952 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
68953 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
68954 C...Already predetermined choice.
68955 IF(IPSPD.NE.0) THEN
68956 PMSQCD=P(IPSPD,5)**2
68957 ELSEIF(FBR.LT.1D-3) THEN
68959 ELSEIF(MSTJ(44).LE.0) THEN
68960 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
68961 ELSEIF(MSTJ(44).EQ.1) THEN
68962 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
68964 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
68966 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
68967 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
68968 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
68972 C...Select mass for daughter in QED evolution.
68973 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
68974 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
68975 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
68976 IF(FBRE.LT.1D-3) THEN
68979 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
68980 & (PARU(101)*FBRE)))
68982 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
68983 PMSQED=PMSQED+PMTH(1,IR)**2
68984 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
68986 IF(PMSQED.GT.PMSQCD) THEN
68992 C...Check whether daughter mass below cutoff.
68993 P(IEP(1),5)=SQRT(V(IEP(1),5))
68994 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
68995 P(IEP(1),5)=PMTH(1,IR)
68996 V(IEP(1),5)=P(IEP(1),5)**2
69000 C...Already predetermined choice of z, and flavour in g -> qqbar.
69001 IF(IPSPD.NE.0) THEN
69004 PMSGD1=P(IPSGD1,5)**2
69005 PMSGD2=P(IPSGD2,5)**2
69006 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
69007 & 4D0*PMSGD1*PMSGD2))
69008 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
69009 & PMSGD1+PMSGD2)/ALAMPS
69010 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
69011 IF(KFL(1).NE.21) THEN
69014 K(IEP(1),5)=IABS(K(IPSGD1,2))
69017 C...Select z value of branching: q -> qgamma.
69018 ELSEIF(MCE.EQ.2) THEN
69019 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
69020 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
69024 C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
69025 ELSEIF(MSTJ(49).EQ.0.AND.
69026 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
69027 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69028 C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
69029 IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
69030 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
69034 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
69035 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
69036 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69037 C...Only do z weighting when no ME correction afterwards.
69038 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
69040 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
69041 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69042 IF(PYR(0).GT.0.5D0) Z=1D0-Z
69043 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
69045 ELSEIF(MSTJ(49).NE.1) THEN
69047 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
69048 KFLB=1+INT(MSTJ(45)*PYR(0))
69049 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
69050 IF(PMQ.GE.1D0) GOTO 410
69051 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
69052 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
69053 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
69054 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
69055 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
69057 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
69061 C...Ditto for scalar gluon model.
69062 ELSEIF(KFL(1).NE.21) THEN
69063 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
69065 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
69066 Z=ZC+(1D0-2D0*ZC)*PYR(0)
69069 Z=ZC+(1D0-2D0*ZC)*PYR(0)
69070 KFLB=1+INT(MSTJ(45)*PYR(0))
69071 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
69072 IF(PMQ.GE.1D0) GOTO 410
69076 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
69077 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
69078 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
69079 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69080 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
69082 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
69083 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
69084 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
69085 IF(PT2APP.LT.PT2MIN) GOTO 410
69086 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
69090 C...Check if z consistent with chosen m.
69091 IF(KFL(1).EQ.21) THEN
69092 IRGD1=IABS(K(IEP(1),5))
69096 IRGD2=IABS(K(IEP(1),5))
69100 ELSEIF(NEP.GE.3) THEN
69102 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
69103 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
69105 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
69106 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
69108 IF(MOD(MSTJ(43),2).EQ.1) THEN
69109 PMQTH3=0.5D0*PARJ(82)
69110 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
69111 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
69112 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
69113 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
69114 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
69118 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
69121 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
69122 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69123 ELSEIF(IPSPD.NE.0) THEN
69127 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
69129 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
69131 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
69133 C...Width suppression for q -> q + g.
69134 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
69136 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
69140 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
69141 IF(MSTJ(40).EQ.1) THEN
69142 IF(CHI.LT.PYR(0)) GOTO 410
69143 ELSEIF(MSTJ(40).EQ.2) THEN
69144 IF(1D0-CHI.LT.PYR(0)) GOTO 410
69148 C...Three-jet matrix element correction.
69153 C...QED matrix elements: only for massless case so far.
69154 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
69155 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
69156 X2=1D0-V(IEP(1),5)/V(NS+1,5)
69157 X3=(1D0-X1)+(1D0-X2)
69159 KI2=K(IPA(3-INUM),2)
69160 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
69161 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
69162 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
69163 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
69164 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
69165 ELSEIF(MCE.EQ.2) THEN
69167 C...QCD matrix elements, including mass effects.
69168 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
69172 IF(IR.GE.31.AND.IGM.EQ.0) THEN
69173 C...QCD ME: original parton, first branching.
69174 PM2ME=PMTH(1,63-IR)
69176 ELSEIF(IR.GE.31) THEN
69177 C...QCD ME: original parton, subsequent branchings.
69178 PM2ME=PMTH(1,63-IR)
69179 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
69180 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69181 ELSEIF(K(IM,2).EQ.21) THEN
69182 C...QCD ME: secondary partons, first branching.
69185 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
69186 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
69187 & 4D0*PS1ME*PM2ME**2))
69188 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
69190 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69193 C...QCD ME: secondary partons, subsequent branchings.
69195 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
69196 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69199 C...Construct ME variables.
69202 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
69203 X2=1D0+R2ME**2-PS1ME/ECMME**2
69204 C...Call ME, with right order important for two inequivalent showerers.
69205 IF(IR.EQ.IORD+30) THEN
69206 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
69208 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
69210 C...Split up total ME when two radiating partons.
69212 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
69213 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
69214 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
69215 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
69216 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
69217 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
69218 & MAX(1D-10,2D0-X1-X2)
69219 C...Evaluate shower rate to be compared with.
69220 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
69221 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
69222 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
69223 ELSEIF(MSTJ(49).NE.1) THEN
69225 C...Toy model scalar theory matrix elements; no mass effects.
69227 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
69228 X2=1D0-V(IEP(1),5)/V(NS+1,5)
69229 X3=(1D0-X1)+(1D0-X2)
69230 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
69232 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
69236 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
69239 C...Impose angular ordering by rejection of nonordered emission.
69240 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
69241 PEMAO=V(IM,1)*P(IM,4)
69242 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
69243 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
69245 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
69246 & .OR.MSTJ(42).EQ.7)) THEN
69248 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
69249 & .OR.MSTJ(42).EQ.6)) THEN
69251 PMDAO=PMTH(2,K(IEP(1),5))
69252 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
69255 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
69256 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
69257 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
69261 440 IF(K(IAOM,5).EQ.22) THEN
69263 IF(K(IAOM,3).LE.NS) MAOM=0
69264 IF(MAOM.EQ.1) GOTO 440
69266 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
69267 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
69268 IF(THE2ID.LT.THE2IM) GOTO 410
69272 C...Impose user-defined maximum angle at first branching.
69273 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
69274 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
69275 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
69276 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
69277 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
69278 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
69279 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
69280 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
69281 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
69282 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
69286 C...Impose angular constraint in first branching from interference
69287 C...with initial state partons.
69288 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
69289 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
69290 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
69291 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
69292 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
69293 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
69297 C...End of inner veto algorithm. Check if only one leg evolved so far.
69301 IF(NEP.EQ.1) GOTO 490
69302 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
69305 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
69306 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
69310 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
69314 PMSUM=PMSUM+P(N+I,5)
69316 IF(PMSUM.GE.PS(5)) GOTO 350
69317 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
69320 IF(KSH(IRDA).EQ.0) GOTO 480
69321 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
69322 IF(IRDA.EQ.21) THEN
69323 IRGD1=IABS(K(I1,5))
69327 IRGD2=IABS(K(I1,5))
69330 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
69331 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
69333 IF(I1.EQ.N+1) ZM=V(IM,1)
69334 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
69335 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
69336 & 4D0*V(N+1,5)*V(N+2,5))
69337 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
69340 IF(MOD(MSTJ(43),2).EQ.1) THEN
69341 PMQTH3=0.5D0*PARJ(82)
69342 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
69343 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
69344 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
69345 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
69346 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
69350 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
69353 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
69354 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69358 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
69359 & ISSET(1).EQ.0) THEN
69361 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
69362 & ISSET(2).EQ.0) THEN
69366 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
69368 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
69370 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
69373 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
69374 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
69375 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
69376 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
69377 IF(ISL(1).EQ.1) ISL(2)=0
69378 IF(ISL(1).EQ.0) ISLM=1
69379 IF(ISL(2).EQ.0) ISLM=2
69381 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
69386 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
69387 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
69388 PMQ1=V(N+1,5)/V(IM,5)
69389 PMQ2=V(N+2,5)/V(IM,5)
69390 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
69395 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
69399 C...Accepted branch. Construct four-momentum for initial partons.
69405 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
69407 P(N+1,4)=P(IPA(1),4)
69409 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
69410 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
69413 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
69418 P(N+2,4)=P(IM,5)-PED1
69421 ELSEIF(NEP.GE.3) THEN
69422 C...Rescale all momenta for energy conservation.
69428 P(N+I,J)=P(IPA(I),J)
69431 PQS=PQS+P(N+I,5)**2/P(N+I,4)
69434 FAC=(PS(5)-PQS)/(PES-PQS)
69439 P(N+I,J)=FAC*P(N+I,J)
69441 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)
69444 PQS=PQS+P(N+I,5)**2/P(N+I,4)
69446 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
69448 C...Construct transverse momentum for ordinary branching in shower.
69452 550 LOOPPT=LOOPPT+1
69453 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
69454 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
69455 IF(PZM.LE.0D0) THEN
69457 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69458 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69459 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
69460 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
69461 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
69462 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
69464 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
69466 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
69469 ELSEIF(PTS.LT.0D0) THEN
69472 PT=SQRT(MAX(0D0,PTS))
69474 C...Global statistics.
69475 MINT(353)=MINT(353)+1
69476 VINT(353)=VINT(353)+PT
69477 IF (MINT(353).EQ.1) VINT(358)=PT
69479 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
69481 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
69482 & .AND.IAU.NE.0) THEN
69483 IF(K(IGM,3).NE.0) MAZIP=1
69485 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
69486 IF(MAZIP.EQ.0) ZAU=0D0
69487 IF(K(IGM,2).NE.21) THEN
69488 HAZIP=2D0*ZAU/(1D0+ZAU**2)
69490 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
69492 IF(K(N+1,2).NE.21) THEN
69493 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
69495 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
69499 C...Find coefficient of azimuthal asymmetry due to soft gluon
69502 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
69503 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
69504 IF(K(IGM,3).NE.0) MAZIC=N+1
69505 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
69506 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
69507 & ZM.GT.0.5D0) MAZIC=N+2
69508 IF(K(IAU,2).EQ.22) MAZIC=0
69510 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
69512 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
69513 IF(MAZIC.EQ.0) ZGM=1D0
69514 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
69515 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
69516 HAZIC=MIN(0.95D0,HAZIC)
69520 C...Construct energies for ordinary branching in shower.
69521 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
69522 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69523 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69524 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
69525 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
69526 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
69527 P(N+1,4)=PEM*V(IM,1)
69529 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
69530 & SQRT(PMLS)*ZM)/V(IM,5)
69533 C...Already predetermined choice of phi angle or not
69535 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
69537 IF(K(IPSPD,4).GT.0) THEN
69539 IF(IM.EQ.NS+2) THEN
69540 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
69542 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
69545 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
69547 IF(K(IPSPD,4).GT.0) THEN
69549 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
69550 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
69551 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
69552 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
69553 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
69554 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
69558 C...Construct momenta for ordinary branching in shower.
69559 P(N+1,1)=PT*COS(PHI)
69560 P(N+1,2)=PT*SIN(PHI)
69561 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69562 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69563 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
69564 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
69565 ELSEIF(PZM.GT.0D0) THEN
69566 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
69567 & 2D0*PEM*P(N+1,4))/PZM
69573 P(N+2,3)=PZM-P(N+1,3)
69574 P(N+2,4)=PEM-P(N+1,4)
69575 IF(MSTJ(43).LE.2) THEN
69576 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
69577 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
69581 C...Rotate and boost daughters.
69583 IF(MSTJ(43).LE.2) THEN
69584 BEX=P(IGM,1)/P(IGM,4)
69585 BEY=P(IGM,2)/P(IGM,4)
69586 BEZ=P(IGM,3)/P(IGM,4)
69587 GA=P(IGM,4)/P(IGM,5)
69588 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
69597 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
69598 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
69599 IF(PTIMB.GT.1D-4) THEN
69600 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
69605 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
69606 & SIN(THE)*COS(PHI)*P(I,3)
69607 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
69608 & SIN(THE)*SIN(PHI)*P(I,3)
69609 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
69611 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
69612 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
69613 P(I,1)=DP(1)+DGABP*BEX
69614 P(I,2)=DP(2)+DGABP*BEY
69615 P(I,3)=DP(3)+DGABP*BEZ
69616 P(I,4)=GA*(DP(4)+DBP)
69620 C...Weight with azimuthal distribution, if required.
69621 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
69627 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
69628 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
69629 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
69631 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
69632 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
69634 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
69635 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
69636 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
69637 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
69638 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
69639 IF(MAZIP.NE.0) THEN
69640 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
69643 IF(MAZIC.NE.0) THEN
69644 IF(MAZIC.EQ.N+2) CAD=-CAD
69645 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
69646 & .LT.PYR(0)) GOTO 560
69651 C...Azimuthal anisotropy due to interference with initial state partons.
69652 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
69653 &K(N+2,2).EQ.21)) THEN
69655 IF(ISII(III).GE.1) THEN
69657 IF(K(N+1,2).NE.21) IAZIID=N+2
69658 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
69659 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
69660 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
69661 IF(III.EQ.2) THEIID=PARU(1)-THEIID
69662 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
69663 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
69664 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
69665 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
69666 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
69667 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
69668 & .LT.PYR(0)) GOTO 560
69672 C...Continue loop over partons that may branch, until none left.
69673 IF(IGM.GE.0) K(IM,1)=14
69676 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
69677 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
69678 IF(MSTU(21).GE.1) N=NS
69679 IF(MSTU(21).GE.1) RETURN
69683 C...Set information on imagined shower initiator.
69684 600 IF(NPA.GE.2) THEN
69688 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
69696 C...Reconstruct string drawing information.
69697 DO 610 I=NS+1+IIM,N
69698 KQ=KCHG(PYCOMP(K(I,2)),2)
69699 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
69701 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
69702 & IABS(K(I,2)).LE.18) THEN
69704 ELSEIF(K(I,1).LE.10) THEN
69705 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
69706 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
69707 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
69708 ID1=MOD(K(I,4),MSTU(5))
69709 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
69710 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
69711 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
69712 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
69713 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
69714 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
69715 K(ID1,4)=K(ID1,4)+MSTU(5)*I
69716 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
69717 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
69718 K(ID2,5)=K(ID2,5)+MSTU(5)*I
69720 ID1=MOD(K(I,4),MSTU(5))
69722 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
69723 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
69724 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
69725 K(ID1,4)=K(ID1,4)+MSTU(5)*I
69726 K(ID1,5)=K(ID1,5)+MSTU(5)*I
69736 C...Transformation from CM frame.
69738 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
69739 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
69741 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
69742 ELSEIF(NPA.EQ.2) THEN
69747 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
69748 & /(1D0+GA)-P(IPA(1),4))
69749 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
69750 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
69751 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
69753 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
69755 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
69758 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
69761 C...Decay vertex of shower.
69768 C...Delete trivial shower, else connect initiators.
69769 IF(N.LE.NS+NPA+IIM) THEN
69774 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
69775 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
69776 K(NS+IIM+IP,3)=IPA(IP)
69777 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
69778 IF(K(NS+IIM+IP,1).NE.1) THEN
69779 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
69780 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
69788 C*********************************************************************
69791 C...Generates pT-ordered timelike final-state parton showers.
69793 C...MODE defines how to find radiators and recoilers.
69794 C... = 0 : based on colour flow between undecayed partons.
69795 C... = 1 : for IPART <= NPARTD only consider primary partons,
69796 C... whether decayed or not; else as above.
69797 C... = 2 : based on common history, whether decayed or not.
69798 C... = 3 : use (or create) MCT color information to shower partons
69800 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
69802 C...Double precision and integer declarations.
69803 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69804 IMPLICIT INTEGER(I-N)
69805 INTEGER PYK,PYCHGE,PYCOMP
69806 C...Parameter statement to help give large particle numbers.
69807 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69808 &KEXCIT=4000000,KDIMEN=5000000)
69809 C...Parameter statement for maximum size of showers.
69810 PARAMETER (MAXNUR=1000)
69812 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
69813 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69814 COMMON/PYCTAG/NCT,MCT(4000,2)
69815 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69816 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69817 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69818 COMMON/PYINT1/MINT(400),VINT(400)
69819 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
69822 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
69823 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
69824 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
69825 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
69826 C...Statement functions.
69827 SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
69828 &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
69830 C...Initial values. Check that valid system.
69832 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
69833 &MSTJ(41).NE.12) RETURN
69834 IF(NPART.LE.0) THEN
69835 CALL PYERRM(2,'(PYPTFS:) showering system too small')
69841 C...Mass thresholds and Lambda for QCD evolution.
69845 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
69846 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
69853 C...Cutoff scale for QCD evolution. Starting pT2.
69854 NFLAV=MAX(0,MIN(5,MSTJ(45)))
69855 PT0C=0.5D0*PARJ(82)
69856 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
69858 C...Parameters for QED evolution.
69859 AEM2PI=PARU(101)/PARU(2)
69860 PT0EQ=0.5D0*PARJ(83)
69861 PT0EL=0.5D0*PARJ(90)
69863 C...Reset. Remove irrelevant colour tags.
69868 DO 110 I=MINT(84)+1,N
69869 IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
69873 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
69880 C...Begin loop to set up showering partons. Sum four-momenta.
69883 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
69884 IF(K(I,1).GT.10) GOTO 230
69885 ELSEIF(K(I,3).GT.MINT(84)) THEN
69886 IF(K(I,3).GT.MINT(84)+2) GOTO 230
69888 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 230
69891 PSUM(J)=PSUM(J)+P(I,J)
69894 C...Find colour and charge, but skip diquarks.
69895 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 230
69896 KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
69897 KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
69900 IF (IABS(K(I,2)).GE.9900101.AND.IABS(K(I,2)).LE.9910555) THEN
69901 IF (MSTP(148).GE.1) THEN
69902 C...Temporary: force no radiation from quarkonia since not yet treated
69903 CALL PYERRM(11,'(PYPTFS:) quarkonia showers not yet in'
69904 & //' PYPTFS, switched off')
69905 CALL PYGIVE('MSTP(148)=0')
69907 IF (MSTP(148).EQ.0) THEN
69908 C...Skip quarkonia if radiation switched off
69914 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
69915 C...(only intended for studying the effects of switching such rad on/off)
69916 IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) THEN
69920 C...Either colour or anticolour charge radiates; for gluon both.
69921 DO 180 JSGCOL=1,-1,-2
69922 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
69923 JCOL=4+(1-JSGCOL)/2
69926 C...Basic info about radiating parton.
69930 ISCOL(NEVOL)=JSGCOL
69932 PTSCA(NEVOL)=PTPART(IP)
69934 C...Begin search for colour recoiler when MODE = 0 or 1.
69936 C...Find sister with matching anticolour to the radiating parton.
69938 IRNEW=K(IROLD,JCOL)/MSTU(5)
69941 C...Skip radiation off loose colour ends.
69942 130 IF(IRNEW.EQ.0) THEN
69946 C...Optionally skip radiation on dipole to beam remnant.
69947 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
69951 C...For now always skip radiation on dipole to junction.
69952 ELSEIF(K(IRNEW,2).EQ.88) THEN
69956 C...For MODE=1: if reached primary then done.
69957 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
69958 & IRNEW.LE.NPARTD) THEN
69960 C...If sister stable and points back then done.
69961 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
69963 IF(K(IRNEW,1).LT.10) THEN
69965 C...If sister unstable then go to her daughter.
69968 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
69973 C...If found mother then look for aunt.
69974 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
69977 IRNEW=K(IROLD,JCOL)/MSTU(5)
69980 C...If daughter stable then done.
69981 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
69983 IF(K(IRNEW,1).LT.10) THEN
69985 C...If daughter unstable then go to granddaughter.
69988 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
69993 C...If daughter points to another daughter then done or move up.
69994 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
69996 IF(K(IRNEW,1).LT.10) THEN
69999 IRNEW=K(IRNEW,JCOL)/MSTU(5)
70005 C...Begin search for colour recoiler when MODE = 2.
70006 ELSEIF (MODE.EQ.2) THEN
70008 IRNEW=K(IROLD,JCOL)/MSTU(5)
70009 140 IF (IRNEW.LE.0.OR.IRNEW.GT.N) THEN
70010 C...If no color partner found, pick at random among other primaries
70011 C...(e.g., when the color line is traced all the way to the beam)
70012 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70013 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70014 ELSEIF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
70015 C...Step up to mother if radiating parton already branched.
70016 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
70018 IRNEW=K(IROLD,JCOL)/MSTU(5)
70020 C...Pick sister by history if no anticolour available.
70022 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
70024 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
70027 C...Last resort: pick at random among other primaries.
70029 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70030 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70034 C...Trace down if sister branched.
70035 150 IF(K(IRNEW,1).GT.10) THEN
70036 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
70037 C...If no correct color-daughter found, swap.
70038 IF (IRTMP.EQ.0) THEN
70041 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
70046 ELSEIF (MODE.EQ.3) THEN
70047 C...The following will add MCT colour tracing for unprepped events
70048 C...If not done, trace Les Houches colour tags for this dipole
70050 IF (MCT(I,JCOL-3).EQ.0) THEN
70051 C...Special end code -1 : trace to color partner or 0, return in IEND
70053 CALL PYCTTR(I,JCOL,IEND)
70054 C...Clean up mother/daughter 'read' tags set by PYCTTR
70057 K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
70058 K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
70065 IF (K(IR,1).GT.0.AND.MCT(IR,6-JCOL).EQ.MCT(I,JCOL-3))
70069 C...If no color partner, then we hit beam
70070 IF (IEND.LE.0) THEN
70071 C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate
70072 IF (MSTP(72).LE.1) THEN
70076 C...Else try a random partner
70077 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70078 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70081 C...Else save recoiling colour partner
70087 C...Now found other end of colour dipole.
70092 C...Also electrical charge may radiate; so far only quarks and leptons.
70093 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
70094 & IABS(K(I,2)).LE.18) THEN
70096 C...Basic info about radiating parton.
70102 PTSCA(NEVOL)=PTPART(IP)
70104 C...Pick nearest (= smallest invariant mass) charged particle
70105 C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
70109 DO 190 IP2=1,NPART+N-MINT(53)
70110 IF(IP2.EQ.IP) GOTO 190
70111 IF(IP2.LE.NPART) THEN
70113 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
70114 IF(K(I2,1).GT.10) GOTO 190
70115 ELSEIF(K(I2,3).GT.MINT(84)) THEN
70116 IF(K(I2,3).GT.MINT(84)+2) GOTO 190
70118 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 190
70121 I2=MINT(53)+IP2-NPART
70123 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 190
70124 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
70125 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
70126 IF(PM2INV.LT.PM2MIN) THEN
70131 IF(IRNEW.EQ.0) THEN
70136 C...Begin search for charge recoiler when MODE = 2.
70139 C...Pick sister by history; step up if parton already branched.
70140 200 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
70144 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
70146 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
70148 C...Last resort: pick at random among other primaries.
70150 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70151 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70153 C...Trace down if sister branched.
70154 210 IF(K(IRNEW,1).GT.10) THEN
70155 DO 220 IR=IRNEW+1,N
70156 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
70166 C...End loop to set up showering partons. System invariant mass.
70168 IF(NEVOL.LE.0) RETURN
70169 IF (MODE.EQ.3.AND.NEVOL.LE.1) RETURN
70170 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
70172 C...Check if 3-jet matrix elements to be used.
70176 IF(MSTJ(47).GE.1) THEN
70178 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
70180 IPART1=K(IPART(1),3)
70181 IPART2=K(IPART(2),3)
70182 240 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
70183 KFSRCE=IABS(K(IPART1,2))
70184 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
70187 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
70192 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
70193 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
70194 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
70195 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
70196 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
70197 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
70198 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
70199 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
70201 C...Identify two primary showerers.
70202 KFLA1=IABS(K(IPART(1),2))
70204 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
70205 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
70206 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
70207 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
70208 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
70209 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
70210 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
70211 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
70212 KFLA2=IABS(K(IPART(2),2))
70214 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
70215 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
70216 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
70217 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
70218 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
70219 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
70220 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
70221 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
70223 C...Order of showerers. Presence of gluino.
70224 ITYPMN=MIN(ITYPE1,ITYPE2)
70225 ITYPMX=MAX(ITYPE1,ITYPE2)
70227 IF(ITYPE1.GT.ITYPE2) IORD=2
70229 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
70231 C...Require exactly two primary showerers for ME corrections.
70233 IF(IPART1.GT.0) THEN
70235 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
70238 IF(NPRIM.NE.2) THEN
70240 C...Predetermined and default matrix element kinds.
70241 ELSEIF(MSTJ(38).NE.0) THEN
70245 ELSEIF(MSTJ(47).GE.6) THEN
70251 C...Vector/axial vector -> q + qbar; q -> q + V.
70252 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
70253 & ITYPES.EQ.3)) THEN
70255 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
70257 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
70258 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
70259 C...gamma*/Z0: assume e+e- initial state if unknown.
70261 IF(KFSRCE.EQ.23) THEN
70263 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
70264 IF(IANNFL.GT.0) THEN
70265 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
70267 IF(IANNFL.NE.0) THEN
70268 KANNFL=IABS(K(IANNFL,2))
70269 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
70272 AI=SIGN(1D0,EI+0.1D0)
70273 VI=AI-4D0*EI*PARU(102)
70274 EF=KCHG(KFLA1,1)/3D0
70275 AF=SIGN(1D0,EF+0.1D0)
70276 VF=AF-4D0*EF*PARU(102)
70277 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
70280 SQWZ=PSUM(5)*PMAS(23,2)
70281 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
70282 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
70283 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
70284 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
70286 ALPHA=VECT/(VECT+AXIV)
70287 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
70290 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
70291 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
70293 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70294 & ITYPES.EQ.1)) THEN
70297 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
70298 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
70300 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
70302 ELSEIF(KFSRCE.EQ.36) THEN
70305 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70306 & ITYPES.EQ.1)) THEN
70309 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
70310 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70311 & ITYPES.EQ.3)) THEN
70313 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70314 & ITYPES.EQ.2)) THEN
70316 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
70318 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70319 & ITYPES.EQ.2)) THEN
70322 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
70323 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70324 & ITYPES.EQ.5)) THEN
70326 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70327 & ITYPES.EQ.2)) THEN
70329 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70330 & ITYPES.EQ.1)) THEN
70333 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
70334 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
70336 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70337 & ITYPES.EQ.2)) THEN
70339 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70340 & ITYPES.EQ.1)) THEN
70343 C...g -> ~g + ~g (eikonal approximation).
70344 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
70347 M3JC=5*ICLASS+ICOMBI
70350 C...Store pair that together define matrix element treatment.
70353 MESYS(NMESYS,0)=M3JC
70354 MESYS(NMESYS,1)=IPART(1)
70355 MESYS(NMESYS,2)=IPART(2)
70358 C...Store qqbar or l+l- pairs for QED radiation.
70359 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
70361 MESYS(NMESYS,0)=101
70362 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
70363 MESYS(NMESYS,1)=IPART(1)
70364 MESYS(NMESYS,2)=IPART(2)
70367 C...Store other qqbar/l+l- pairs from g/gamma branchings.
70369 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 290
70371 260 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
70375 C...Move up this check to avoid out-of-bounds.
70376 IF(I1M.EQ.0) GOTO 290
70377 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 290
70379 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 280
70381 270 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
70385 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
70391 MESYS(NMESYS,0)=102
70399 C..Loopback point for counting number of emissions.
70403 C...Begin loop to evolve all existing partons, if required.
70406 DO 380 IEVOL=1,NEVOL
70407 IF(IFLG(IEVOL).EQ.0) THEN
70409 C...Basic info on radiator and recoil.
70416 C...Invariant mass of "dipole".Starting value for pT evolution.
70417 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
70418 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
70420 C...Case of evolution by QCD branching.
70421 IF(ISCOL(IEVOL).NE.0) THEN
70423 C...Parton-by-parton maximum scale from initial conditions.
70424 IF(MSTP(72).EQ.0) THEN
70425 DO 320 IPRT=1,NPARTS
70426 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
70430 C...If kinematically impossible then do not evolve.
70431 IF(PT2.LT.PT2CMN) THEN
70436 C...Check if part of system for which ME corrections should be applied.
70438 DO 330 IME=1,NMESYS
70439 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
70440 & MESYS(IME,0).LT.100) IMESYS=IME
70443 C...Special flag for colour octet states.
70444 C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot.
70446 IF(K(I,2).EQ.21) MOCT=1
70448 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
70450 IF(K(I,2).EQ.5100021) MOCT=2
70452 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).EQ.9900101.AND.
70453 & IABS(K(I,2)).LE.9910555) MOCT=2
70457 C...Upper estimate for matrix element weighting and colour factor.
70458 C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
70461 IF(MOCT.GE.1) COLFAC=3D0/2D0
70462 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
70463 WTPSQQ=0.5D0*0.5D0*NFLAV
70465 C...Determine overestimated z range: switch at c and b masses.
70470 IF(PT2.GT.1.01D0*PMCS) THEN
70476 IF(PT2.GT.1.01D0*PMBS) THEN
70482 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
70483 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
70485 C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
70486 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
70489 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
70490 EVCOEF=EVCOEF+EVEMQQ
70493 C...Pick pT2 (in overestimated z range).
70494 350 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
70496 C...Loopback if crossed c/b mass thresholds.
70497 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
70501 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
70506 C...Finish if below lower cutoff.
70507 IF(PT2.LT.PT2CMN) THEN
70512 C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
70513 C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting
70515 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
70517 C...Pick z: dz/(1-z) or dz.
70518 IF(IFLAG.EQ.1) THEN
70519 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
70521 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
70524 C...Loopback if outside allowed range for given pT2.
70525 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
70526 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
70527 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
70528 PM2=PM2I+PT2/(Z*(1D0-Z))
70529 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
70531 C...No weighting for primary partons; to be done later on.
70532 IF(IMESYS.GT.0) THEN
70534 C...Weighting of q->qg/X->Xg branching.
70535 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
70536 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 350
70538 C...Weighting of g->gg branching.
70539 ELSEIF(IFLAG.EQ.1) THEN
70540 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 350
70542 C...Flavour choice and weighting of g->qqbar branching.
70544 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
70546 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
70547 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
70548 IF(WTME.LT.PYR(0)) GOTO 350
70552 C...Case of evolution by QED branching.
70553 ELSEIF(ISCHG(IEVOL).NE.0) THEN
70555 C...If kinematically impossible then do not evolve.
70557 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
70558 IF(PT2.LT.PT2EMN) THEN
70563 C...Check if part of system for which ME corrections should be applied.
70565 DO 360 IME=1,NMESYS
70566 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
70567 & MESYS(IME,0).GT.100) IMESYS=IME
70570 C...Charge. Matrix element weighting factor.
70571 CHG=ISCHG(IEVOL)/3D0
70574 C...Determine overestimated z range. Find evolution coefficient.
70575 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
70576 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
70577 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
70579 C...Pick pT2 (in overestimated z range).
70580 370 PT2=PT2*PYR(0)**(1D0/EVCOEF)
70582 C...Finish if below lower cutoff.
70583 IF(PT2.LT.PT2EMN) THEN
70588 C...Pick z: dz/(1-z).
70589 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
70591 C...Loopback if outside allowed range for given pT2.
70592 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
70593 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
70594 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 370
70595 PM2=PM2I+PT2/(Z*(1D0-Z))
70596 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 370
70598 C...Weighting by branching kernel, except if ME weighting later.
70599 IF(IMESYS.EQ.0) THEN
70600 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 370
70605 C...Save acceptable branching.
70607 IMESAV(IEVOL)=IMESYS
70613 C...Check if branching has highest pT.
70614 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
70616 PT2MX=PT2SAV(IEVOL)
70620 C...Finished if no more branchings to be done.
70621 IF(IMX.EQ.0) GOTO 500
70623 C...Restore info on hardest branching to be processed.
70634 PM2=PM2I+PT2/(Z*(1D0-Z))
70636 C...Special flag for colour octet states.
70638 IF(K(I,2).EQ.21) MOCT=1
70639 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
70640 IF(K(I,2).EQ.5100021) MOCT=2
70642 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).GE.9900101.AND.
70643 & IABS(K(I,2)).LE.9910555) MOCT=2
70646 C...Restore further info for g->qqbar branching.
70648 IF(IFLG(IMX).GT.10) THEN
70651 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
70654 C...For branching g include azimuthal asymmetries from polarization.
70656 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
70657 C...Trace grandmother via intermediate recoil copies.
70660 390 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
70661 & K(IM,3).GT.0) THEN
70663 IF(IM.GT.MINT(84)) GOTO 390
70666 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
70667 & KFGM=IABS(K(IGM,2))
70668 C...Define approximate energy sharing by identifying aunt.
70670 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
70671 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
70672 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
70673 C...Coefficient from gluon production.
70675 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
70677 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
70679 C...Coefficient from gluon decay.
70681 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
70683 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
70688 C...Create new slots for branching products and recoil.
70694 C...Set status, flavour and mother of new ones.
70697 IF(KCHA.NE.0) K(IGNEW,1)=1
70702 IF(KCHA.NE.0) K(IGNEW,2)=22
70704 K(INEW,2)=-ISIGN(KFQ,KCOL)
70705 K(IGNEW,2)=-K(INEW,2)
70712 C...Find rest frame and angles of branching+recoil.
70718 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
70719 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
70720 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
70721 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
70722 PHI=PYANGL(P(INEW,1),P(INEW,2))
70723 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
70725 C...Derive kinematics of branching: generics (like g->gg).
70730 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
70731 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
70732 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
70733 PTCOR=SQRT(MAX(0D0,PT2COR))
70734 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
70735 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
70736 C...Specific kinematics reduction for q->qg with m_q > 0.
70738 PTCOR=(1D0-PM2I/PM2)*PTCOR
70739 PZN=PZN+PM2I*PZG/PM2
70740 PZG=(1D0-PM2I/PM2)*PZG
70741 C...Specific kinematics reduction for g->qqbar with m_q > 0.
70742 ELSEIF(KFQ.NE.0) THEN
70746 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
70750 C...Pick phi and construct kinematics of branching.
70751 420 PHIROT=PARU(2)*PYR(0)
70752 P(INEW,1)=PTCOR*COS(PHIROT)
70753 P(INEW,2)=PTCOR*SIN(PHIROT)
70755 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
70756 P(IGNEW,1)=-P(INEW,1)
70757 P(IGNEW,2)=-P(INEW,2)
70759 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
70763 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
70765 C...Boost branching system to lab frame.
70766 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
70768 C...Renew choice of phi angle according to polarization asymmetry.
70769 IF(ABS(ASYPOL).GT.1D-3) THEN
70775 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
70776 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
70777 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
70779 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
70780 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
70782 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
70783 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
70784 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
70785 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
70786 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
70787 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
70792 C...Matrix element corrections for primary partons when requested.
70793 IF(IMESYS.GT.0) THEN
70794 M3JC=MESYS(IMESYS,0)
70796 C...Identify recoiling partner and set up three-body kinematics.
70797 IRP=MESYS(IMESYS,1)
70798 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
70799 IF(IRP.EQ.IR) IRP=IRNEW
70801 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
70803 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
70805 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
70806 & PSUM(3)*P(INEW,3))/PSUM(5)**2
70807 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
70808 & PSUM(3)*P(IRP,3))/PSUM(5)**2
70810 R1ME=P(INEW,5)/PSUM(5)
70811 R2ME=P(IRP,5)/PSUM(5)
70813 C...Matrix elements for gluon emission.
70814 IF(M3JC.LT.100) THEN
70816 C...Call ME, with right order important for two inequivalent showerers.
70817 IF(MESYS(IMESYS,IORD).EQ.I) THEN
70818 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
70820 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
70823 C...Split up total ME when two radiating partons.
70825 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
70826 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
70827 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
70828 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
70829 & MAX(1D-10,2D0-X1-X2)
70831 C...Evaluate shower rate.
70832 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
70833 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70834 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
70836 C...Matrix elements for photon emission: still rather primitive.
70839 C...For generic charge combination currently only massless expression.
70840 IF(M3JC.EQ.101) THEN
70841 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
70842 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
70843 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
70844 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
70846 C...For flavour neutral system assume vector source and include masses.
70848 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
70849 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
70850 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
70851 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70855 C...Perform weighting with W_ME/W_PS.
70856 IF(WME.LT.PYR(0)*WPS) THEN
70864 C...Now for sure accepted branching. Save highest pT.
70865 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
70867 C...Update status for obsolete ones. Bookkkep the moved original parton
70868 C...and new daughter (arbitrary choice for g->gg or g->qqbar).
70869 C...Do not bookkeep radiated photon, since it cannot radiate further.
70873 IF(IPART(IP).EQ.I) IPART(IP)=INEW
70874 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
70881 C...Initialize colour flow of branching.
70882 C...Use both old and new style colour tags for flexibility.
70896 C...Trivial colour flow for l->lgamma and q->qgamma.
70897 IF(IABS(KCHA).EQ.3) THEN
70900 ELSEIF(KCHA.NE.0) THEN
70901 IF(K(I,4).NE.0) THEN
70903 K(INEW,4)=MSTU(5)*I
70904 MCT(INEW,1)=MCT(I,1)
70906 IF(K(I,5).NE.0) THEN
70908 K(INEW,5)=MSTU(5)*I
70909 MCT(INEW,2)=MCT(I,2)
70912 C...Set colour flow for q->qg and g->gg.
70913 ELSEIF(KFQ.EQ.0) THEN
70914 K(I,JCOLP)=K(I,JCOLP)+IGNEW
70915 K(IGNEW,JCOLP)=MSTU(5)*I
70916 K(INEW,JCOLP)=MSTU(5)*IGNEW
70917 K(IGNEW,JCOLN)=MSTU(5)*INEW
70918 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
70920 MCT(INEW,JCOLP-3)=NCT
70921 MCT(IGNEW,JCOLN-3)=NCT
70923 K(I,JCOLN)=K(I,JCOLN)+INEW
70924 K(INEW,JCOLN)=MSTU(5)*I
70925 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
70928 C...Set colour flow for g->qqbar.
70930 K(I,JCOLN)=K(I,JCOLN)+INEW
70931 K(INEW,JCOLN)=MSTU(5)*I
70932 K(I,JCOLP)=K(I,JCOLP)+IGNEW
70933 K(IGNEW,JCOLP)=MSTU(5)*I
70934 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
70935 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
70938 C...Daughter info for colourless recoiling parton.
70939 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
70945 C...Colour of recoiling parton sails through unchanged.
70947 IF(K(IR,4).NE.0) THEN
70948 K(IR,4)=K(IR,4)+IRNEW
70949 K(IRNEW,4)=MSTU(5)*IR
70950 MCT(IRNEW,1)=MCT(IR,1)
70952 IF(K(IR,5).NE.0) THEN
70953 K(IR,5)=K(IR,5)+IRNEW
70954 K(IRNEW,5)=MSTU(5)*IR
70955 MCT(IRNEW,2)=MCT(IR,2)
70959 C...Vertex information trivial.
70966 C...Update list of old radiators.
70967 DO 480 IEVOL=1,NEVOL
70968 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
70970 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
70973 ELSEIF(IPOS(IEVOL).EQ.I) THEN
70976 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
70979 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
70981 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
70985 C...Update links of old connected partons.
70986 IF(IREC(IEVOL).EQ.I) THEN
70989 ELSEIF(IREC(IEVOL).EQ.IR) THEN
70995 C...q->qg or g->gg: create new gluon radiators.
70996 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
71003 PTSCA(NEVOL)=SQRT(PT2)
71010 PTSCA(NEVOL)=PTSCA(NEVOL-1)
71013 C...Update matrix elements parton list and add new for g/gamma->qqbar.
71014 DO 490 IME=1,NMESYS
71015 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
71016 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
71017 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
71018 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
71023 MESYS(NMESYS,1)=INEW
71024 MESYS(NMESYS,2)=IGNEW
71026 MESYS(NMESYS,0)=102
71027 MESYS(NMESYS,1)=INEW
71028 MESYS(NMESYS,2)=IGNEW
71031 C...Global statistics.
71032 MINT(353)=MINT(353)+1
71033 VINT(353)=VINT(353)+PTCOR
71034 IF (MINT(353).EQ.1) VINT(358)=PTCOR
71036 C...Loopback for more emissions if enough space.
71038 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
71039 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
71042 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
71051 C*********************************************************************
71054 C...Auxiliary to PYSHOW and PYPTFS.
71055 C...Matrix elements for gluon (or photon) emission from
71056 C...a two-body state; to be used by the parton shower routine.
71057 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
71058 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
71059 C... = (alpha-strong/2 pi) * CF * PYMAEL,
71060 C...i.e. normalization is such that one recovers the familiar
71061 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
71062 C...Coupling structure:
71063 C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
71064 C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
71065 C... = 16-19 : q -> q V
71066 C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
71067 C... = 26-29 : q -> q S
71068 C... = 31-34 : V -> ~q ~qbar (~q = squark)
71069 C... = 36-39 : ~q -> ~q V
71070 C... = 41-44 : S -> ~q ~qbar
71071 C... = 46-49 : ~q -> ~q S
71072 C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
71073 C... = 56-59 : ~q -> q chi
71074 C... = 61-64 : q -> ~q chi
71075 C... = 66-69 : ~g -> q ~qbar
71076 C... = 71-74 : ~q -> q ~g
71077 C... = 76-79 : q -> ~q ~g
71078 C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
71079 C...Note that the order of the decay products is important.
71080 C...In each set of four, the variants are ordered as:
71081 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
71082 C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
71083 C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
71084 C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
71086 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
71088 C...Double precision and integer declarations.
71089 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71090 IMPLICIT INTEGER(I-N)
71092 C...Check input values. Return zero outside allowed phase space.
71094 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
71095 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
71096 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
71097 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
71098 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
71099 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
71101 C...Initial values and flags.
71109 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
71111 C...Eikonal expression; also acts as default.
71112 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
71114 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
71116 ELSEIF(ICOMBI.EQ.2) THEN
71117 ANUM=(2D0-X1-X2)**2
71118 ELSEIF(ICOMBI.EQ.3) THEN
71119 ANUM=ALPCOR*(2D0-X1-X2)**2
71121 ANUM=0.5D0*(2D0-X1-X2)**2
71123 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
71124 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
71125 & R1**2/(1D0+R2**2-R1**2-X2)**2-
71126 & R2**2/(1D0+R1**2-R2**2-X1)**2)
71129 C...V -> q qbar (V = gamma*/Z0/W+-/...).
71130 ELSEIF(ICLASS.EQ.2) THEN
71131 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71132 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
71133 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
71134 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
71135 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
71136 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
71137 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
71138 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
71139 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
71140 & (-1+R1**2-R2**2+X2)**2
71141 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
71142 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
71143 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
71144 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
71145 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
71146 & -X1-X2)**2+X1*(2-X1-X2)**2)/
71147 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71148 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
71149 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
71150 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
71151 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
71152 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
71156 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71157 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
71158 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
71159 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
71160 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
71161 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
71162 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
71163 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
71164 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
71165 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
71166 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
71167 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
71168 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
71169 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
71170 & -X1-X2)**2+X1*(2-X1-X2)**2)/
71171 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71172 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
71173 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
71174 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
71175 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
71176 & +X2)/(-1-R1**2+R2**2+X1)**2
71180 IF(ICOMBI.EQ.4) THEN
71181 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
71182 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
71183 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
71184 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
71185 & (-1-R1**2+R2**2+X1)**2
71187 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
71188 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
71189 & -R1**2*X2**2+X1*X2**2)/
71190 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71191 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
71192 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
71193 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
71194 & (-1+R1**2-R2**2+X2)**2
71200 ELSEIF(ICLASS.EQ.3) THEN
71201 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71202 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
71203 & +R1**2*R2**2-2D0*R2**4)
71204 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
71205 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
71206 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
71207 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
71208 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
71209 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
71210 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
71211 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
71212 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
71213 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
71214 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71215 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71216 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
71217 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
71218 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
71219 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
71220 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71221 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
71222 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
71225 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71226 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
71227 & +R1**2*R2**2-2D0*R2**4)
71228 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
71229 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
71230 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
71231 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
71232 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
71233 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
71234 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71235 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
71236 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
71237 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
71238 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71239 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71240 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
71241 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
71242 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
71243 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
71244 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71245 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
71246 & +X1*X2**2)/(-2+X1+X2)**2
71249 IF(ICOMBI.EQ.4) THEN
71250 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
71251 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
71252 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
71253 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
71254 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
71255 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71256 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
71257 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
71258 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71259 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71260 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
71261 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
71262 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
71263 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71264 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
71265 & +X1*X2**2)/(2-X1-X2)**2
71269 C...S -> q qbar (S = h0/H0/A0/H+-/...).
71270 ELSEIF(ICLASS.EQ.4) THEN
71271 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71272 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
71273 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71274 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71275 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71276 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
71277 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
71278 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71279 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71280 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71281 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71284 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71285 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
71286 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71287 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71288 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71289 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71290 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
71291 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71292 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
71293 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
71294 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
71295 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71298 IF(ICOMBI.EQ.4) THEN
71299 RLO4=PS*(1D0-R1**2-R2**2)
71300 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
71301 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71302 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
71303 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
71304 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71305 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
71306 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71311 ELSEIF(ICLASS.EQ.5) THEN
71312 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71313 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71314 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
71315 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71316 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
71317 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71318 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
71319 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
71320 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71321 & (-1+R1**2-R2**2+X2)**2
71324 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71325 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
71326 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
71327 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71328 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
71329 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71330 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
71331 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
71332 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71333 & (-1+R1**2-R2**2+X2)**2
71336 IF(ICOMBI.EQ.4) THEN
71337 RLO4=PS*(1D0+R1**2-R2**2)
71338 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
71339 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71340 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
71341 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
71342 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
71343 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
71347 C...V -> ~q ~qbar (~q = squark).
71348 ELSEIF(ICLASS.EQ.6) THEN
71349 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
71350 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
71351 & (-1-R1**2+R2**2+X1)**2
71352 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
71353 & (-1-R1**2+R2**2+X1)
71354 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
71355 & /(-1+R1**2-R2**2+X2)**2
71356 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
71357 & (-1+R1**2-R2**2+X2)
71358 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
71359 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
71360 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
71361 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71365 ELSEIF(ICLASS.EQ.7) THEN
71366 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
71367 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
71368 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
71369 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
71370 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
71371 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
71372 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
71373 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
71374 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
71375 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
71376 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
71382 ELSEIF(ICLASS.EQ.8) THEN
71384 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
71385 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
71386 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
71387 & -R1**2*X2**2+X1*X2**2)/
71388 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
71393 ELSEIF(ICLASS.EQ.9) THEN
71395 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71396 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71397 & -(X1+X2)/(-2+X1+X2)**2
71400 C...chi -> q ~qbar (chi = neutralino/chargino).
71401 ELSEIF(ICLASS.EQ.10) THEN
71402 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71403 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71404 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
71405 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
71406 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
71407 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71408 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
71409 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71410 & (-1+R1**2-R2**2+X2)**2
71413 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71414 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
71415 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
71416 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
71417 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
71418 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71419 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
71420 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71421 & (-1+R1**2-R2**2+X2)**2
71424 IF(ICOMBI.EQ.4) THEN
71425 RLO4=PS*(1+R1**2-R2**2)
71426 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
71427 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
71428 & +X2+R1**2*X2-X1*X2/2)/
71429 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71430 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
71431 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
71436 ELSEIF(ICLASS.EQ.11) THEN
71437 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71438 RLO1=PS*(1D0-(R1+R2)**2)
71439 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
71440 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71441 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71442 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71443 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
71444 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71445 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71448 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71449 RLO2=PS*(1D0-(R1-R2)**2)
71450 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
71452 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71453 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
71454 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71455 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
71456 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71457 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71460 IF(ICOMBI.EQ.4) THEN
71461 RLO4=PS*(1D0-R1**2-R2**2)
71462 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
71463 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
71464 & +3*R1**2*X2-R2**2*X2-X1*X2)/
71465 & (-1+R1**2-R2**2+X2)**2
71466 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
71467 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
71468 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71473 ELSEIF(ICLASS.EQ.12) THEN
71474 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71475 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
71476 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71477 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
71478 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
71479 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
71480 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71481 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71484 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71485 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
71486 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
71487 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
71488 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
71489 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
71490 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71491 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71494 IF(ICOMBI.EQ.4) THEN
71495 RLO4=PS*(1D0-R1**2+R2**2)
71496 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71497 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
71498 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
71499 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
71500 & +R1**2*X2-X1*X2/2-X2**2/2)/
71501 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71506 ELSEIF(ICLASS.EQ.13) THEN
71507 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71508 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71509 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
71510 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
71511 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
71512 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
71513 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
71514 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
71515 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
71516 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
71517 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
71518 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
71519 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
71520 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71521 & (3*(-1+R1**2-R2**2+X2)**2)
71525 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71526 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
71527 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
71528 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
71529 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71530 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
71531 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
71532 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
71533 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
71534 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
71535 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
71536 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71537 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
71538 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
71539 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71540 & (3*(-1+R1**2-R2**2+X2)**2)
71544 IF(ICOMBI.EQ.4) THEN
71545 RLO4=PS*(1D0+R1**2-R2**2)
71546 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
71547 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
71548 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
71549 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
71550 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
71551 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71552 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
71553 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71554 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
71555 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71556 & (3*(-1+R1**2-R2**2+X2)**2)
71562 ELSEIF(ICLASS.EQ.14) THEN
71563 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71564 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
71565 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
71566 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71567 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71568 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
71569 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
71570 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
71571 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
71572 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71573 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71574 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
71575 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
71576 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
71577 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
71579 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
71580 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71581 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71585 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71586 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
71587 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
71588 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71589 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71590 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
71591 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
71592 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
71593 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
71594 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
71595 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
71596 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
71598 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
71599 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
71600 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
71601 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
71602 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
71603 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71607 IF(ICOMBI.EQ.4) THEN
71608 RLO4=PS*(1-R1**2-R2**2)
71609 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
71610 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
71611 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71612 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
71613 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
71614 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
71615 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
71616 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
71617 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
71618 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
71619 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
71620 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
71621 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
71622 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
71623 RFO4=9D0*RFO4/128D0
71628 ELSEIF(ICLASS.EQ.15) THEN
71629 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71630 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
71631 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
71632 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
71633 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
71634 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
71635 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
71636 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
71637 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
71638 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
71639 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
71640 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
71641 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
71642 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
71643 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
71644 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71648 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71649 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
71650 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
71651 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
71652 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
71653 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
71654 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
71655 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
71656 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
71657 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
71658 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71659 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
71660 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
71661 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
71662 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71663 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71667 IF(ICOMBI.EQ.4) THEN
71668 RLO4=PS*(1D0-R1**2+R2**2)
71669 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
71670 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
71671 & -R2**2*X2/2-X1*X2/2)/
71672 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
71673 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
71674 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71675 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
71676 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
71677 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
71678 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
71679 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
71680 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71685 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
71686 ELSEIF(ICLASS.EQ.16) THEN
71688 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
71690 ELSEIF(ICOMBI.EQ.2) THEN
71691 ANUM=(2D0-X1-X2)**2
71692 ELSEIF(ICOMBI.EQ.3) THEN
71693 ANUM=ALPCOR*(2D0-X1-X2)**2
71695 ANUM=0.5D0*(2D0-X1-X2)**2
71697 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
71698 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
71699 & R1**2/(1D0+R2**2-R1**2-X2)**2-
71700 & R2**2/(1D0+R1**2-R2**2-X1)**2)
71705 C...Find relevant LO and FO expression.
71706 IF(ICOMBI.EQ.0) THEN
71707 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
71710 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
71713 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
71714 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
71715 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
71716 ELSEIF(ISSET4.EQ.1) THEN
71719 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
71720 RLO=0.5D0*(RLO1+RLO2)
71721 RFO=0.5D0*(RFO1+RFO2)
71722 ELSEIF(ISSET1.EQ.1) THEN
71726 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
71737 C*********************************************************************
71740 C...Modifies an event so as to approximately take into account
71741 C...Bose-Einstein effects according to a simple phenomenological
71742 C...parametrization.
71744 SUBROUTINE PYBOEI(NSAV)
71746 C...Double precision and integer declarations.
71747 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71748 IMPLICIT INTEGER(I-N)
71749 INTEGER PYK,PYCHGE,PYCOMP
71750 C...Parameter statement to help give large particle numbers.
71751 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71752 &KEXCIT=4000000,KDIMEN=5000000)
71754 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71755 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71756 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71757 COMMON/PYINT1/MINT(400),VINT(400)
71758 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
71759 C...Local arrays and data.
71760 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
71761 &BEIW(100),BEI3W(100)
71762 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
71763 C...Statement function: squared invariant mass.
71764 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
71765 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
71767 C...Boost event to overall CM frame. Calculate CM energy.
71768 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
71774 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
71775 & .AND.K(I,3).GT.0) THEN
71776 KFMA=IABS(K(K(I,3),2))
71777 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
71779 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
71781 DPS(J)=DPS(J)+P(I,J)
71784 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
71788 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
71791 C...Check if we have separated strings
71793 C...Reserve copy of particles by species at end of record.
71799 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
71800 NBE(IBE)=NBE(IBE-1)
71802 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
71803 DO 140 IIBE=1,IBE-1
71804 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
71807 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
71809 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
71810 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
71811 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
71814 NBE(IBE)=NBE(IBE)+1
71821 P(NBE(IBE),1)=0.0D0
71822 P(NBE(IBE),2)=0.0D0
71823 P(NBE(IBE),3)=0.0D0
71824 P(NBE(IBE),4)=0.0D0
71825 P(NBE(IBE),5)=0.0D0
71826 SMMIN=MIN(SMMIN,P(I,5))
71827 C...Check if particles comes from different W's or Z's
71828 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
71830 150 IF(K(IM,3).GT.0) THEN
71832 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
71834 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
71835 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
71836 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
71837 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
71840 C...Check if particles comes from different strings.
71841 IF(PARJ(94).GT.0.0D0) THEN
71843 160 IF(K(IM,3).GT.0) THEN
71845 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
71853 P(NBE(IBE),5)=-1.0D0
71856 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
71858 C...Calculate separation between W+ and W- or between two Z0's.
71859 C...No separation if there has been re-connections.
71861 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
71862 IF(K(IWP,2).EQ.23) THEN
71871 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
71872 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
71873 TAUP=-TAUPD*LOG(PYR(IDUM))
71874 TAUN=-TAUND*LOG(PYR(IDUM))
71875 DXP=TAUP*PYP(IWP,8)/DMP
71876 DXN=TAUN*PYP(IWN,8)/DMN
71878 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
71879 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
71882 C...Add separation between strings.
71883 IF(PARJ(94).GT.0.0D0) THEN
71884 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
71889 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
71890 DO 220 IBE=1,MIN(9,MSTJ(52))
71891 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
71894 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
71895 IF(I2M.EQ.I1M) GOTO 200
71897 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
71898 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
71899 & (P(I1,5)+P(I2,5))**2
71900 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
71909 C...Tabulate integral for subsequent momentum shift.
71910 DO 400 IBE=1,MIN(9,MSTJ(52))
71911 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
71912 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
71914 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
71915 & NBE(7)-NBE(6)).LE.1) GOTO 270
71916 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
71917 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
71918 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
71919 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
71920 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
71921 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
71922 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
71923 QDELW=0.1D0*MIN(PMHQ,SIGW)
71924 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
71925 IF(MSTJ(51).EQ.1) THEN
71926 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
71927 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
71928 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
71929 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
71930 BEEX=EXP(0.5D0*QDEL/PARJ(93))
71931 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
71932 BEEXW=EXP(0.5D0*QDELW/SIGW)
71933 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
71934 BERT=EXP(-QDEL/PARJ(93))
71935 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
71936 BERTW=EXP(-QDELW/SIGW)
71937 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
71939 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
71940 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
71941 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
71942 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
71945 QBIN=QDEL*(IBIN-0.5D0)
71946 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71947 IF(MSTJ(51).EQ.1) THEN
71949 BEI(IBIN)=BEI(IBIN)*BEEX
71951 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
71953 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
71955 DO 240 IBIN=1,NBIN3
71956 QBIN=QDEL3*(IBIN-0.5D0)
71957 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71958 IF(MSTJ(51).EQ.1) THEN
71960 BEI3(IBIN)=BEI3(IBIN)*BEEX3
71962 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
71964 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
71966 DO 250 IBIN=1,NBINW
71967 QBIN=QDELW*(IBIN-0.5D0)
71968 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71969 IF(MSTJ(51).EQ.1) THEN
71971 BEIW(IBIN)=BEIW(IBIN)*BEEXW
71973 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
71975 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
71977 DO 260 IBIN=1,NBIN3W
71978 QBIN=QDEL3W*(IBIN-0.5D0)
71979 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
71980 & SQRT(QBIN**2+PMHQ**2)
71981 IF(MSTJ(51).EQ.1) THEN
71982 BEEX3W=BEEX3W*BERT3W
71983 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
71985 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
71987 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
71990 C...Loop through particle pairs and find old relative momentum.
71991 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
71993 DO 380 I2M=I1M+1,NBE(IBE)
71994 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
71995 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
71997 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
71998 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
71999 IF(Q2OLD.LE.0.0D0) GOTO 380
72002 C...Calculate new relative momentum.
72007 IF(QOLD.LT.1D-3*QDEL) THEN
72009 ELSEIF(QOLD.LE.QDEL) THEN
72011 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
72014 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
72015 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
72016 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72018 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72020 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
72021 IF(QOLD.LT.1D-3*QDEL3) THEN
72023 ELSEIF(QOLD.LE.QDEL3) THEN
72025 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
72028 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
72029 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
72030 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72032 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72034 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
72037 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
72038 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
72039 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
72041 IF(QOLD.LT.1D-3*QDELW) THEN
72043 ELSEIF(QOLD.LE.QDELW) THEN
72045 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
72048 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
72049 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
72050 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72052 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72054 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
72055 IF(QOLD.LT.1D-3*QDEL3W) THEN
72057 ELSEIF(QOLD.LE.QDEL3W) THEN
72059 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
72062 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
72063 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
72064 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72066 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72068 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
72070 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
72072 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
72074 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
72075 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
72077 IF(MSTJ(54).GE.1) THEN
72078 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
72080 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
72081 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
72083 ELSEIF(MSTJ(54).LE.-1) THEN
72084 EDEL=P(I1,4)+P(I2,4)-
72085 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
72086 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
72087 & (P(I1,3)-P(I2,3))**2
72092 SM1=(P(I1,5)+SMMIN)**2
72093 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72094 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
72095 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
72096 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
72097 & K(I3M,5).NE.K(I1M,5)) GOTO 360
72099 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
72102 SM3=(P(I3,5)+SMMIN)**2
72103 IF(MSTJ(54).EQ.-2) THEN
72104 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
72105 & S23*MIN(SM1,SM3))*SM1)
72107 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
72108 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
72109 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
72110 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
72112 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
72113 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
72116 IF(WMAX*WI.GE.1.0) GOTO 360
72118 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
72119 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
72120 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
72121 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
72122 & K(I4M,5).NE.K(I1M,5)) GOTO 350
72124 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
72126 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
72127 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
72128 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
72130 IF(MSTJ(54).EQ.-2) THEN
72134 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
72135 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
72136 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
72137 W=MIN(W,MIN(S23,S24)*S13*S14)
72140 C...weight=1-cos(theta)/mtot2
72141 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
72142 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
72143 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
72144 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
72146 IF(W.LE.WMAX) GOTO 350
72148 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
72149 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
72150 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
72151 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
72152 IF(W.LE.WMAX) GOTO 350
72158 IF(MI4.EQ.0) GOTO 380
72161 EOLD=P(I3,4)+P(I4,4)
72163 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
72164 & (P(I3,3)+P(I4,3))**2
72165 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
72166 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
72167 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
72169 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
72170 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
72177 C...Shift momenta and recalculate energies.
72181 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72185 P(I,J)=P(I,J)+P(IM,J)
72187 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72190 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
72195 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
72196 440 ALPHA=(ESUMP-ESUM)/PROD
72197 PARJ(96)=PARJ(96)+ALPHA
72200 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72203 P(I,J)=P(I,J)+ALPHA*V(IM,J)
72205 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72208 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
72211 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
72215 C...Rescale all momenta for energy conservation.
72219 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
72221 PQS=PQS+P(I,5)**2/P(I,4)
72224 FAC=(PECM-PQS)/(PES-PQS)
72226 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
72230 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72233 C...Boost back to correct reference frame.
72234 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
72236 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
72242 C*********************************************************************
72245 C...Calculates the momentum shift in a system of two particles assuming
72246 C...the relative momentum squared should be shifted to Q2NEW. NI is the
72247 C...last position occupied in /PYJETS/.
72249 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
72251 C...Double precision and integer declarations.
72252 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72253 IMPLICIT INTEGER(I-N)
72254 INTEGER PYK,PYCHGE,PYCOMP
72255 C...Parameter statement to help give large particle numbers.
72256 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72257 &KEXCIT=4000000,KDIMEN=5000000)
72259 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72260 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72261 SAVE /PYJETS/,/PYDAT1/
72262 C...Local arrays and data.
72266 IF(MSTJ(55).EQ.0) THEN
72268 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
72269 & (P(I1,3)-P(I2,3))**2
72270 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
72271 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
72275 DA=SE*DE*DP12-DP2*DQ2SE
72276 DB=DP2*DQ2SE-DP12**2
72277 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
72279 PD=HA*(P(I1,J)-P(I2,J))
72291 DP(J)=P(I1,J)+P(I2,J)
72294 C...Boost to cms and rotate first particle to z-axis
72295 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
72296 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
72297 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
72298 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
72299 S=Q2NEW+(P(I1,5)+P(I2,5))**2
72300 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
72304 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
72308 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
72309 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
72310 CALL PYROBO(NI+1,NI+2,THE,PHI,
72311 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
72314 P(NI+1,J)=P(NI+1,J)-P(I1,J)
72315 P(NI+2,J)=P(NI+2,J)-P(I2,J)
72321 C*********************************************************************
72324 C...Gives the mass of a particle/parton.
72326 FUNCTION PYMASS(KF)
72328 C...Double precision and integer declarations.
72329 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72330 IMPLICIT INTEGER(I-N)
72331 INTEGER PYK,PYCHGE,PYCOMP
72333 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72334 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72335 SAVE /PYDAT1/,/PYDAT2/
72337 C...Reset variables. Compressed code. Special case for popcorn diquarks.
72346 C...Guarantee use of constituent masses for internal checks.
72347 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
72348 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
72350 PYMASS=PARF(100+KFA)
72351 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
72352 ELSEIF(KFA.LE.10) THEN
72354 ELSEIF(MSTJ(93).EQ.1) THEN
72355 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
72357 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
72360 C...Other masses can be read directly off table.
72365 C...Optional mass broadening according to truncated Breit-Wigner
72366 C...(either in m or in m^2).
72367 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
72368 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
72369 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
72370 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
72373 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
72374 & (PM0*PMAS(KC,2)))
72375 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
72376 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
72377 & (PMUPP-PMLOW)*PYR(0))))
72385 C*********************************************************************
72388 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
72389 C...for Higgs couplings. Everything else sent on to PYMASS.
72391 FUNCTION PYMRUN(KF,Q2)
72393 C...Double precision and integer declarations.
72394 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72395 IMPLICIT INTEGER(I-N)
72396 INTEGER PYK,PYCHGE,PYCOMP
72398 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72399 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72400 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
72401 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
72403 C...Most masses not handled here.
72405 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
72408 C...Current-algebra masses, but no Q2 dependence.
72409 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
72410 PYMRUN=PARF(90+KFA)
72412 C...Running current-algebra masses.
72415 PYMRUN=PARF(90+KFA)*
72416 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
72417 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
72423 C*********************************************************************
72426 C...Gives the particle/parton name as a character string.
72428 SUBROUTINE PYNAME(KF,CHAU)
72430 C...Double precision and integer declarations.
72431 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72432 IMPLICIT INTEGER(I-N)
72433 INTEGER PYK,PYCHGE,PYCOMP
72435 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72436 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72437 COMMON/PYDAT4/CHAF(500,2)
72439 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
72440 C...Local character variable.
72443 C...Read out code with distinction particle/antiparticle.
72446 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
72452 C*********************************************************************
72455 C...Gives three times the charge for a particle/parton.
72457 FUNCTION PYCHGE(KF)
72459 C...Double precision and integer declarations.
72460 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72461 IMPLICIT INTEGER(I-N)
72462 INTEGER PYK,PYCHGE,PYCOMP
72464 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72467 C...Read out charge and change sign for antiparticle.
72470 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
72475 C*********************************************************************
72478 C...Compress the standard KF codes for use in mass and decay arrays;
72479 C...also checks whether a given code actually is defined.
72481 FUNCTION PYCOMP(KF)
72483 C...Double precision and integer declarations.
72484 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72485 IMPLICIT INTEGER(I-N)
72486 INTEGER PYK,PYCHGE,PYCOMP
72488 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72489 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72490 SAVE /PYDAT1/,/PYDAT2/
72491 C...Local arrays and saved data.
72492 DIMENSION KFORD(100:500),KCORD(101:500)
72493 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
72495 C...Whenever necessary reorder codes for faster search.
72496 IF(MSTU(20).EQ.0) THEN
72501 IF(KFA.LE.100) GOTO 120
72503 DO 100 I1=NFORD-1,0,-1
72504 IF(KFA.GE.KFORD(I1)) GOTO 110
72505 KFORD(I1+1)=KFORD(I1)
72506 KCORD(I1+1)=KCORD(I1)
72508 110 KFORD(I1+1)=KFA
72516 C...Fast action if same code as in latest call.
72517 IF(KF.EQ.KFLAST) THEN
72522 C...Starting values. Remove internal diquark flags.
72525 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
72526 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
72528 C...Simple cases: direct translation.
72529 IF(KFA.GT.KFORD(NFORD)) THEN
72530 ELSEIF(KFA.LE.100) THEN
72533 C...Else binary search.
72537 130 IAVG=(IMIN+IMAX)/2
72538 IF(KFORD(IAVG).GT.KFA) THEN
72540 IF(IMAX.GT.IMIN+1) GOTO 130
72541 ELSEIF(KFORD(IAVG).LT.KFA) THEN
72543 IF(IMAX.GT.IMIN+1) GOTO 130
72549 C...Check if antiparticle allowed.
72550 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
72551 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
72554 C...Save codes for possible future fast action.
72561 C*********************************************************************
72564 C...Informs user of errors in program execution.
72566 SUBROUTINE PYERRM(MERR,CHMESS)
72568 C...Double precision and integer declarations.
72569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72570 IMPLICIT INTEGER(I-N)
72571 INTEGER PYK,PYCHGE,PYCOMP
72573 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72574 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72575 SAVE /PYJETS/,/PYDAT1/
72576 C...Local character variable.
72577 CHARACTER CHMESS*(*)
72579 C...Write first few warnings, then be silent.
72580 IF(MERR.LE.10) THEN
72581 MSTU(27)=MSTU(27)+1
72583 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
72584 & MERR,MSTU(31),CHMESS
72586 C...Write first few errors, then be silent or stop program.
72587 ELSEIF(MERR.LE.20) THEN
72588 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
72589 MSTU(30)=MSTU(30)+1
72591 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
72592 & MERR-10,MSTU(31),CHMESS
72593 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
72594 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
72595 WRITE(MSTU(11),5200)
72596 IF(MERR.NE.17) CALL PYLIST(2)
72600 C...Stop program in case of irreparable error.
72602 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
72606 C...Formats for output.
72607 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
72608 &' PYEXEC calls:'/5X,A)
72609 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
72610 &' PYEXEC calls:'/5X,A)
72611 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
72613 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
72614 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
72619 C*********************************************************************
72622 C...Calculates the running alpha_electromagnetic.
72624 FUNCTION PYALEM(Q2)
72626 C...Double precision and integer declarations.
72627 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72628 IMPLICIT INTEGER(I-N)
72629 INTEGER PYK,PYCHGE,PYCOMP
72631 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72634 C...Calculate real part of photon vacuum polarization.
72635 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
72636 C...For hadrons use parametrization of H. Burkhardt et al.
72637 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
72638 AEMPI=PARU(101)/(3D0*PARU(1))
72639 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
72641 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
72643 ELSEIF(MSTU(101).EQ.2) THEN
72644 RPIGG=1D0-PARU(101)/PARU(103)
72645 ELSEIF(Q2.LT.0.09D0) THEN
72646 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
72647 ELSEIF(Q2.LT.9D0) THEN
72648 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
72649 & 0.00238D0*LOG(1D0+3.927D0*Q2)
72650 ELSEIF(Q2.LT.1D4) THEN
72651 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
72652 & 0.00299D0*LOG(1D0+Q2)
72654 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
72655 & 0.00293D0*LOG(1D0+Q2)
72658 C...Calculate running alpha_em.
72659 PYALEM=PARU(101)/(1D0-RPIGG)
72665 C*********************************************************************
72668 C...Gives the value of alpha_strong.
72670 FUNCTION PYALPS(Q2)
72672 C...Double precision and integer declarations.
72673 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72674 IMPLICIT INTEGER(I-N)
72675 INTEGER PYK,PYCHGE,PYCOMP
72677 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72678 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72679 SAVE /PYDAT1/,/PYDAT2/
72680 C...Coefficients for second-order threshold matching.
72681 C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
72682 DIMENSION STEPDN(6),STEPUP(6)
72683 c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
72684 c &(2D0*321D0/3703D0),0D0/
72685 c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
72686 c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
72687 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
72688 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
72690 C...Constant alpha_strong trivial. Pick artificial Lambda.
72691 IF(MSTU(111).LE.0) THEN
72693 MSTU(118)=MSTU(112)
72695 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
72696 & ((33D0-2D0*MSTU(112))*PARU(111)))
72697 PARU(118)=PARU(111)
72701 C...Find effective Q2, number of flavours and Lambda.
72703 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
72706 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
72707 Q2THR=PARU(113)*PMAS(NF,1)**2
72708 IF(Q2EFF.LT.Q2THR) THEN
72711 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
72712 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
72716 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
72717 Q2THR=PARU(113)*PMAS(NF+1,1)**2
72718 IF(Q2EFF.GT.Q2THR) THEN
72721 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
72722 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
72726 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
72727 PARU(117)=SQRT(ALAM2)
72729 C...Evaluate first or second order alpha_strong.
72730 B0=(33D0-2D0*NF)/6D0
72731 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
72732 IF(MSTU(111).EQ.1) THEN
72733 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
72735 B1=(153D0-19D0*NF)/6D0
72736 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
72745 C*********************************************************************
72748 C...Reconstructs an angle from given x and y coordinates.
72750 FUNCTION PYANGL(X,Y)
72752 C...Double precision and integer declarations.
72753 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72754 IMPLICIT INTEGER(I-N)
72755 INTEGER PYK,PYCHGE,PYCOMP
72757 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72762 IF(R.LT.1D-20) RETURN
72763 IF(ABS(X)/R.LT.0.8D0) THEN
72764 PYANGL=SIGN(ACOS(X/R),Y)
72767 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
72768 PYANGL=PARU(1)-PYANGL
72769 ELSEIF(X.LT.0D0) THEN
72770 PYANGL=-PARU(1)-PYANGL
72777 C*********************************************************************
72780 C...Performs rotations and boosts.
72782 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
72784 C...Double precision and integer declarations.
72785 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72786 IMPLICIT INTEGER(I-N)
72787 INTEGER PYK,PYCHGE,PYCOMP
72789 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72790 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72791 SAVE /PYJETS/,/PYDAT1/
72793 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
72795 C...Find and check range of rotation/boost.
72797 IF(IMIN.LE.0) IMIN=1
72798 IF(MSTU(1).GT.0) IMIN=MSTU(1)
72800 IF(IMAX.LE.0) IMAX=N
72801 IF(MSTU(2).GT.0) IMAX=MSTU(2)
72802 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
72803 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
72807 C...Optional resetting of V (when not set before.)
72808 IF(MSTU(33).NE.0) THEN
72809 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
72817 C...Rotate, typically from z axis to direction (theta,phi).
72818 IF(THE**2+PHI**2.GT.1D-20) THEN
72819 ROT(1,1)=COS(THE)*COS(PHI)
72821 ROT(1,3)=SIN(THE)*COS(PHI)
72822 ROT(2,1)=COS(THE)*SIN(PHI)
72824 ROT(2,3)=SIN(THE)*SIN(PHI)
72829 IF(K(I,1).LE.0) GOTO 140
72835 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
72836 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
72841 C...Boost, typically from rest to momentum/energy=beta.
72842 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
72846 DB=SQRT(DBX**2+DBY**2+DBZ**2)
72848 IF(DB.GT.EPS1) THEN
72849 C...Rescale boost vector if too close to unity.
72850 CALL PYERRM(3,'(PYROBO:) boost vector too large')
72856 DGA=1D0/SQRT(1D0-DB**2)
72858 IF(K(I,1).LE.0) GOTO 160
72863 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
72864 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
72865 P(I,1)=DP(1)+DGABP*DBX
72866 P(I,2)=DP(2)+DGABP*DBY
72867 P(I,3)=DP(3)+DGABP*DBZ
72868 P(I,4)=DGA*(DP(4)+DBP)
72869 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
72870 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
72871 V(I,1)=DV(1)+DGABV*DBX
72872 V(I,2)=DV(2)+DGABV*DBY
72873 V(I,3)=DV(3)+DGABV*DBZ
72874 V(I,4)=DGA*(DV(4)+DBV)
72881 C*********************************************************************
72884 C...Performs global manipulations on the event record, in particular
72885 C...to exclude unstable or undetectable partons/particles.
72887 SUBROUTINE PYEDIT(MEDIT)
72889 C...Double precision and integer declarations.
72890 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72891 IMPLICIT INTEGER(I-N)
72892 INTEGER PYK,PYCHGE,PYCOMP
72893 C...Parameter statement to help give large particle numbers.
72894 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72895 &KEXCIT=4000000,KDIMEN=5000000)
72897 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72898 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72899 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72900 COMMON/PYCTAG/NCT,MCT(4000,2)
72901 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
72903 DIMENSION NS(2),PTS(2),PLS(2)
72905 C...Remove unwanted partons/particles.
72906 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
72908 IF(MSTU(2).GT.0) IMAX=MSTU(2)
72909 I1=MAX(1,MSTU(1))-1
72910 DO 110 I=MAX(1,MSTU(1)),IMAX
72911 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
72912 IF(MEDIT.EQ.1) THEN
72913 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72914 ELSEIF(MEDIT.EQ.2) THEN
72915 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72917 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72918 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72919 & K(I,2).EQ.KSUSY1+39) GOTO 110
72920 ELSEIF(MEDIT.EQ.3) THEN
72921 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72923 IF(KC.EQ.0) GOTO 110
72924 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
72925 ELSEIF(MEDIT.EQ.5) THEN
72926 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
72928 IF(KC.EQ.0) GOTO 110
72929 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
72930 & KCHG(KC,2).EQ.0) GOTO 110
72933 C...Pack remaining partons/particles. Origin no longer known.
72942 IF(I1.LT.N) MSTU(3)=0
72943 IF(I1.LT.N) MSTU(70)=0
72946 C...Selective removal of class of entries. New position of retained.
72947 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
72950 K(I,3)=MOD(K(I,3),MSTU(5))
72951 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
72952 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
72953 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
72954 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
72955 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
72956 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
72957 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
72959 K(I,3)=K(I,3)+MSTU(5)*I1
72962 C...Find new event history information and replace old.
72964 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
72965 & K(I,3)/MSTU(5).EQ.0) GOTO 140
72967 130 IM=MOD(K(ID,3),MSTU(5))
72968 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
72969 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
72970 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
72974 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
72975 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
72976 & K(IM,2).EQ.94) THEN
72981 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
72982 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
72983 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
72984 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
72985 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
72986 & K(K(I,4),3)/MSTU(5)
72987 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
72988 & K(K(I,5),3)/MSTU(5)
72990 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
72991 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
72992 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
72993 KCD=MOD(K(I,4),MSTU(5))
72994 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
72995 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
72996 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
72997 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
72998 KCD=MOD(K(I,5),MSTU(5))
72999 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
73000 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
73004 C...Pack remaining entries.
73009 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
73016 C...Also update LHA1 colour tags
73019 K(I1,3)=MOD(K(I1,3),MSTU(5))
73021 IF(I.EQ.MSTU(90+IZ)) THEN
73022 MSTU(90)=MSTU(90)+1
73023 MSTU(90+MSTU(90))=I1
73024 PARU(90+MSTU(90))=PARU(90+IZ)
73028 IF(I1.LT.N) MSTU(3)=0
73029 IF(I1.LT.N) MSTU(70)=0
73032 C...Fill in some missing daughter pointers (lost in colour flow).
73033 ELSEIF(MEDIT.EQ.16) THEN
73035 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
73036 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
73037 C...Find daughters who point to mother.
73039 IF(K(I1,3).NE.I) THEN
73040 ELSEIF(K(I,4).EQ.0) THEN
73046 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73047 IF(K(I,4).NE.0) GOTO 220
73048 C...Find daughters who point to documentation version of mother.
73050 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
73051 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
73052 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
73054 IF(K(I1,3).NE.IM) THEN
73055 ELSEIF(K(I,4).EQ.0) THEN
73061 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73062 IF(K(I,4).NE.0) GOTO 220
73063 C...Find daughters who point to documentation daughters who,
73064 C...in their turn, point to documentation mother.
73068 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
73070 IF(ID1.EQ.IM) ID1=I1
73074 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
73075 ELSEIF(K(I,4).EQ.0) THEN
73081 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73084 C...Save top entries at bottom of PYJETS commonblock.
73085 ELSEIF(MEDIT.EQ.21) THEN
73086 IF(2*N.GE.MSTU(4)) THEN
73087 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
73092 K(MSTU(4)-I,J)=K(I,J)
73093 P(MSTU(4)-I,J)=P(I,J)
73094 V(MSTU(4)-I,J)=V(I,J)
73099 C...Restore bottom entries of commonblock PYJETS to top.
73100 ELSEIF(MEDIT.EQ.22) THEN
73101 DO 260 I=1,MSTU(32)
73103 K(I,J)=K(MSTU(4)-I,J)
73104 P(I,J)=P(MSTU(4)-I,J)
73105 V(I,J)=V(MSTU(4)-I,J)
73110 C...Mark primary entries at top of commonblock PYJETS as untreated.
73111 ELSEIF(MEDIT.EQ.23) THEN
73116 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
73118 IF(KH.NE.0) GOTO 280
73120 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
73121 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
73125 C...Place largest axis along z axis and second largest in xy plane.
73126 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
73127 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
73128 & P(MSTU(61),2)),0D0,0D0,0D0)
73129 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
73130 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
73131 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
73132 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
73133 IF(MEDIT.EQ.31) RETURN
73135 C...Rotate to put slim jet along +z axis.
73142 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
73143 IF(MSTU(41).GE.2) THEN
73145 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73146 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73147 & K(I,2).EQ.KSUSY1+39) GOTO 300
73148 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
73151 IS=2D0-SIGN(0.5D0,P(I,3))
73153 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
73155 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
73156 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
73158 C...Rotate to put second largest jet into -z,+x quadrant.
73160 IF(P(I,3).GE.0D0) GOTO 310
73161 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
73162 IF(MSTU(41).GE.2) THEN
73164 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73165 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73166 & K(I,2).EQ.KSUSY1+39) GOTO 310
73167 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
73170 IS=2D0-SIGN(0.5D0,P(I,1))
73171 PLS(IS)=PLS(IS)-P(I,3)
73173 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
73180 C*********************************************************************
73183 C...Gives program heading, or lists an event, or particle
73184 C...data, or current parameter values.
73186 SUBROUTINE PYLIST(MLIST)
73188 C...Double precision and integer declarations.
73189 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73190 IMPLICIT INTEGER(I-N)
73191 INTEGER PYK,PYCHGE,PYCOMP
73192 C...Parameter statement to help give large particle numbers.
73193 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
73194 &KEXCIT=4000000,KDIMEN=5000000)
73196 C...HEPEVT commonblock.
73197 PARAMETER (NMXHEP=4000)
73198 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
73199 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
73200 DOUBLE PRECISION PHEP,VHEP
73203 C...User process event common block.
73205 PARAMETER (MAXNUP=500)
73206 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
73207 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
73208 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
73209 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
73210 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
73214 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73215 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73216 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73217 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
73218 COMMON/PYCTAG/NCT,MCT(4000,2)
73219 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
73220 C...Local arrays, character variables and data.
73221 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
73223 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
73225 C...Initialization printout: version number and date of last change.
73226 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
73229 IF(MLIST.EQ.0) RETURN
73232 C...List event data, including additional lines after N.
73233 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
73234 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
73235 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
73236 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
73237 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
73239 IF(MLIST.GE.2) LMX=16
73242 IF(MSTU(2).GT.0) IMAX=MSTU(2)
73243 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
73244 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
73245 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
73246 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
73248 C...Get particle name, pad it and check it is not too long.
73249 CALL PYNAME(K(I,2),CHAP)
73252 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
73256 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
73258 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
73261 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
73263 CHAC=CHDL(MDL)(1:2*LDL)//' '
73265 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
73266 & CHDL(MDL)(LDL+1:2*LDL)//' '
73267 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
73271 C...Add information on string connection.
73272 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
73276 IF(KC.NE.0) KCC=KCHG(KC,2)
73277 IF(IABS(K(I,2)).EQ.39) THEN
73278 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
73279 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
73281 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
73282 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
73283 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
73284 ELSEIF(KCC.NE.0) THEN
73286 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
73289 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
73290 & CHAC(LMX-1:LMX-1)='I'
73292 C...Write data for particle/jet.
73293 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
73294 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
73296 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
73297 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
73299 ELSEIF(MLIST.EQ.1) THEN
73300 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
73302 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
73303 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
73304 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
73305 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
73306 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
73308 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
73309 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
73310 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
73311 & ,10000),MCT(I,1),MCT(I,2)
73313 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
73315 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
73316 & ,MCT(I,1),MCT(I,2)
73318 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
73320 C...Insert extra separator lines specified by user.
73321 IF(MSTU(70).GE.1) THEN
73323 DO 110 J=1,MIN(10,MSTU(70))
73324 IF(I.EQ.MSTU(70+J)) ISEP=1
73327 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
73328 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
73329 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
73334 C...Sum of charges and momenta.
73338 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
73339 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
73340 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
73341 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
73342 ELSEIF(MLIST.EQ.1) THEN
73343 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
73344 ELSEIF(MLIST.LE.3) THEN
73345 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
73347 WRITE(MSTU(11),7000) PS(6)
73350 C...Simple listing of HEPEVT entries (mainly for test purposes).
73351 ELSEIF(MLIST.EQ.5) THEN
73352 WRITE(MSTU(11),7100)
73354 IF(ISTHEP(I).EQ.0) GOTO 140
73355 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
73356 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
73360 C...Simple listing of user-process entries (mainly for test purposes).
73361 ELSEIF(MLIST.EQ.7) THEN
73362 WRITE(MSTU(11),7300)
73364 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
73365 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
73368 C...Give simple list of KF codes defined in program.
73369 ELSEIF(MLIST.EQ.11) THEN
73370 WRITE(MSTU(11),7500)
73372 CALL PYNAME(KF,CHAP)
73373 CALL PYNAME(-KF,CHAN)
73374 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
73375 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73379 DO 170 KFLB=1,KFLA-(3-KFLS)/2
73380 KF=1000*KFLA+100*KFLB+KFLS
73381 CALL PYNAME(KF,CHAP)
73382 CALL PYNAME(-KF,CHAN)
73383 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73389 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
73390 IF(KMUL.EQ.5) KFLS=5
73392 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
73393 IF(KMUL.EQ.4) KFLR=2
73395 DO 200 KFLC=1,KFLB-1
73396 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
73397 CALL PYNAME(KF,CHAP)
73398 CALL PYNAME(-KF,CHAN)
73399 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73402 CALL PYNAME(KFK,CHAP)
73403 WRITE(MSTU(11),7600) KFK,CHAP
73405 CALL PYNAME(KFK,CHAP)
73406 WRITE(MSTU(11),7600) KFK,CHAP
73409 KF=10000*KFLR+110*KFLB+KFLS
73410 CALL PYNAME(KF,CHAP)
73411 WRITE(MSTU(11),7600) KF,CHAP
73415 CALL PYNAME(KF,CHAP)
73416 WRITE(MSTU(11),7600) KF,CHAP
73418 CALL PYNAME(KF,CHAP)
73419 WRITE(MSTU(11),7600) KF,CHAP
73425 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
73427 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
73428 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
73429 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
73430 CALL PYNAME(KF,CHAP)
73431 CALL PYNAME(-KF,CHAN)
73432 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73439 IF(KF.LT.1000000) GOTO 270
73440 CALL PYNAME(KF,CHAP)
73441 CALL PYNAME(-KF,CHAN)
73442 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
73443 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73446 C...List parton/particle data table. Check whether to be listed.
73447 ELSEIF(MLIST.EQ.12) THEN
73448 WRITE(MSTU(11),7700)
73449 DO 300 KC=1,MSTU(6)
73451 IF(KF.EQ.0) GOTO 300
73452 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
73455 C...Find particle name and mass. Print information.
73456 CALL PYNAME(KF,CHAP)
73457 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
73458 CALL PYNAME(-KF,CHAN)
73459 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
73460 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
73462 C...Particle decay: channel number, branching ratios, matrix element,
73463 C...decay products.
73464 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73466 CALL PYNAME(KFDP(IDC,J),CHAD(J))
73468 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
73473 C...List parameter value table.
73474 ELSEIF(MLIST.EQ.13) THEN
73475 WRITE(MSTU(11),8000)
73477 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
73481 C...Format statements for output on unit MSTU(11) (by default 6).
73482 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
73483 &5X,'KF orig p_x p_y p_z E m'/)
73484 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
73485 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73486 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
73487 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
73488 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73489 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
73490 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
73491 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
73492 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
73493 & ,' C tag AC tag'/)
73494 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
73495 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
73496 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
73497 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
73498 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
73499 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
73500 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
73501 6200 FORMAT(66X,5(1X,F12.3))
73502 6300 FORMAT(1X,78('='))
73503 6400 FORMAT(1X,130('='))
73504 6500 FORMAT(1X,65('='))
73505 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
73506 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
73507 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
73508 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
73510 7000 FORMAT(19X,'sum charge:',F6.2)
73511 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
73512 &//' I IST ID Mothers Daughters p_x p_y p_z',
73514 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
73515 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
73516 &//' I IST ID Mothers Colours p_x p_y p_z',
73518 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
73519 7500 FORMAT(///20X,'List of KF codes in program'/)
73520 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
73521 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
73522 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
73523 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
73524 &1X,'ME',3X,'Br.rat.',4X,'decay products')
73525 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
73526 &1X,1P,E13.5,3X,I2)
73527 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
73528 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
73529 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
73530 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
73535 C*********************************************************************
73538 C...Writes a logo for the program.
73542 C...Double precision and integer declarations.
73543 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73544 IMPLICIT INTEGER(I-N)
73545 INTEGER PYK,PYCHGE,PYCOMP
73546 C...Parameter for length of information block.
73547 PARAMETER (IREFER=21)
73549 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73550 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
73551 SAVE /PYDAT1/,/PYPARS/
73552 C...Local arrays and character variables.
73554 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
73555 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
73557 C...Data on months, logo, titles, and references.
73558 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
73559 &'Oct','Nov','Dec'/
73560 DATA (LOGO(J),J=1,19)/
73562 &' *:::!!:::::::::::* ',
73563 &' *::::::!!::::::::::::::* ',
73564 &' *::::::::!!::::::::::::::::* ',
73565 &' *:::::::::!!:::::::::::::::::* ',
73566 &' *:::::::::!!:::::::::::::::::* ',
73567 &' *::::::::!!::::::::::::::::*! ',
73568 &' *::::::!!::::::::::::::* !! ',
73569 &' !! *:::!!:::::::::::* !! ',
73570 &' !! !* -><- * !! ',
73580 DATA (LOGO(J),J=20,38)/
73581 &'Welcome to the Lund Monte Carlo!',
73583 &'PPP Y Y TTTTT H H III A ',
73584 &'P P Y Y T H H I A A ',
73585 &'PPP Y T HHHHH I AAAAA',
73586 &'P Y T H H I A A',
73587 &'P Y T H H III A A',
73589 &'This is PYTHIA version x.xxx ',
73590 &'Last date of change: xx xxx 200x',
73592 &'Now is xx xxx 200x at xx:xx:xx ',
73594 &'Disclaimer: this program comes ',
73595 &'without any guarantees. Beware ',
73596 &'of errors and use common sense ',
73597 &'when interpreting results. ',
73599 &'Copyright T. Sjostrand (2008) '/
73600 DATA (REFER(J),J=1,14)/
73601 &'An archive of program versions and d',
73602 &'ocumentation is found on the web: ',
73603 &'http://www.thep.lu.se/~torbjorn/Pyth',
73607 &'When you cite this program, the offi',
73608 &'cial reference is to the 6.4 manual:',
73609 &'T. Sjostrand, S. Mrenna and P. Skand',
73610 &'s, JHEP05 (2006) 026 ',
73611 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
73612 &'-T) [hep-ph/0603175]. ',
73615 DATA (REFER(J),J=15,32)/
73616 &'Also remember that the program, to a',
73617 &' large extent, represents original ',
73618 &'physics research. Other publications',
73619 &' of special relevance to your ',
73620 &'studies may therefore deserve separa',
73624 &'Main author: Torbjorn Sjostrand; Dep',
73625 &'artment of Theoretical Physics, ',
73626 &' Lund University, Solvegatan 14A, S',
73627 &'-223 62 Lund, Sweden; ',
73628 &' phone: + 46 - 46 - 222 48 16; e-ma',
73629 &'il: torbjorn@thep.lu.se ',
73630 &'Author: Stephen Mrenna; Computing Di',
73631 &'vision, GDS Group, ',
73632 &' Fermi National Accelerator Laborat',
73633 &'ory, MS 234, Batavia, IL 60510, USA;'/
73634 DATA (REFER(J),J=33,2*IREFER)/
73635 &' phone: + 1 - 630 - 840 - 2556; e-m',
73636 &'ail: mrenna@fnal.gov ',
73637 &'Author: Peter Skands; Theoretical Ph',
73638 &'ysics Department, ',
73639 &' Fermi National Accelerator Laborat',
73640 &'ory, MS 106, Batavia, IL 60510, USA;',
73641 &' and CERN/PH, CH-1211 Geneva, Switz',
73643 &' phone: + 41 - 22 - 767 24 59; e-ma',
73644 &'il: skands@fnal.gov '/
73646 C...Check that PYDATA linked.
73647 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
73649 & 'Error: PYDATA has not been linked.'
73650 WRITE(*,'(1X,A)') 'Execution stopped!'
73653 C...Write current version number and current date+time.
73655 WRITE(VERS,'(I1)') MSTP(181)
73656 LOGO(28)(24:24)=VERS
73657 WRITE(SUBV,'(I3)') MSTP(182)
73658 LOGO(28)(26:28)=SUBV
73659 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
73660 WRITE(DATE,'(I2)') MSTP(185)
73661 LOGO(29)(22:23)=DATE
73662 LOGO(29)(25:27)=MONTH(MSTP(184))
73663 WRITE(YEAR,'(I4)') MSTP(183)
73664 LOGO(29)(29:32)=YEAR
73666 IF(IDATI(1).LE.0) THEN
73669 WRITE(DATE,'(I2)') IDATI(3)
73671 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
73672 WRITE(YEAR,'(I4)') IDATI(1)
73673 LOGO(31)(15:18)=YEAR
73674 WRITE(HOUR,'(I2)') IDATI(4)
73675 LOGO(31)(23:24)=HOUR
73676 WRITE(MINU,'(I2)') IDATI(5)
73677 LOGO(31)(26:27)=MINU
73678 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
73679 WRITE(SECO,'(I2)') IDATI(6)
73680 LOGO(31)(29:30)=SECO
73681 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
73685 C...Loop over lines in header. Define page feed and side borders.
73686 DO 100 ILIN=1,29+IREFER
73695 C...Separator lines and logos.
73696 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
73697 LINE(4:77)='***********************************************'//
73698 & '***************************'
73699 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
73700 LINE(6:37)=LOGO(ILIN-5)
73701 LINE(44:75)=LOGO(ILIN+14)
73702 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
73703 LINE(5:40)=REFER(2*ILIN-51)
73704 LINE(41:76)=REFER(2*ILIN-50)
73707 C...Write lines to appropriate unit.
73708 WRITE(MSTU(11),'(A79)') LINE
73714 C*********************************************************************
73717 C...Facilitates the updating of particle and decay data
73718 C...by allowing it to be done in an external file.
73720 SUBROUTINE PYUPDA(MUPDA,LFN)
73722 C...Double precision and integer declarations.
73723 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73724 IMPLICIT INTEGER(I-N)
73725 INTEGER PYK,PYCHGE,PYCOMP
73727 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73728 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73729 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
73730 COMMON/PYDAT4/CHAF(500,2)
73732 COMMON/PYINT4/MWID(500),WIDS(500,5)
73733 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
73734 C...Local arrays, character variables and data.
73735 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
73736 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
73737 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
73738 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
73739 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
73740 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
73741 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
73743 C...Write header if not yet done.
73744 IF(MSTU(12).NE.12345) CALL PYLIST(0)
73746 C...Write information on file for editing.
73747 IF(MUPDA.EQ.1) THEN
73749 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
73750 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
73751 & MWID(KC),MDCY(KC,1)
73752 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73753 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
73754 & (KFDP(IDC,J),J=1,5)
73758 C...Read complete set of information from edited file or
73759 C...read partial set of new or updated information from edited file.
73760 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
73762 C...Reset counters.
73766 IF(MUPDA.EQ.2) THEN
73771 DO 130 KC=1,MSTU(6)
73772 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
73773 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
73777 C...Begin of loop: read new line; unknown whether particle or
73779 140 READ(LFN,5200,END=190) CHINL
73781 C...Identify particle code and whether already defined (for MUPDA=3).
73782 IF(CHINL(2:10).NE.' ') THEN
73785 IF(MUPDA.EQ.2) THEN
73798 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
73801 C...Remove duplicate old decay data.
73802 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
73803 IDCREP=MDCY(KCREP,2)
73804 NDCREP=MDCY(KCREP,3)
73806 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
73808 DO 180 I=IDCREP,NDC-NDCREP
73809 MDME(I,1)=MDME(I+NDCREP,1)
73810 MDME(I,2)=MDME(I+NDCREP,2)
73811 BRAT(I)=BRAT(I+NDCREP)
73813 KFDP(I,J)=KFDP(I+NDCREP,J)
73818 ELSEIF(KCREP.NE.0) THEN
73826 C...Study line with particle data.
73827 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
73828 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
73829 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
73830 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
73831 & MWID(KC),MDCY(KC,1)
73835 C...Study line with decay data.
73838 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
73839 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
73840 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
73841 MDCY(KC,3)=MDCY(KC,3)+1
73842 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
73843 & (KFDP(NDC,J),J=1,5)
73846 C...End of loop; ensure that PYCOMP tables are updated.
73851 C...Perform possible tests that new information is consistent.
73852 DO 220 KC=1,MSTU(6)
73854 IF(KF.EQ.0) GOTO 220
73855 WRITE(CHKF,5300) KF
73856 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
73857 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
73858 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
73860 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73861 IF(MDME(IDC,2).GT.80) GOTO 210
73863 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
73867 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
73869 ELSEIF(PYCOMP(KP).EQ.0) THEN
73874 PMS=PMS-PMAS(KPC,1)
73875 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
73879 IF(KQ.NE.0) MERR=MAX(2,MERR)
73880 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
73882 IF(MERR.EQ.3) CALL PYERRM(17,
73883 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
73884 IF(MERR.EQ.2) CALL PYERRM(17,
73885 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
73886 IF(MERR.EQ.1) CALL PYERRM(7,
73887 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
73888 BRSUM=BRSUM+BRAT(IDC)
73890 WRITE(CHTMP,5500) BRSUM
73891 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
73892 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
73893 & CHTMP(9:16)//' for KF ='//CHKF)
73896 C...Write DATA statements for inclusion in program.
73897 ELSEIF(MUPDA.EQ.4) THEN
73899 C...Find out how many codes and decay channels are actually used.
73903 IF(KCHG(I,4).NE.0) THEN
73905 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
73909 C...Initialize writing of DATA statements for inclusion in program.
73912 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
73915 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
73919 C...Loop through variables for conversion to characters.
73921 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
73922 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
73923 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
73924 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
73925 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
73926 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
73927 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
73928 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
73929 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
73930 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
73931 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
73932 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
73933 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
73934 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
73935 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
73936 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
73937 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
73938 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
73939 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
73940 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
73941 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
73942 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
73944 C...Replace variables beyond what is properly defined.
73946 IF(IDIM.GT.KCC) CHTMP=' 0'
73947 ELSEIF(IVAR.LE.8) THEN
73948 IF(IDIM.GT.KCC) CHTMP=' 0.0'
73949 ELSEIF(IVAR.LE.11) THEN
73950 IF(IDIM.GT.KCC) CHTMP=' 0'
73951 ELSEIF(IVAR.LE.13) THEN
73952 IF(IDIM.GT.NDC) CHTMP=' 0'
73953 ELSEIF(IVAR.LE.14) THEN
73954 IF(IDIM.GT.NDC) CHTMP=' 0.0'
73955 ELSEIF(IVAR.LE.19) THEN
73956 IF(IDIM.GT.NDC) CHTMP=' 0'
73957 ELSEIF(IVAR.LE.21) THEN
73958 IF(IDIM.GT.KCC) CHTMP=' '
73960 IF(IDIM.GT.KCC) CHTMP=' 0'
73963 C...Length of variable, trailing decimal zeros, quotation marks.
73967 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
73968 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
73970 CHNEW=CHTMP(LLOW:LHIG)//' '
73972 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
73975 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
73976 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
73981 CHNEW(LNEW+1:LNEW+2)='D0'
73984 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
73985 DO 260 LL=LNEW,1,-1
73986 IF(CHNEW(LL:LL).EQ.'''') THEN
73988 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
73994 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
73998 C...Form composite character string, often including repetition counter.
73999 IF(CHNEW.NE.CHOLD) THEN
74006 IF(NRPT.GE.2) LRPT=LNEW+3
74007 IF(NRPT.GE.10) LRPT=LNEW+4
74008 IF(NRPT.GE.100) LRPT=LNEW+5
74009 IF(NRPT.GE.1000) LRPT=LNEW+6
74012 WRITE(CHTMP,5400) NRPT
74014 IF(NRPT.GE.10) LRPT=2
74015 IF(NRPT.GE.100) LRPT=3
74016 IF(NRPT.GE.1000) LRPT=4
74017 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
74021 C...Add characters to end of line, to new line (after storing old line),
74022 C...or to new block of lines (after writing old block).
74023 IF(LLIN+LCOM.LE.70) THEN
74024 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
74026 ELSEIF(NLIN.LE.19) THEN
74027 CHLIN(LLIN+1:72)=' '
74030 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
74033 CHLIN(LLIN:72)='/'//' '
74035 WRITE(CHTMP,5400) IDIM-NRPT
74036 CHBLK(1)(30:33)=CHTMP(13:16)
74038 WRITE(LFN,5700) CHBLK(ILIN)
74042 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
74043 & ',I= , )/'//CHCOM(1:LCOM)//','
74044 WRITE(CHTMP,5400) IDIM-NRPT+1
74045 CHLIN(25:28)=CHTMP(13:16)
74050 C...Write final block of lines.
74051 CHLIN(LLIN:72)='/'//' '
74053 WRITE(CHTMP,5400) NDIM
74054 CHBLK(1)(30:33)=CHTMP(13:16)
74056 WRITE(LFN,5700) CHBLK(ILIN)
74061 C...Formats for reading and writing particle data.
74062 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
74063 5100 FORMAT(10X,2I5,F12.6,5I10)
74074 C*********************************************************************
74077 C...Provides various integer-valued event related data.
74081 C...Double precision and integer declarations.
74082 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74083 IMPLICIT INTEGER(I-N)
74084 INTEGER PYK,PYCHGE,PYCOMP
74086 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74087 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74088 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74089 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74091 C...Default value. For I=0 number of entries, number of stable entries
74092 C...or 3 times total charge.
74094 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
74095 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
74097 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
74099 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
74100 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
74103 ELSEIF(I.EQ.0) THEN
74105 C...For I > 0 direct readout of K matrix or charge.
74106 ELSEIF(J.LE.5) THEN
74108 ELSEIF(J.EQ.6) THEN
74111 C...Status (existing/fragmented/decayed), parton/hadron separation.
74112 ELSEIF(J.LE.8) THEN
74113 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
74114 IF(J.EQ.8) PYK=PYK*K(I,2)
74115 ELSEIF(J.LE.12) THEN
74119 IF(KC.NE.0) KQ=KCHG(KC,2)
74120 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
74121 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
74123 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
74125 C...Heaviest flavour in hadron/diquark.
74126 ELSEIF(J.EQ.13) THEN
74128 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
74129 IF(KFA.LT.10) PYK=KFA
74130 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
74131 PYK=PYK*ISIGN(1,K(I,2))
74133 C...Particle history: generation, ancestor, rank.
74134 ELSEIF(J.LE.15) THEN
74141 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
74144 ELSEIF(J.EQ.16) THEN
74146 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
74147 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
74154 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
74155 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
74157 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
74158 IF(ILP.EQ.1) GOTO 120
74160 IF(K(I1,1).EQ.12) THEN
74162 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
74163 & .AND.K(I3,2).NE.93) PYK=PYK+1
74169 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
74173 C...Particle coming from collapsing jet system or not.
74174 ELSEIF(J.EQ.17) THEN
74181 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
74182 IF(PYK.EQ.1) PYK=-1
74186 IF(KCHG(KC,2).EQ.0) GOTO 150
74187 IF(K(I1,1).NE.12) PYK=0
74188 IF(K(I1,1).NE.12) RETURN
74191 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
74193 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
74195 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
74197 C...Number of decay products. Colour flow.
74198 ELSEIF(J.EQ.18) THEN
74199 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
74200 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
74201 ELSEIF(J.LE.22) THEN
74202 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
74203 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
74204 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
74205 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
74206 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
74213 C*********************************************************************
74216 C...Provides various real-valued event related data.
74220 C...Double precision and integer declarations.
74221 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74222 IMPLICIT INTEGER(I-N)
74223 INTEGER PYK,PYCHGE,PYCOMP
74225 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74226 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74227 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74228 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74232 C...Set default value. For I = 0 sum of momenta or charges,
74233 C...or invariant mass of system.
74235 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
74236 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
74238 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
74240 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
74244 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
74248 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
74249 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
74251 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
74253 ELSEIF(I.EQ.0) THEN
74255 C...Direct readout of P matrix.
74256 ELSEIF(J.LE.5) THEN
74259 C...Charge, total momentum, transverse momentum, transverse mass.
74260 ELSEIF(J.LE.12) THEN
74261 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
74262 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
74263 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
74264 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
74265 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
74267 C...Theta and phi angle in radians or degrees.
74268 ELSEIF(J.LE.16) THEN
74269 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
74270 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
74271 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
74273 C...True rapidity, rapidity with pion mass, pseudorapidity.
74274 ELSEIF(J.LE.19) THEN
74276 IF(J.EQ.17) PMR=P(I,5)
74277 IF(J.EQ.18) PMR=PYMASS(211)
74278 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
74279 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
74282 C...Energy and momentum fractions (only to be used in CM frame).
74283 ELSEIF(J.LE.25) THEN
74284 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
74285 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
74286 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
74287 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
74288 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
74289 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
74295 C*********************************************************************
74298 C...Performs sphericity tensor analysis to give sphericity,
74299 C...aplanarity and the related event axes.
74301 SUBROUTINE PYSPHE(SPH,APL)
74303 C...Double precision and integer declarations.
74304 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74305 IMPLICIT INTEGER(I-N)
74306 INTEGER PYK,PYCHGE,PYCOMP
74307 C...Parameter statement to help give large particle numbers.
74308 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74309 &KEXCIT=4000000,KDIMEN=5000000)
74311 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74312 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74313 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74314 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74316 DIMENSION SM(3,3),SV(3,3)
74318 C...Calculate matrix to be diagonalized.
74327 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
74328 IF(MSTU(41).GE.2) THEN
74330 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74331 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74332 & K(I,2).EQ.KSUSY1+39) GOTO 140
74333 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74337 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74339 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
74340 & MAX(1D-10,PA)**(PARU(41)-2D0)
74343 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
74349 C...Very low multiplicities (0 or 1) not considered.
74351 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
74358 SM(J1,J2)=SM(J1,J2)/PS
74362 C...Find eigenvalues to matrix (third degree equation).
74363 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
74364 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
74365 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
74366 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
74367 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
74368 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
74369 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
74370 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
74371 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
74372 IF(P(N+2,4).LT.1D-5) THEN
74373 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
74379 C...Find first and last eigenvector by solving equation system.
74382 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
74384 SV(J1,J2)=SM(J1,J2)
74385 SV(J2,J1)=SM(J1,J2)
74391 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
74394 SMAX=ABS(SV(J1,J2))
74398 DO 220 J3=JA+1,JA+2
74400 RL=SV(J1,JB)/SV(JA,JB)
74402 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
74403 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
74405 SMAX=ABS(SV(J1,J2))
74409 JB2=JB+2-3*((JB+1)/3)
74410 P(N+I,JB1)=-SV(JC,JB2)
74411 P(N+I,JB2)=SV(JC,JB1)
74412 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
74414 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
74415 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74417 P(N+I,J)=SGN*P(N+I,J)/PA
74421 C...Middle axis orthogonal to other two. Fill other codes.
74422 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74423 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
74424 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
74425 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
74438 C...Calculate sphericity and aplanarity. Select storing option.
74439 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
74443 IF(MSTU(43).LE.1) MSTU(3)=3
74444 IF(MSTU(43).GE.2) N=N+3
74449 C*********************************************************************
74452 C...Performs thrust analysis to give thrust, oblateness
74453 C...and the related event axes.
74455 SUBROUTINE PYTHRU(THR,OBL)
74457 C...Double precision and integer declarations.
74458 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74459 IMPLICIT INTEGER(I-N)
74460 INTEGER PYK,PYCHGE,PYCOMP
74461 C...Parameter statement to help give large particle numbers.
74462 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74463 &KEXCIT=4000000,KDIMEN=5000000)
74465 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74466 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74467 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74468 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74470 DIMENSION TDI(3),TPR(3)
74472 C...Take copy of particles that are to be considered in thrust analysis.
74476 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
74477 IF(MSTU(41).GE.2) THEN
74479 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74480 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74481 & K(I,2).EQ.KSUSY1+39) GOTO 100
74482 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74485 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
74486 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
74496 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74498 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
74499 & P(N+NP,4)**(PARU(42)-1D0)
74500 PS=PS+P(N+NP,4)*P(N+NP,5)
74503 C...Very low multiplicities (0 or 1) not considered.
74505 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
74511 C...Loop over thrust and major. T axis along z direction in latter case.
74515 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
74517 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
74518 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
74519 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
74522 C...Find and order particles with highest p (pT for major).
74523 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
74527 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
74528 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
74529 IF(P(I,4).LE.P(ILF,4)) GOTO 140
74531 P(ILF+1,J)=P(ILF,J)
74540 C...Find and order initial axes with highest thrust (major).
74541 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
74544 NC=2**(MIN(MSTU(44),NP)-1)
74549 DO 200 ILF=1,MIN(MSTU(44),NP)
74550 SGN=P(N+NP+ILF+3,5)
74551 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
74553 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
74556 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
74557 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
74558 IF(TDS.LE.P(ILG,4)) GOTO 230
74560 P(ILG+1,J)=P(ILG,J)
74563 ILG=N+NP+MSTU(44)+4
74570 C...Iterate direction of axis until stable maximum.
74577 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
74578 IF(THP.GT.1D-10) TDI(J)=TPR(J)
74582 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
74584 TPR(J)=TPR(J)+SGN*P(I,J)
74587 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
74588 IF(THP.GE.THPS+PARU(48)) GOTO 270
74590 C...Save good axis. Try new initial axis until a number of tries agree.
74591 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
74592 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
74594 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74596 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
74602 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
74605 C...Find minor axis and value by orthogonality.
74606 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74607 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
74608 P(N+NP+3,2)=SGN*P(N+NP+2,1)
74612 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
74617 C...Fill axis information. Rotate back to original coordinate system.
74625 P(N+ILD,J)=P(N+NP+ILD,J)
74629 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
74631 C...Calculate thrust and oblateness. Select storing option.
74633 OBL=P(N+2,4)-P(N+3,4)
74636 IF(MSTU(43).LE.1) MSTU(3)=3
74637 IF(MSTU(43).GE.2) N=N+3
74642 C*********************************************************************
74645 C...Subdivides the particle content of an event into jets/clusters.
74647 SUBROUTINE PYCLUS(NJET)
74649 C...Double precision and integer declarations.
74650 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74651 IMPLICIT INTEGER(I-N)
74652 INTEGER PYK,PYCHGE,PYCOMP
74653 C...Parameter statement to help give large particle numbers.
74654 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74655 &KEXCIT=4000000,KDIMEN=5000000)
74657 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74658 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74659 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74660 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74661 C...Local arrays and saved variables.
74663 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
74665 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
74666 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
74667 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
74668 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
74669 &P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
74670 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
74671 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
74673 C...If first time, reset. If reentering, skip preliminaries.
74674 IF(MSTU(48).LE.0) THEN
74680 PIMASS=PMAS(PYCOMP(211),1)
74683 IF(MSTU(43).GE.2) N=N-NJET
74684 DO 110 I=N+1,N+NJET
74685 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74687 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
74690 R2ACC=PARU(45)*PS(5)**2
74696 C...Find which particles are to be considered in cluster search.
74698 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
74699 IF(MSTU(41).GE.2) THEN
74701 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74702 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74703 & K(I,2).EQ.KSUSY1+39) GOTO 140
74704 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74707 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
74708 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
74713 C...Take copy of these particles, with space left for jets later on.
74719 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
74720 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
74721 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
74722 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74724 PS(J)=PS(J)+P(N+NP,J)
74734 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
74736 C...Very low multiplicities not considered.
74737 IF(NP.LT.MSTU(47)) THEN
74738 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
74743 C...Find precluster configuration. If too few jets, make harder cuts.
74745 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
74748 R2ACC=PARU(45)*PS(5)**2
74750 RINIT=1.25D0*PARU(43)
74751 IF(NP.LE.MSTU(47)+2) RINIT=0D0
74752 170 RINIT=0.8D0*RINIT
74755 DO 180 I=N+NP+1,N+2*NP
74759 C...Sum up small momentum region. Jet if enough absolute momentum.
74760 IF(MSTU(46).LE.2) THEN
74764 DO 210 I=N+NP+1,N+2*NP
74765 IF(P(I,5).GT.2D0*RINIT) GOTO 210
74769 P(N+1,J)=P(N+1,J)+P(I,J)
74772 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
74773 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
74774 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
74775 IF(NREM.EQ.0) GOTO 170
74778 C...Find fastest remaining particle.
74781 DO 230 I=N+NP+1,N+2*NP
74782 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
74787 P(N+NPRE,J)=P(IMAX,J)
74792 C...Sum up precluster around it according to pT separation.
74793 IF(MSTU(46).LE.2) THEN
74794 DO 260 I=N+NP+1,N+2*NP
74795 IF(K(I,4).NE.0) GOTO 260
74797 IF(R2.GT.RINIT**2) GOTO 260
74801 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
74804 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
74806 C...Sum up precluster around it according to mass or
74807 C...Durham pT separation.
74811 DO 280 I=N+NP+1,N+2*NP
74812 IF(K(I,4).NE.0) GOTO 280
74813 IF(MSTU(46).LE.4) THEN
74818 IF(R2.GE.R2MIN) GOTO 280
74824 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
74826 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
74833 C...Check if more preclusters to be found. Start over if too few.
74834 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
74835 IF(NREM.GT.0) GOTO 220
74838 C...Reassign all particles to nearest jet. Sum up new jet momenta.
74841 310 IF(MSTU(46).LE.1) THEN
74842 DO 330 I=N+1,N+NJET
74847 DO 360 I=N+NP+1,N+2*NP
74849 DO 340 IJET=N+1,N+NJET
74850 IF(P(IJET,5).LT.RINIT) GOTO 340
74852 IF(R2.GE.R2MIN) GOTO 340
74858 V(IMIN,J)=V(IMIN,J)+P(I,J)
74862 DO 380 I=N+1,N+NJET
74866 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74871 C...Find two closest jets.
74872 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
74873 DO 400 ITRY1=N+1,N+NJET-1
74874 DO 390 ITRY2=ITRY1+1,N+NJET
74875 IF(MSTU(46).LE.2) THEN
74876 R2=R2T(ITRY1,ITRY2)
74877 ELSEIF(MSTU(46).LE.4) THEN
74878 R2=R2M(ITRY1,ITRY2)
74880 R2=R2D(ITRY1,ITRY2)
74882 IF(R2.GE.R2MIN) GOTO 390
74889 C...If allowed, join two closest jets and start over.
74890 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
74891 IREC=MIN(IMIN1,IMIN2)
74892 IDEL=MAX(IMIN1,IMIN2)
74894 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
74896 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
74897 DO 430 I=IDEL+1,N+NJET
74902 IF(MSTU(46).GE.2) THEN
74903 DO 440 I=N+NP+1,N+2*NP
74905 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
74906 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
74912 C...Divide up broad jet if empty cluster in list of final ones.
74913 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
74914 DO 450 I=N+1,N+NJET
74917 DO 460 I=N+NP+1,N+2*NP
74918 K(N+K(I,4),5)=K(N+K(I,4),5)+1
74921 DO 470 I=N+1,N+NJET
74922 IF(K(I,5).EQ.0) IEMP=I
74928 DO 480 I=N+NP+1,N+2*NP
74929 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
74932 IF(R2.LE.R2MAX) GOTO 480
74939 P(IEMP,J)=P(ISPL,J)
74940 P(IJET,J)=P(IJET,J)-P(ISPL,J)
74942 P(IEMP,5)=P(ISPL,5)
74943 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
74944 IF(NLOOP.LE.2) GOTO 300
74949 C...If generalized thrust has not yet converged, continue iteration.
74950 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
74956 C...Reorder jets according to energy.
74957 DO 510 I=N+1,N+NJET
74962 DO 540 INEW=N+1,N+NJET
74964 DO 520 ITRY=N+1,N+NJET
74965 IF(V(ITRY,4).LE.PEMAX) GOTO 520
74974 P(INEW,J)=V(IMAX,J)
74980 C...Clean up particle-jet assignments and jet information.
74981 DO 550 I=N+NP+1,N+2*NP
74984 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
74985 K(IORI,4)=K(IORI,4)+1
74989 DO 570 I=N+1,N+NJET
74992 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
74996 IF(K(I,4).EQ.0) IEMP=I
74999 C...Select storing option. Output variables. Check for failure.
75005 PARU(63)=SQRT(R2MIN)
75006 IF(NJET.LE.1) PARU(63)=0D0
75008 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
75012 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
75013 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
75019 C*********************************************************************
75022 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
75023 C...as used for calorimeters at hadron colliders.
75025 SUBROUTINE PYCELL(NJET)
75027 C...Double precision and integer declarations.
75028 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75029 IMPLICIT INTEGER(I-N)
75030 INTEGER PYK,PYCHGE,PYCOMP
75031 C...Parameter statement to help give large particle numbers.
75032 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75033 &KEXCIT=4000000,KDIMEN=5000000)
75035 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75036 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75037 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75038 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75040 C...Loop over all particles. Find cell that was hit by given particle.
75041 PTLRAT=1D0/SINH(PARU(51))**2
75045 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
75046 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
75047 IF(MSTU(41).GE.2) THEN
75049 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75050 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75051 & K(I,2).EQ.KSUSY1+39) GOTO 110
75052 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75056 PT=SQRT(P(I,1)**2+P(I,2)**2)
75057 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
75058 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
75059 & (ETA/PARU(51)+1D0))))
75060 PHI=PYANGL(P(I,1),P(I,2))
75061 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
75062 & (PHI/PARU(1)+1D0))))
75063 IETPH=MSTU(52)*IETA+IPHI
75065 C...Add to cell already hit, or book new cell.
75067 IF(IETPH.EQ.K(IC,3)) THEN
75073 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
75074 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
75082 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
75083 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
75087 C...Smear true bin content by calorimeter resolution.
75088 IF(MSTU(53).GE.1) THEN
75091 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
75092 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
75093 & COS(PARU(2)*PYR(0))
75094 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
75096 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
75100 C...Remove cells below threshold.
75101 IF(PARU(58).GT.0D0) THEN
75105 IF(P(IC,5).GT.PARU(58)) THEN
75117 C...Find initiator cell: the one with highest pT of not yet used ones.
75121 IF(K(IC,5).NE.2) GOTO 160
75122 IF(P(IC,5).LE.ETMAX) GOTO 160
75128 IF(ETMAX.LT.PARU(52)) GOTO 220
75129 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
75130 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
75144 C...Sum up unused cells within required distance of initiator.
75146 IF(K(IC,5).EQ.0) GOTO 170
75147 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
75148 DPHIA=ABS(P(IC,2)-PHI)
75149 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
75151 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
75152 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
75154 K(NJ,4)=K(NJ,4)+K(IC,4)
75155 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
75156 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
75157 P(NJ,5)=P(NJ,5)+P(IC,5)
75160 C...Reject cluster below minimum ET, else accept.
75161 IF(P(NJ,5).LT.PARU(53)) THEN
75164 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
75166 ELSEIF(MSTU(54).LE.2) THEN
75167 P(NJ,3)=P(NJ,3)/P(NJ,5)
75168 P(NJ,4)=P(NJ,4)/P(NJ,5)
75169 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
75172 IF(K(IC,5).LT.0) K(IC,5)=0
75179 IF(K(IC,5).GE.0) GOTO 210
75180 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
75181 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
75182 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
75183 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
75189 C...Arrange clusters in falling ET sequence.
75190 220 DO 250 I=1,NJ-NC
75193 IF(K(IJ,5).EQ.0) GOTO 230
75194 IF(P(IJ,5).LT.ETMAX) GOTO 230
75202 K(N+I,4)=K(IJMAX,4)
75205 P(N+I,J)=P(IJMAX,J)
75211 C...Convert to massless or massive four-vectors.
75212 IF(MSTU(54).EQ.2) THEN
75213 DO 260 I=N+1,N+NJET
75215 P(I,1)=P(I,5)*COS(P(I,4))
75216 P(I,2)=P(I,5)*SIN(P(I,4))
75217 P(I,3)=P(I,5)*SINH(ETA)
75218 P(I,4)=P(I,5)*COSH(ETA)
75221 ELSEIF(MSTU(54).GE.3) THEN
75222 DO 270 I=N+1,N+NJET
75223 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
75227 C...Information about storage.
75231 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
75232 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
75237 C*********************************************************************
75240 C...Determines, approximately, the two jet masses that minimize
75241 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
75243 SUBROUTINE PYJMAS(PMH,PML)
75245 C...Double precision and integer declarations.
75246 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75247 IMPLICIT INTEGER(I-N)
75248 INTEGER PYK,PYCHGE,PYCOMP
75249 C...Parameter statement to help give large particle numbers.
75250 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75251 &KEXCIT=4000000,KDIMEN=5000000)
75253 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75254 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75255 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75256 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75258 DIMENSION SM(3,3),SAX(3),PS(3,5)
75271 PIMASS=PMAS(PYCOMP(211),1)
75273 C...Take copy of particles that are to be considered in mass analysis.
75275 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
75276 IF(MSTU(41).GE.2) THEN
75278 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75279 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75280 & K(I,2).EQ.KSUSY1+39) GOTO 170
75281 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75284 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
75285 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
75294 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
75295 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
75296 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
75298 C...Fill information in sphericity tensor and total momentum vector.
75301 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
75304 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
75306 PS(3,J)=PS(3,J)+P(N+NP,J)
75310 C...Very low multiplicities (0 or 1) not considered.
75312 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
75317 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
75320 C...Find largest eigenvalue to matrix (third degree equation).
75323 SM(J1,J2)=SM(J1,J2)/PSS
75326 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
75327 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
75328 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
75329 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
75330 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
75331 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
75332 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
75334 C...Find largest eigenvector by solving equation system.
75336 SM(J1,J1)=SM(J1,J1)-SMA
75338 SM(J2,J1)=SM(J1,J2)
75344 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
75347 SMAX=ABS(SM(J1,J2))
75351 DO 250 J3=JA+1,JA+2
75353 RL=SM(J1,JB)/SM(JA,JB)
75355 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
75356 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
75358 SMAX=ABS(SM(J1,J2))
75362 JB2=JB+2-3*((JB+1)/3)
75363 SAX(JB1)=-SM(JC,JB2)
75364 SAX(JB2)=SM(JC,JB1)
75365 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
75367 C...Divide particles into two initial clusters by hemisphere.
75369 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
75371 IF(PSAX.LT.0D0) IS=2
75374 PS(IS,J)=PS(IS,J)+P(I,J)
75377 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
75378 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
75380 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
75384 PS(3,J)=PS(1,J)-PS(2,J)
75387 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)
75388 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
75389 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
75390 IF(PMDI.LT.PMD) THEN
75396 C...Loop back if significant reduction in sum of m^2.
75397 IF(PMD.LT.-PARU(48)*PMS) THEN
75401 PS(IS,J)=PS(IS,J)-P(IM,J)
75402 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
75408 C...Final masses and output.
75411 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
75412 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
75413 PMH=MAX(PS(1,5),PS(2,5))
75414 PML=MIN(PS(1,5),PS(2,5))
75419 C*********************************************************************
75422 C...Calculates the first few Fox-Wolfram moments.
75424 SUBROUTINE PYFOWO(H10,H20,H30,H40)
75426 C...Double precision and integer declarations.
75427 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75428 IMPLICIT INTEGER(I-N)
75429 INTEGER PYK,PYCHGE,PYCOMP
75430 C...Parameter statement to help give large particle numbers.
75431 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75432 &KEXCIT=4000000,KDIMEN=5000000)
75434 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75435 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75436 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75437 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75439 C...Copy momenta for particles and calculate H0.
75444 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
75445 IF(MSTU(41).GE.2) THEN
75447 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75448 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75449 & K(I,2).EQ.KSUSY1+39) GOTO 110
75450 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75453 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
75454 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
75465 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
75471 C...Very low multiplicities (0 or 1) not considered.
75473 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
75481 C...Calculate H1 - H4.
75487 DO 120 I2=I1+1,N+NP
75488 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
75489 & (P(I1,4)*P(I2,4))
75490 H10=H10+P(I1,4)*P(I2,4)*CTHE
75491 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
75492 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
75493 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
75498 C...Calculate H1/H0 - H4/H0. Output.
75501 H10=(HD+2D0*H10)/H0
75502 H20=(HD+2D0*H20)/H0
75503 H30=(HD+2D0*H30)/H0
75504 H40=(HD+2D0*H40)/H0
75509 C*********************************************************************
75512 C...Evaluates various properties of an event, with statistics
75513 C...accumulated during the course of the run and
75514 C...printed at the end.
75516 SUBROUTINE PYTABU(MTABU)
75518 C...Double precision and integer declarations.
75519 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75520 IMPLICIT INTEGER(I-N)
75521 INTEGER PYK,PYCHGE,PYCOMP
75522 C...Parameter statement to help give large particle numbers.
75523 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75524 &KEXCIT=4000000,KDIMEN=5000000)
75526 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75527 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75528 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75529 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
75530 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
75531 C...Local arrays, character variables, saved variables and data.
75532 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
75533 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
75534 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
75535 &KFDM(8),KFDC(200,0:8),NPDC(200)
75536 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
75537 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
75538 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
75539 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
75540 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
75541 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
75542 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
75543 &NEVDC/0/,NKFDC/0/,NREDC/0/
75545 C...Reset statistics on initial parton state.
75546 IF(MTABU.EQ.10) THEN
75550 C...Identify and order flavour content of initial state.
75551 ELSEIF(MTABU.EQ.11) THEN
75553 KFM1=2*IABS(MSTU(161))
75554 IF(MSTU(161).GT.0) KFM1=KFM1-1
75555 KFM2=2*IABS(MSTU(162))
75556 IF(MSTU(162).GT.0) KFM2=KFM2-1
75557 KFMN=MIN(KFM1,KFM2)
75558 KFMX=MAX(KFM1,KFM2)
75560 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
75563 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
75564 & KFMX.LT.KFIS(I,2))) THEN
75570 110 IF(IKFIS.LT.0) THEN
75573 IF(NKFIS.GE.100) RETURN
75574 DO 130 I=NKFIS,IKFIS,-1
75575 KFIS(I+1,1)=KFIS(I,1)
75576 KFIS(I+1,2)=KFIS(I,2)
75578 NPIS(I+1,J)=NPIS(I,J)
75588 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
75590 C...Count number of partons in initial state.
75593 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
75594 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
75595 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
75600 IF(IM.LE.0.OR.IM.GT.N) THEN
75602 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
75604 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
75605 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
75615 IF(NP.GE.11) NPCO=8
75616 IF(NP.GE.16) NPCO=9
75617 IF(NP.GE.26) NPCO=10
75618 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
75621 C...Write statistics on initial parton state.
75622 ELSEIF(MTABU.EQ.12) THEN
75623 FAC=1D0/MAX(1,NEVIS)
75624 WRITE(MSTU(11),5000) NEVIS
75627 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
75629 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
75630 CALL PYNAME(KFM1,CHAU)
75632 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
75634 IF(KFIS(I,1).EQ.0) KFMX=0
75636 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
75637 CALL PYNAME(KFM2,CHAU)
75639 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
75640 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
75641 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
75644 C...Copy statistics on initial parton state into /PYJETS/.
75645 ELSEIF(MTABU.EQ.13) THEN
75646 FAC=1D0/MAX(1,NEVIS)
75649 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
75651 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
75653 IF(KFIS(I,1).EQ.0) KFMX=0
75655 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
75662 P(I,J)=FAC*NPIS(I,J)
75663 V(I,J)=FAC*NPIS(I,J+5)
75677 C...Reset statistics on number of particles/partons.
75678 ELSEIF(MTABU.EQ.20) THEN
75685 C...Identify whether particle/parton is primary or not.
75686 ELSEIF(MTABU.EQ.21) THEN
75690 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
75691 MSTU(62)=MSTU(62)+1
75694 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
75696 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
75698 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
75700 ELSEIF(KC.EQ.0) THEN
75701 ELSEIF(K(K(I,3),1).EQ.13) THEN
75703 IF(IM.LE.0.OR.IM.GT.N) THEN
75705 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
75708 ELSEIF(KCHG(KC,2).EQ.0) THEN
75709 KCM=PYCOMP(K(K(I,3),2))
75711 IF(KCHG(KCM,2).NE.0) MPRI=1
75714 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
75715 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
75717 IF(K(I,1).LE.10) THEN
75719 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
75722 C...Fill statistics on number of particles/partons in event.
75724 KFS=3-ISIGN(1,K(I,2))-MPRI
75726 IF(KFA.EQ.KFFS(IP)) THEN
75729 ELSEIF(KFA.LT.KFFS(IP)) THEN
75735 220 IF(IKFFS.LT.0) THEN
75738 IF(NKFFS.GE.400) RETURN
75739 DO 240 IP=NKFFS,IKFFS,-1
75740 KFFS(IP+1)=KFFS(IP)
75742 NPFS(IP+1,J)=NPFS(IP,J)
75751 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
75754 C...Write statistics on particle/parton composition of events.
75755 ELSEIF(MTABU.EQ.22) THEN
75756 FAC=1D0/MAX(1,NEVFS)
75757 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
75759 CALL PYNAME(KFFS(I),CHAU)
75762 IF(KC.NE.0) MDCYF=MDCY(KC,1)
75763 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
75764 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
75767 C...Copy particle/parton composition information into /PYJETS/.
75768 ELSEIF(MTABU.EQ.23) THEN
75769 FAC=1D0/MAX(1,NEVFS)
75775 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
75777 P(I,J)=FAC*NPFS(I,J)
75797 C...Reset factorial moments statistics.
75798 ELSEIF(MTABU.EQ.30) THEN
75804 FM1FM(IM,IB,IP)=0D0
75805 FM2FM(IM,IB,IP)=0D0
75810 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
75811 ELSEIF(MTABU.EQ.31) THEN
75816 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
75817 IF(MSTU(41).GE.2) THEN
75819 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75820 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75821 & K(I,2).EQ.KSUSY1+39) GOTO 410
75822 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
75823 & PYCHGE(K(I,2)).EQ.0) GOTO 410
75826 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
75827 IF(MSTU(42).GE.2) PMR=P(I,5)
75828 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
75829 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
75831 IF(ABS(YETA).GT.PARU(57)) GOTO 410
75832 PHI=PYANGL(P(I,1),P(I,2))
75833 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
75834 IYETA=MAX(0,MIN(511,IYETA))
75835 IPHI=512D0*(PHI+PARU(1))/PARU(2)
75836 IPHI=MAX(0,MIN(511,IPHI))
75839 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
75842 C...Order particles in (pseudo)rapidity and/or azimuth.
75843 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
75844 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
75848 IF(NUPP.EQ.NLOW+1) THEN
75853 DO 350 I1=NUPP-1,NLOW+1,-1
75854 IF(IYETA.GE.K(I1,1)) GOTO 360
75857 360 K(I1+1,1)=IYETA
75858 DO 370 I1=NUPP-1,NLOW+1,-1
75859 IF(IPHI.GE.K(I1,2)) GOTO 380
75863 DO 390 I1=NUPP-1,NLOW+1,-1
75864 IF(IYEP.GE.K(I1,3)) GOTO 400
75874 C...Calculate sum of factorial moments in event.
75882 IF(IM.LE.2) IBIN=2**(10-IB)
75883 IF(IM.EQ.3) IBIN=4**(10-IB)
75884 IAGR=K(NLOW+1,IM)/IBIN
75886 DO 440 I=NLOW+2,NUPP+1
75888 IF(ICUT.EQ.IAGR) THEN
75892 ELSEIF(NAGR.EQ.2) THEN
75893 FEVFM(IB,1)=FEVFM(IB,1)+2D0
75894 ELSEIF(NAGR.EQ.3) THEN
75895 FEVFM(IB,1)=FEVFM(IB,1)+6D0
75896 FEVFM(IB,2)=FEVFM(IB,2)+6D0
75897 ELSEIF(NAGR.EQ.4) THEN
75898 FEVFM(IB,1)=FEVFM(IB,1)+12D0
75899 FEVFM(IB,2)=FEVFM(IB,2)+24D0
75900 FEVFM(IB,3)=FEVFM(IB,3)+24D0
75902 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
75903 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
75904 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
75906 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
75907 & (NAGR-3D0)*(NAGR-4D0)
75915 C...Add results to total statistics.
75918 IF(FEVFM(1,IP).LT.0.5D0) THEN
75920 ELSEIF(IM.LE.2) THEN
75921 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
75923 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
75925 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
75926 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
75930 NMUFM=NMUFM+(NUPP-NLOW)
75933 C...Write accumulated statistics on factorial moments.
75934 ELSEIF(MTABU.EQ.32) THEN
75935 FAC=1D0/MAX(1,NEVFM)
75936 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
75937 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
75938 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
75940 WRITE(MSTU(11),5500)
75943 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
75945 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
75946 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
75947 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
75949 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
75950 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
75953 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
75958 C...Copy statistics on factorial moments into /PYJETS/.
75959 ELSEIF(MTABU.EQ.33) THEN
75960 FAC=1D0/MAX(1,NEVFM)
75967 IF(IM.NE.2) K(I,3)=2**(IB-1)
75969 IF(IM.NE.1) K(I,4)=2**(IB-1)
75971 P(I,1)=2D0*PARU(57)/K(I,3)
75972 V(I,1)=PARU(2)/K(I,4)
75974 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
75975 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
75991 C...Reset statistics on Energy-Energy Correlation.
75992 ELSEIF(MTABU.EQ.40) THEN
76003 C...Find particles to include, with proper assumed mass.
76004 ELSEIF(MTABU.EQ.41) THEN
76010 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
76011 IF(MSTU(41).GE.2) THEN
76013 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76014 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76015 & K(I,2).EQ.KSUSY1+39) GOTO 570
76016 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
76017 & PYCHGE(K(I,2)).EQ.0) GOTO 570
76020 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
76021 IF(MSTU(42).GE.2) PMR=P(I,5)
76022 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
76023 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
76030 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
76031 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
76034 IF(NUPP.EQ.NLOW) RETURN
76036 C...Analyze Energy-Energy Correlation in event.
76037 FAC=(2D0/ECM**2)*50D0/PARU(1)
76041 DO 600 I1=NLOW+2,NUPP
76042 DO 590 I2=NLOW+1,I1-1
76043 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
76044 & (P(I1,5)*P(I2,5))
76045 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
76046 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
76047 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
76051 FE1EC(J)=FE1EC(J)+FEVEE(J)
76052 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
76053 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
76054 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
76055 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
76056 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
76060 C...Write statistics on Energy-Energy Correlation.
76061 ELSEIF(MTABU.EQ.42) THEN
76062 FAC=1D0/MAX(1,NEVEE)
76063 WRITE(MSTU(11),5700) NEVEE
76066 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
76067 FEEC2=FAC*FE1EC(51-J)
76068 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
76070 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
76071 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
76072 & FEEC2,FEES2,FEECA,FEESA
76075 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
76076 ELSEIF(MTABU.EQ.43) THEN
76077 FAC=1D0/MAX(1,NEVEE)
76084 P(I,1)=FAC*FE1EC(I)
76085 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
76086 P(I,2)=FAC*FE1EC(51-I)
76087 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
76088 P(I,3)=FAC*FE1EA(I)
76089 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
76090 P(I,4)=PARU(1)*(I-1)/50D0
76091 P(I,5)=PARU(1)*I/50D0
76106 C...Reset statistics on decay channels.
76107 ELSEIF(MTABU.EQ.50) THEN
76112 C...Identify and order flavour content of final state.
76113 ELSEIF(MTABU.EQ.51) THEN
76117 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
76124 IF(K(I,2).LT.0) KFM=KFM-1
76125 DO 650 IDS=NDS-1,1,-1
76127 IF(KFM.LT.KFDM(IDS)) GOTO 660
76128 KFDM(IDS+1)=KFDM(IDS)
76134 C...Find whether old or new final state.
76136 IF(NDS.LT.KFDC(IDC,0)) THEN
76139 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
76141 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
76144 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
76153 700 IF(IKFDC.LT.0) THEN
76155 ELSEIF(NKFDC.GE.200) THEN
76159 DO 720 IDC=NKFDC,IKFDC,-1
76160 NPDC(IDC+1)=NPDC(IDC)
76162 KFDC(IDC+1,I)=KFDC(IDC,I)
76168 KFDC(IKFDC,I)=KFDM(I)
76172 NPDC(IKFDC)=NPDC(IKFDC)+1
76174 C...Write statistics on decay channels.
76175 ELSEIF(MTABU.EQ.52) THEN
76176 FAC=1D0/MAX(1,NEVDC)
76177 WRITE(MSTU(11),5900) NEVDC
76179 DO 740 I=1,KFDC(IDC,0)
76182 IF(2*KF.NE.KFM) KF=-KF
76183 CALL PYNAME(KF,CHAU)
76185 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
76187 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
76189 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
76191 C...Copy statistics on decay channels into /PYJETS/.
76192 ELSEIF(MTABU.EQ.53) THEN
76193 FAC=1D0/MAX(1,NEVDC)
76199 K(IDC,5)=KFDC(IDC,0)
76204 DO 770 I=1,KFDC(IDC,0)
76207 IF(2*KF.NE.KFM) KF=-KF
76208 IF(I.LE.5) P(IDC,I)=KF
76209 IF(I.GE.6) V(IDC,I-5)=KF
76211 V(IDC,5)=FAC*NPDC(IDC)
76226 C...Format statements for output on unit MSTU(11) (default 6).
76227 5000 FORMAT(///20X,'Event statistics - initial state'/
76228 &20X,'based on an analysis of ',I6,' events'//
76229 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
76230 &'according to fragmenting system multiplicity'/
76231 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
76232 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
76233 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
76234 5200 FORMAT(///20X,'Event statistics - final state'/
76235 &20X,'based on an analysis of ',I7,' events'//
76236 &5X,'Mean primary multiplicity =',F10.4/
76237 &5X,'Mean final multiplicity =',F10.4/
76238 &5X,'Mean charged multiplicity =',F10.4//
76239 &5X,'Number of particles produced per event (directly and via ',
76240 &'decays/branchings)'/
76241 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
76242 &8X,'Total'/35X,'prim seco prim seco'/)
76243 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
76244 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
76245 &20X,'based on an analysis of ',I6,' events'//
76246 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
76247 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
76249 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
76250 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
76251 &20X,'based on an analysis of ',I6,' events'//
76252 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
76253 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
76254 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
76255 5900 FORMAT(///20X,'Decay channel analysis - final state'/
76256 &20X,'based on an analysis of ',I6,' events'//
76257 &2X,'Probability',10X,'Complete final state'/)
76258 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
76259 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
76260 &'or table overflow)')
76265 C*********************************************************************
76268 C...Handles the generation of an e+e- annihilation jet event.
76270 SUBROUTINE PYEEVT(KFL,ECM)
76272 C...Double precision and integer declarations.
76273 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76274 IMPLICIT INTEGER(I-N)
76275 INTEGER PYK,PYCHGE,PYCOMP
76277 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76278 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76279 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76280 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76282 C...Check input parameters.
76283 IF(MSTU(12).NE.12345) CALL PYLIST(0)
76284 IF(KFL.LT.0.OR.KFL.GT.8) THEN
76285 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
76286 IF(MSTU(21).GE.1) RETURN
76288 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
76289 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
76290 IF(ECM.LT.ECMMIN) THEN
76291 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
76292 IF(MSTU(21).GE.1) RETURN
76295 C...Check consistency of MSTJ options set.
76296 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
76298 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
76301 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
76303 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
76307 C...Initialize alpha_strong and total cross-section.
76308 MSTU(111)=MSTJ(108)
76309 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
76311 PARU(112)=PARJ(121)
76312 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
76313 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
76314 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
76316 IF(MSTJ(116).GE.3) MSTJ(116)=1
76319 C...Add initial e+e- to event record (documentation only).
76322 IF(NTRY.GT.100) THEN
76323 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
76328 IF(MSTJ(115).GE.2) THEN
76330 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
76332 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
76336 C...Radiative photon (in initial state).
76339 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
76341 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
76342 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
76344 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
76345 K(NC,3)=MIN(MSTJ(115)/2,1)
76348 C...Virtual exchange boson (gamma or Z0).
76349 IF(MSTJ(115).GE.3) THEN
76352 IF(MSTJ(102).EQ.2) KF=23
76356 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
76362 C...Choice of flavour and jet configuration.
76363 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
76364 IF(KFLC.EQ.0) GOTO 100
76365 CALL PYXJET(ECMC,NJET,CUT)
76367 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
76369 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
76370 IF(NJET.EQ.2) MSTJ(120)=1
76372 C...Fill jet configuration and origin.
76373 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
76374 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
76376 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
76377 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
76378 &-KFLC,ECMC,X1,X2,X4,X12,X14)
76379 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
76380 &-KFLC,ECMC,X1,X2,X4,X12,X14)
76381 IF(MSTU(24).NE.0) GOTO 100
76383 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
76386 C...Angular orientation according to matrix element.
76387 IF(MSTJ(106).EQ.1) THEN
76388 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
76389 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
76390 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
76393 C...Rotation and boost from radiative photon.
76395 DBEK=-PAK/(ECM-PAK)
76396 NMIN=NC+1-MSTJ(115)/3
76397 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
76398 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
76399 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
76402 C...Generate parton shower. Rearrange along strings and check.
76403 IF(MSTJ(101).EQ.5) THEN
76404 CALL PYSHOW(N-1,N,ECMC)
76406 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
76407 IF(MSTJ(105).GE.0) MSTU(28)=0
76410 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
76413 C...Fragmentation/decay generation. Information for PYTABU.
76414 IF(MSTJ(105).EQ.1) CALL PYEXEC
76421 C*********************************************************************
76424 C...Calculates total cross-section, including initial state
76425 C...radiation effects.
76427 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
76429 C...Double precision and integer declarations.
76430 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76431 IMPLICIT INTEGER(I-N)
76432 INTEGER PYK,PYCHGE,PYCOMP
76434 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76435 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76436 SAVE /PYDAT1/,/PYDAT2/
76438 C...Status, (optimized) Q^2 scale, alpha_strong.
76440 MSTJ(119)=10*MSTJ(102)+KFL
76441 IF(MSTJ(111).EQ.0) THEN
76443 ELSEIF(MSTU(111).EQ.0) THEN
76444 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
76445 & ((33D0-2D0*MSTU(112))*PARU(111)))))
76446 Q2R=PARJ(168)*ECM**2
76448 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
76449 & (2D0*PARU(112)/ECM)**2))
76450 Q2R=PARJ(168)*ECM**2
76452 ALSPI=PYALPS(Q2R)/PARU(1)
76454 C...QCD corrections factor in R.
76455 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
76457 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
76459 ELSEIF(MSTJ(109).EQ.0) THEN
76460 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
76461 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
76462 & LOG(PARJ(168))*ALSPI**2)
76463 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
76464 RQCD=1D0+(3D0/4D0)*ALSPI
76466 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
76469 C...Calculate Z0 width if default value not acceptable.
76470 IF(MSTJ(102).GE.3) THEN
76471 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
76472 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
76475 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
76476 & (2D0*PYMASS(KFLC)/ ECM)**2))
76477 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
76478 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
76479 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
76481 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
76485 C...Calculate propagator and related constants for QFD case.
76486 POLL=1D0-PARJ(131)*PARJ(132)
76487 IF(MSTJ(102).GE.2) THEN
76488 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
76489 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
76490 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
76491 VE=4D0*PARU(102)-1D0
76492 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
76493 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
76498 C...Loop over different flavours: charge, velocity.
76503 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
76504 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
76507 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
76508 QF=KCHG(KFLC,1)/3D0
76510 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
76512 C...Calculate R and sum of charges for QED or QFD case.
76513 RQQ=RQQ+3D0*QF**2*POLL
76514 IF(MSTJ(102).LE.1) THEN
76515 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
76517 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
76518 RQV=RQV-6D0*QF*VF*SF1I
76519 RVA=RVA+3D0*(VF**2+1D0)*SF1W
76520 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
76521 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
76525 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
76527 C...Calculate cross-section, including QCD corrections.
76530 PARJ(143)=RTOT*RQCD
76531 PARJ(144)=PARJ(143)
76532 PARJ(145)=PARJ(141)*86.8D0/ECM**2
76533 PARJ(146)=PARJ(142)*86.8D0/ECM**2
76534 PARJ(147)=PARJ(143)*86.8D0/ECM**2
76535 PARJ(148)=PARJ(147)
76536 PARJ(157)=RSUM*RQCD
76540 IF(MSTJ(107).LE.0) RETURN
76542 C...Virtual cross-section.
76544 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
76545 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
76546 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
76547 &1.526D0*LOG(ECM**2/0.932D0)
76549 C...Soft and hard radiative cross-section in QED case.
76550 IF(MSTJ(102).LE.1) THEN
76551 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
76552 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
76553 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
76555 C...Soft and hard radiative cross-section in QFD case.
76557 SZM=1D0-(PARJ(123)/ECM)**2
76558 SZW=PARJ(123)*PARJ(124)/ECM**2
76559 PARJ(161)=-RQQ/RSUM
76560 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
76561 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
76562 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
76563 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
76564 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
76565 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
76566 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
76567 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
76568 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
76569 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
76570 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
76571 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
76572 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
76575 C...Total cross-section and fraction of hard photon events.
76576 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
76577 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
76578 PARJ(144)=PARJ(157)
76579 PARJ(148)=PARJ(144)*86.8D0/ECM**2
76585 C*********************************************************************
76588 C...Generates initial state photon radiation.
76590 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
76592 C...Double precision and integer declarations.
76593 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76594 IMPLICIT INTEGER(I-N)
76595 INTEGER PYK,PYCHGE,PYCOMP
76597 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76600 C...Function: cumulative hard photon spectrum in QFD case.
76601 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
76602 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
76604 C...Determine whether radiative photon or not.
76607 IF(PARJ(160).LT.PYR(0)) RETURN
76610 C...Photon energy range. Find photon momentum in QED case.
76612 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
76613 IF(MSTJ(102).LE.1) THEN
76614 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
76615 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
76617 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
76619 SZM=1D0-(PARJ(123)/ECM)**2
76620 SZW=PARJ(123)*PARJ(124)/ECM**2
76623 FXKD=1D-4*(FXKU-FXKL)
76624 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
76629 IF(FXKV.GT.FXKR) THEN
76636 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
76637 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
76641 C...Photon polar and azimuthal angle.
76642 PME=2D0*(PYMASS(11)/ECM)**2
76643 120 CTHM=PME*(2D0/PME)**PYR(0)
76644 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
76645 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
76647 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
76648 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
76649 THEK=PYANGL(CTHE,STHE)
76650 PHIK=PARU(2)*PYR(0)
76652 C...Rotation angle for hadronic system.
76654 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
76656 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
76657 &(2D0-XK*(1D0-SGN*CTHE)))
76662 C*********************************************************************
76665 C...Selects flavour for produced qqbar pair.
76667 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
76669 C...Double precision and integer declarations.
76670 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76671 IMPLICIT INTEGER(I-N)
76672 INTEGER PYK,PYCHGE,PYCOMP
76674 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76675 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76676 SAVE /PYDAT1/,/PYDAT2/
76678 C...Calculate maximum weight in QED or QFD case.
76679 IF(MSTJ(102).LE.1) THEN
76682 POLL=1D0-PARJ(131)*PARJ(132)
76683 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
76684 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
76685 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
76686 VE=4D0*PARU(102)-1D0
76687 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
76688 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
76689 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
76690 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
76691 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
76695 C...Choose flavour. Gives charge and velocity.
76698 IF(NTRY.GT.100) THEN
76699 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
76704 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
76707 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
76708 QF=KCHG(KFLC,1)/3D0
76710 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
76712 C...Calculate weight in QED or QFD case.
76713 IF(MSTJ(102).LE.1) THEN
76715 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
76717 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
76718 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
76719 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
76721 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
76724 C...Weighting or new event (radiative photon). Cross-section update.
76725 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
76726 PARJ(158)=PARJ(158)+1D0
76727 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
76728 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
76729 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
76730 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
76731 PARJ(148)=PARJ(144)*86.8D0/ECM**2
76736 C*********************************************************************
76739 C...Selects number of jets in matrix element approach.
76741 SUBROUTINE PYXJET(ECM,NJET,CUT)
76743 C...Double precision and integer declarations.
76744 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76745 IMPLICIT INTEGER(I-N)
76746 INTEGER PYK,PYCHGE,PYCOMP
76748 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76750 C...Local array and data.
76752 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
76754 C...Trivial result for two-jets only, including parton shower.
76755 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
76758 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
76759 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
76761 IF(MSTJ(109).EQ.2) CF=1D0
76762 IF(MSTJ(111).EQ.0) THEN
76765 ELSEIF(MSTU(111).EQ.0) THEN
76766 PARJ(169)=MIN(1D0,PARJ(129))
76767 Q2=PARJ(169)*ECM**2
76768 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
76769 & ((33D0-2D0*MSTU(112))*PARU(111)))))
76770 Q2R=PARJ(168)*ECM**2
76772 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
76773 Q2=PARJ(169)*ECM**2
76774 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
76775 & (2D0*PARU(112)/ECM)**2))
76776 Q2R=PARJ(168)*ECM**2
76779 C...alpha_strong for R and R itself.
76780 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
76781 IF(IABS(MSTJ(101)).EQ.1) THEN
76783 ELSEIF(MSTJ(109).EQ.0) THEN
76784 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
76785 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
76786 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
76788 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
76791 C...alpha_strong for jet rate. Initial value for y cut.
76792 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76793 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
76794 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
76795 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
76796 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
76798 C...Parametrization of first order three-jet cross-section.
76799 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
76802 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
76803 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
76804 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
76805 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
76806 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
76810 C...Parametrization of second order three-jet cross-section.
76811 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
76812 & CUT.GE.0.25D0) THEN
76814 ELSEIF(MSTJ(110).LE.1) THEN
76815 CT=LOG(1D0/CUT-2D0)
76816 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
76817 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
76819 C...Interpolation in second/first order ratio for Zhu parametrization.
76820 ELSEIF(MSTJ(110).EQ.2) THEN
76823 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
76829 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
76831 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
76834 C...Shift in second order three-jet cross-section with optimized Q^2.
76835 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
76836 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
76837 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
76839 C...Parametrization of second order four-jet cross-section.
76840 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
76843 CT=LOG(1D0/CUT-5D0)
76844 IF(CUT.LE.0.018D0) THEN
76845 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
76846 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
76848 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
76849 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
76851 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
76852 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
76853 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
76854 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
76855 & 0.002093D0*CT**3)
76856 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
76858 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
76859 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
76862 C...If negative three-jet rate, change y' optimization parameter.
76863 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
76864 & PARJ(169).LT.0.99D0) THEN
76865 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
76866 Q2=PARJ(169)*ECM**2
76867 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76871 C...If too high cross-section, use harder cuts, or fail.
76872 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
76873 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
76874 & PARJ(169).LT.0.99D0) THEN
76875 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
76876 Q2=PARJ(169)*ECM**2
76877 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76879 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
76881 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
76883 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
76884 & PARJ(154))**(-1D0/3D0)
76885 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
76889 C...Scalar gluon (first order only).
76891 ALSPI=PYALPS(ECM**2)/PARU(1)
76892 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
76894 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
76895 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
76900 C...Select number of jets.
76902 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
76904 ELSEIF(MSTJ(101).LE.0) THEN
76905 NJET=MIN(4,2-MSTJ(101))
76909 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
76910 IF(PARJ(154).GT.RNJ) NJET=4
76916 C*********************************************************************
76919 C...Selects the kinematical variables of three-jet events.
76921 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
76923 C...Double precision and integer declarations.
76924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76925 IMPLICIT INTEGER(I-N)
76926 INTEGER PYK,PYCHGE,PYCOMP
76928 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76931 DIMENSION ZHUP(5,12)
76933 C...Coefficients of Zhu second order parametrization.
76934 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
76935 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
76936 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
76937 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
76938 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
76939 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
76940 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
76941 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
76942 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
76943 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
76944 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
76946 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
76947 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
76950 C...Event type. Mass effect factors and other common constants.
76954 QME=(2D0*PMQ/ECM)**2
76955 IF(MSTJ(109).NE.1) THEN
76957 CUTD=LOG(1D0/CUT-2D0)
76958 IF(MSTJ(109).EQ.0) THEN
76962 WTMX=MIN(20D0,37D0-6D0*CUTD)
76963 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
76971 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
76972 ALS2PI=PARU(118)/PARU(2)
76974 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
76975 & LOG(PARJ(169))*ALS2PI
76976 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
76978 C...Choose three-jet events in allowed region.
76980 110 Y13L=CUTL+CUTD*PYR(0)
76981 Y23L=CUTL+CUTD*PYR(0)
76985 IF(Y12.LE.CUT) GOTO 110
76986 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
76988 C...Second order corrections.
76989 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
76994 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
76995 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
76996 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
76997 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
76998 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
76999 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
77000 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
77001 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
77002 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
77003 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
77004 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
77005 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
77006 & TR*(2D0*CUTL/3D0-10D0/9D0)+
77007 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
77008 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
77009 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
77010 & Y13*Y23)/(Y12+Y13)**2)/WT1+
77011 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
77012 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
77013 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
77014 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
77015 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
77016 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
77017 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
77018 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
77019 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
77020 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
77022 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
77023 C...Second order corrections; Zhu parametrization of ERT.
77028 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
77032 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77033 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77034 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77035 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77038 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77039 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77040 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77041 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77043 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77044 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77045 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77046 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77047 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
77049 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
77050 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
77051 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
77054 C...Impose mass cuts (gives two jets). For fixed jet number new try.
77058 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
77059 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
77060 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
77061 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
77062 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
77064 C...Scalar gluon model (first order only, no mass effects).
77067 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
77068 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
77069 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
77070 X1=1D0-0.5D0*(X3+YD)
77071 X2=1D0-0.5D0*(X3-YD)
77072 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
77073 IF(MSTJ(102).GE.2) THEN
77074 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
77075 & X3**2*PYR(0)) NJET=2
77077 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
77083 C*********************************************************************
77086 C...Selects the kinematical variables of four-jet events.
77088 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
77090 C...Double precision and integer declarations.
77091 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77092 IMPLICIT INTEGER(I-N)
77093 INTEGER PYK,PYCHGE,PYCOMP
77095 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77098 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
77100 C...Common constants. Colour factors for QCD and Abelian gluon theory.
77102 QME=(2D0*PMQ/ECM)**2
77103 CT=LOG(1D0/CUT-5D0)
77104 IF(MSTJ(109).EQ.0) THEN
77114 C...Choice of process (qqbargg or qqbarqqbar).
77117 IF(PARJ(155).GT.PYR(0)) IT=2
77118 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
77119 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
77120 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
77121 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
77124 C...Sample the five kinematical variables (for qqgg preweighted in y34).
77125 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
77126 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
77127 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
77128 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
77129 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
77131 CP=COS(PARU(1)*PYR(0))
77134 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
77135 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
77136 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
77138 Y12=1D0-Y134-Y23-Y24
77139 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
77143 C...Calculate matrix elements for qqgg or qqqq process.
77148 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
77149 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
77150 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
77151 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
77152 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
77153 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
77154 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
77155 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
77156 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
77157 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
77158 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
77159 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
77160 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
77161 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
77162 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
77163 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
77164 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
77165 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
77166 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
77167 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
77168 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
77169 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
77170 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
77171 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
77172 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
77173 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
77174 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
77175 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
77176 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
77177 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
77178 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
77179 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
77180 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
77181 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
77182 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
77183 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
77184 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
77185 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
77186 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
77187 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
77188 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
77191 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
77192 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
77193 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
77194 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
77195 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
77196 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
77197 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
77198 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
77199 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
77200 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
77201 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
77202 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
77203 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
77204 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
77205 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
77206 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
77207 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
77208 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
77211 C...Permutations of momenta in matrix element. Weighting.
77212 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
77223 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
77234 IF(IC.LE.3) GOTO 120
77235 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
77238 C...qqgg events: string configuration and event type.
77240 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
77241 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
77242 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
77243 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
77244 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
77245 IF(ID.EQ.2) GOTO 130
77246 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
77247 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
77248 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
77249 IF(ID.EQ.2) GOTO 130
77252 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
77253 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
77256 C...Mass cuts. Kinematical variables out.
77257 IF(Y12.LE.CUT+QME) NJET=2
77258 IF(NJET.EQ.2) GOTO 150
77259 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
77260 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
77261 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
77263 X12=(1D0-Q12)*Y13+Q12*Y23
77265 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
77267 C...qqbarqqbar events: string configuration, choose new flavour.
77270 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
77271 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
77272 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
77273 IF(WTR.LT.WTD(4)) ID=4
77274 IF(ID.GE.2) GOTO 130
77277 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
77278 140 KFLN=1+INT(5D0*PYR(0))
77279 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
77280 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
77281 IF(KFLN.GT.MSTJ(104)) NJET=2
77283 QMEN=(2D0*PMQN/ECM)**2
77285 C...Mass cuts. Kinematical variables out.
77286 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
77287 IF(NJET.EQ.2) GOTO 150
77288 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
77289 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
77290 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
77291 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
77292 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
77293 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
77296 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
77298 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
77299 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
77300 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
77302 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
77307 C*********************************************************************
77310 C...Gives the angular orientation of events.
77312 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
77314 C...Double precision and integer declarations.
77315 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77316 IMPLICIT INTEGER(I-N)
77317 INTEGER PYK,PYCHGE,PYCOMP
77319 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77320 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77321 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77322 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77324 C...Charge. Factors depending on polarization for QED case.
77326 POLL=1D0-PARJ(131)*PARJ(132)
77327 POLD=PARJ(132)-PARJ(131)
77328 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
77334 C...Factors depending on flavour, energy and polarization for QFD case.
77336 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
77337 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
77338 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
77340 VE=4D0*PARU(102)-1D0
77342 VF=AF-4D0*QF*PARU(102)
77343 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
77344 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
77345 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
77346 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
77347 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
77348 & SFW*SFF**2*(VE**2-AE**2))
77349 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
77353 C...Mass factor. Differential cross-sections for two-jet events.
77356 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
77357 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
77359 SIGU=4D0*SQRT(1D0-QME)
77360 SIGL=2D0*QME*SQRT(1D0-QME)
77366 C...Kinematical variables. Reduce four-jet event to three-jet one.
77369 X1=2D0*P(NC+1,4)/ECM
77370 X2=2D0*P(NC+3,4)/ECM
77372 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
77373 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
77374 X1=2D0*P(NC+1,4)/ECMR
77375 X2=2D0*P(NC+4,4)/ECMR
77378 C...Differential cross-sections for three-jet (or reduced four-jet).
77379 XQ=(1D0-X1)/(1D0-X2)
77380 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
77381 ST12=SQRT(1D0-CT12**2)
77382 IF(MSTJ(109).NE.1) THEN
77383 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
77384 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
77385 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
77386 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
77388 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
77389 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
77390 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
77391 SIGA=X2**2*ST12/SQ2
77392 SIGP=2D0*(X1**2-X2**2*CT12)
77394 C...Differential cross-sect for scalar gluons (no mass effects).
77398 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
77399 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
77400 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
77401 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
77402 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
77403 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
77404 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
77405 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
77406 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
77407 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
77408 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
77412 C...Upper bounds for differential cross-section.
77417 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
77418 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
77419 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
77420 &2D0*HF2A*ABS(SIGP)
77422 C...Generate angular orientation according to differential cross-sect.
77423 100 CHI=PARU(2)*PYR(0)
77424 CTHE=2D0*PYR(0)-1D0
77432 C2PHI=COS(2D0*(PHI-PARJ(134)))
77433 S2PHI=SIN(2D0*(PHI-PARJ(134)))
77434 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
77435 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
77436 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
77437 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
77438 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
77439 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
77440 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
77441 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
77446 C*********************************************************************
77449 C...Generates Upsilon and toponium decays into three gluons
77450 C...or two gluons and a photon.
77452 SUBROUTINE PYONIA(KFL,ECM)
77454 C...Double precision and integer declarations.
77455 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77456 IMPLICIT INTEGER(I-N)
77457 INTEGER PYK,PYCHGE,PYCOMP
77459 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77460 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77461 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77462 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77464 C...Printout. Check input parameters.
77465 IF(MSTU(12).NE.12345) CALL PYLIST(0)
77466 IF(KFL.LT.0.OR.KFL.GT.8) THEN
77467 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
77468 IF(MSTU(21).GE.1) RETURN
77470 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
77471 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
77472 IF(MSTU(21).GE.1) RETURN
77475 C...Initial e+e- and onium state (optional).
77477 IF(MSTJ(115).GE.2) THEN
77479 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
77481 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
77485 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
77491 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
77497 C...Choose x1 and x2 according to matrix element.
77502 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
77503 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
77506 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
77507 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
77509 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
77510 MSTU(111)=MSTJ(108)
77511 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
77513 PARU(112)=PARJ(121)
77514 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
77516 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
77517 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
77520 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
77521 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
77523 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
77524 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
77527 ECMC=SQRT(1D0-X1)*ECM
77528 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
77533 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
77534 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
77535 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
77536 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
77538 IF(ECMC.LT.4D0*PARJ(127)) THEN
77542 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
77548 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
77551 C...Differential cross-sections. Upper limit for cross-section.
77552 IF(MSTJ(106).EQ.1) THEN
77554 HF1=1D0-PARJ(131)*PARJ(132)
77556 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
77557 ST13=SQRT(1D0-CT13**2)
77558 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
77559 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
77561 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
77562 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
77563 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
77565 C...Angular orientation of event.
77566 120 CHI=PARU(2)*PYR(0)
77567 CTHE=2D0*PYR(0)-1D0
77575 C2PHI=COS(2D0*(PHI-PARJ(134)))
77576 S2PHI=SIN(2D0*(PHI-PARJ(134)))
77577 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
77578 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
77579 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
77580 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
77581 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
77582 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
77583 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
77584 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
77587 C...Generate parton shower. Rearrange along strings and check.
77588 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
77589 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
77591 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
77592 IF(MSTJ(105).GE.0) MSTU(28)=0
77595 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
77598 C...Generate fragmentation. Information for PYTABU:
77599 IF(MSTJ(105).EQ.1) CALL PYEXEC
77600 MSTU(161)=110*KFLC+3
77606 C*********************************************************************
77609 C...Books a histogram.
77611 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
77613 C...Double precision declaration.
77614 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77615 IMPLICIT INTEGER(I-N)
77617 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77619 C...Local character variables.
77620 CHARACTER TITLE*(*), TITFX*60
77622 C...Check that input is sensible. Find initial address in memory.
77623 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77624 &'(PYBOOK:) not allowed histogram number')
77625 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
77626 &'(PYBOOK:) not allowed number of bins')
77627 IF(XL.GE.XU) CALL PYERRM(28,
77628 &'(PYBOOK:) x limits in wrong order')
77630 IHIST(4)=IHIST(4)+28+NX
77631 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
77632 &'(PYBOOK:) out of histogram space')
77635 C...Store histogram size and reset contents.
77639 BIN(IS+4)=(XU-XL)/NX
77642 C...Store title by conversion to integer to double precision.
77645 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
77646 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
77652 C*********************************************************************
77655 C...Fills entry in histogram.
77657 SUBROUTINE PYFILL(ID,X,W)
77659 C...Double precision declaration.
77660 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77661 IMPLICIT INTEGER(I-N)
77663 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77666 C...Find initial address in memory. Increase number of entries.
77667 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77668 &'(PYFILL:) not allowed histogram number')
77670 IF(IS.EQ.0) CALL PYERRM(28,
77671 &'(PYFILL:) filling unbooked histogram')
77672 BIN(IS+5)=BIN(IS+5)+1D0
77674 C...Find bin in x, including under/overflow, and fill.
77675 IF(X.LT.BIN(IS+2)) THEN
77676 BIN(IS+6)=BIN(IS+6)+W
77677 ELSEIF(X.GE.BIN(IS+3)) THEN
77678 BIN(IS+8)=BIN(IS+8)+W
77680 BIN(IS+7)=BIN(IS+7)+W
77681 IX=(X-BIN(IS+2))/BIN(IS+4)
77682 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
77683 BIN(IS+9+IX)=BIN(IS+9+IX)+W
77689 C*********************************************************************
77692 C...Multiplies histogram contents by factor.
77694 SUBROUTINE PYFACT(ID,F)
77696 C...Double precision declaration.
77697 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77698 IMPLICIT INTEGER(I-N)
77700 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77703 C...Find initial address in memory. Multiply all contents bins.
77704 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77705 &'(PYFACT:) not allowed histogram number')
77707 IF(IS.EQ.0) CALL PYERRM(28,
77708 &'(PYFACT:) scaling unbooked histogram')
77709 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
77716 C*********************************************************************
77719 C...Performs operations between histograms.
77721 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
77723 C...Double precision declaration.
77724 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77725 IMPLICIT INTEGER(I-N)
77727 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77729 C...Character variable.
77732 C...Find initial addresses in memory, and histogram size.
77733 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
77734 &'(PYFACT:) not allowed histogram number')
77736 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
77737 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
77738 NX=NINT(BIN(IS3+1))
77739 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
77741 C...Update info on number of histogram entries.
77742 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
77743 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
77744 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
77745 BIN(IS3+5)=BIN(IS1+5)
77748 C...Operations on pair of histograms: addition, subtraction,
77749 C...multiplication, division.
77750 IF(OPER.EQ.'+') THEN
77752 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
77754 ELSEIF(OPER.EQ.'-') THEN
77756 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
77758 ELSEIF(OPER.EQ.'*') THEN
77760 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
77762 ELSEIF(OPER.EQ.'/') THEN
77765 IF(ABS(FA2).LE.1D-20) THEN
77768 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
77772 C...Operations on single histogram: multiplication+addition,
77773 C...square root+addition, logarithm+addition.
77774 ELSEIF(OPER.EQ.'A') THEN
77776 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
77778 ELSEIF(OPER.EQ.'S') THEN
77780 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
77782 ELSEIF(OPER.EQ.'L') THEN
77785 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
77786 & ZMIN=0.8D0*BIN(IS1+IX)
77789 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
77792 C...Operation on two or three histograms: average and
77793 C...standard deviation.
77794 ELSEIF(OPER.EQ.'M') THEN
77796 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
77799 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
77802 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
77805 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
77809 BIN(IS1+IX)=F1*BIN(IS1+IX)
77816 C*********************************************************************
77819 C...Prints and resets all histograms.
77823 C...Double precision declaration.
77824 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77825 IMPLICIT INTEGER(I-N)
77827 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77830 C...Loop over histograms, print and reset used ones.
77831 DO 100 ID=1,IHIST(1)
77833 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
77842 C*********************************************************************
77845 C...Prints a histogram (but does not reset it).
77847 SUBROUTINE PYPLOT(ID)
77849 C...Double precision declaration.
77850 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77851 IMPLICIT INTEGER(I-N)
77853 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77854 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77855 SAVE /PYDAT1/,/PYBINS/
77856 C...Local arrays and character variables.
77857 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
77858 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
77860 C...Steps in histogram scale. Character sequence.
77861 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
77862 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
77864 C...Find initial address in memory; skip if empty histogram.
77865 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
77868 IF(NINT(BIN(IS+5)).LE.0) THEN
77869 WRITE(MSTU(11),5000) ID
77873 C...Number of histogram lines and x bins.
77877 C...Extract title by conversion from double precision via integer.
77879 IEQ=NINT(BIN(IS+8+NX+IT))
77880 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
77881 & //CHAR(MOD(IEQ,256))
77884 C...Find time; print title.
77886 IF(IDATI(1).GT.0) THEN
77887 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
77889 WRITE(MSTU(11),5200) ID, TITLE
77892 C...Find minimum and maximum bin content.
77895 DO 110 IX=IS+10,IS+8+NX
77896 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
77897 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
77900 C...Determine scale and step size for y axis.
77901 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
77902 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
77903 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
77904 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
77905 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
77906 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
77909 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
77913 C...Convert bin contents to integer form; fractional fill in top row.
77915 CTA=ABS(BIN(IS+8+IX))/DY
77916 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
77917 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
77919 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
77920 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
77922 C...Print histogram row by row.
77923 DO 150 IR=IRMA,IRMI,-1
77924 IF(IR.EQ.0) GOTO 150
77927 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
77928 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
77930 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
77933 C...Print sign and value of bin contents.
77934 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
77937 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
77938 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
77940 WRITE(MSTU(11),5400) OUT
77943 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
77945 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
77948 C...Print sign and value of lower bin edge.
77949 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
77953 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
77954 & OUT(IX:IX)=CHA(11)
77955 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
77957 WRITE(MSTU(11),5600) OUT
77960 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
77962 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
77966 C...Calculate and print statistics.
77971 CTA=ABS(BIN(IS+8+IX))
77972 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
77975 CXXSUM=CXXSUM+CTA*X**2
77977 XMEAN=CXSUM/MAX(CSUM,1D-20)
77978 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
77979 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
77980 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
77982 C...Formats for output.
77983 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
77984 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
77986 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
77987 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
77988 5400 FORMAT(/8X,'Contents',3X,A100)
77989 5500 FORMAT(9X,'*10**',I2,3X,A100)
77990 5600 FORMAT(/8X,'Low edge',3X,A100)
77991 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
77992 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
77993 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
77998 C*********************************************************************
78001 C...Resets bin contents of a histogram.
78003 SUBROUTINE PYNULL(ID)
78005 C...Double precision declaration.
78006 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78007 IMPLICIT INTEGER(I-N)
78009 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
78012 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
78015 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
78022 C*********************************************************************
78025 C...Dumps histogram contents on file for reading by other program.
78026 C...Can also read back own dump.
78028 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
78030 C...Double precision declaration.
78031 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78032 IMPLICIT INTEGER(I-N)
78034 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
78036 C...Local arrays and character variables.
78037 DIMENSION IHI(*),ISS(100),VAL(5)
78038 CHARACTER TITLE*60,FORMAT*13
78040 C...Dump all histograms that have been booked,
78041 C...including titles and ranges, one after the other.
78042 IF(MDUMP.EQ.1) THEN
78044 C...Loop over histograms and find which are wanted and booked.
78059 C...Write title, histogram size, filling statistics.
78062 IEQ=NINT(BIN(IS+8+NX+IT))
78063 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
78064 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
78066 WRITE(LFN,5100) ID,TITLE
78067 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
78068 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
78072 C...Write histogram contents, in groups of five.
78073 DO 120 IXG=1,(NX+4)/5
78077 VAL(IXV)=BIN(IS+8+IX)
78082 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
78085 C...Go to next histogram; finish.
78086 ELSEIF(NHI.GT.0) THEN
78087 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
78091 C...Read back in histograms dumped MDUMP=1.
78092 ELSEIF(MDUMP.EQ.2) THEN
78094 C...Read histogram number, title and range, and book.
78095 140 READ(LFN,5100,END=170) ID,TITLE
78096 READ(LFN,5200) NX,XL,XU
78097 CALL PYBOOK(ID,TITLE,NX,XL,XU)
78100 C...Read filling statistics.
78101 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
78102 BIN(IS+5)=DBLE(NENTRY)
78104 C...Read histogram contents, in groups of five.
78105 DO 160 IXG=1,(NX+4)/5
78106 READ(LFN,5400) (VAL(IXV),IXV=1,5)
78109 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
78113 C...Go to next histogram; finish.
78117 C...Write histogram contents in column format,
78118 C...convenient e.g. for GNUPLOT input.
78119 ELSEIF(MDUMP.EQ.3) THEN
78121 C...Find addresses to wanted histograms.
78135 IF(IS.NE.0.AND.NSS.LT.100) THEN
78138 ELSEIF(NSS.GE.100) THEN
78139 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
78140 ELSEIF(NHI.GT.0) THEN
78141 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
78145 C...Check that they have common number of x bins. Fix format.
78146 NX=NINT(BIN(ISS(1)+1))
78148 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
78149 CALL PYERRM(8,'(PYDUMP:) different number of bins')
78153 FORMAT='(1P,000E12.4)'
78154 WRITE(FORMAT(5:7),'(I3)') NSS+1
78156 C...Write histogram contents; first column x values.
78158 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
78159 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
78164 C...Formats for output.
78165 5100 FORMAT(I5,5X,A60)
78166 5200 FORMAT(I5,1P,2D12.4)
78167 5300 FORMAT(I12,1P,3D12.4)
78168 5400 FORMAT(1P,5D12.4)
78173 C*********************************************************************
78176 C...Allows users to handle STOP statemens
78178 SUBROUTINE PYSTOP(MCOD)
78180 C...Double precision and integer declarations.
78181 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78182 IMPLICIT INTEGER(I-N)
78183 INTEGER PYK,PYCHGE,PYCOMP
78185 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78189 C...Write message, then stop
78190 WRITE(MSTU(11),5000) MCOD
78194 C...Formats for output.
78195 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
78198 C*********************************************************************
78201 C...Dummy routine, which the user can replace in order to make cuts on
78202 C...the kinematics on the parton level before the matrix elements are
78203 C...evaluated and the event is generated. The cross-section estimates
78204 C...will automatically take these cuts into account, so the given
78205 C...values are for the allowed phase space region only. MCUT=0 means
78206 C...that the event has passed the cuts, MCUT=1 that it has failed.
78208 SUBROUTINE PYKCUT(MCUT)
78210 C...Double precision and integer declarations.
78211 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78212 IMPLICIT INTEGER(I-N)
78213 INTEGER PYK,PYCHGE,PYCOMP
78215 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78216 COMMON/PYINT1/MINT(400),VINT(400)
78217 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
78218 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
78220 C...Set default value (accepting event) for MCUT.
78223 C...Read out subprocess number.
78227 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78231 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
78233 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
78235 C...Calculate x_1, x_2, x_F.
78236 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
78237 X1=SQRT(TAU)*EXP(YST)
78238 X2=SQRT(TAU)*EXP(-YST)
78240 X1=SQRT(TAUP)*EXP(YST)
78241 X2=SQRT(TAUP)*EXP(-YST)
78245 C...Calculate shat, that, uhat, p_T^2.
78251 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
78252 RPTS=4D0*VINT(71)**2/SHAT
78253 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
78256 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
78257 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
78258 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
78259 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
78261 C...Decisions by user to be put here.
78263 C...Stop program if this routine is ever called.
78264 C...You should not copy these lines to your own routine.
78265 WRITE(MSTU(11),5000)
78268 C...Format for error printout.
78269 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
78270 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78271 &1X,'Execution stopped!')
78276 C*********************************************************************
78279 C...Dummy routine, which the user can replace in order to multiply the
78280 C...standard PYTHIA differential cross-section by a process- and
78281 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
78282 C...to generation of weighted events, with weight 1/WTXS, while for
78283 C...MSTP(142)=2 it corresponds to a modification of the underlying
78286 SUBROUTINE PYEVWT(WTXS)
78288 C...Double precision and integer declarations.
78289 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78290 IMPLICIT INTEGER(I-N)
78291 INTEGER PYK,PYCHGE,PYCOMP
78293 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78294 COMMON/PYINT1/MINT(400),VINT(400)
78295 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
78296 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
78298 C...Set default weight for WTXS.
78301 C...Read out subprocess number.
78305 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78309 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
78311 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
78313 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
78322 C...Modifications by user to be put here.
78324 C...Stop program if this routine is ever called.
78325 C...You should not copy these lines to your own routine.
78326 WRITE(MSTU(11),5000)
78329 C...Format for error printout.
78330 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
78331 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78332 &1X,'Execution stopped!')
78337 C*********************************************************************
78340 C...Dummy routine, to be replaced by a user implementing external
78341 C...processes. Is supposed to fill the HEPRUP commonblock with info
78342 C...on incoming beams and allowed processes.
78344 C...New example: handles a standard Les Houches Events File.
78348 C...Double precision and integer declarations.
78349 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78350 IMPLICIT INTEGER(I-N)
78352 C...PYTHIA commonblock: only used to provide read unit MSTP(161).
78353 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78356 C...User process initialization commonblock.
78358 PARAMETER (MAXPUP=100)
78359 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78360 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78361 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78362 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78366 C...Lines to read in assumed never longer than 200 characters.
78367 PARAMETER (MAXLEN=200)
78368 CHARACTER*(MAXLEN) STRING
78370 C...Format for reading lines.
78373 WRITE(STRFMT(3:5),'(I3)') MAXLEN
78375 C...Loop until finds line beginning with "<init>" or "<init ".
78376 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
78379 C...Allow indentation.
78380 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
78381 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
78382 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
78384 C...Read first line of initialization info.
78385 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
78386 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78388 C...Read NPRUP subsequent lines with information on each process.
78390 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
78391 & XMAXUP(IPR),LPRUP(IPR)
78395 C...Error exit: give up if initalization does not work.
78396 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
78397 WRITE(*,*) ' Event generation will be stopped.'
78403 C...Old example: handles a simple Pythia 6.4 initialization file.
78405 c SUBROUTINE UPINIT
78407 C...Double precision and integer declarations.
78408 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78409 c IMPLICIT INTEGER(I-N)
78412 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78413 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78414 c SAVE /PYDAT1/,/PYPARS/
78416 C...User process initialization commonblock.
78418 c PARAMETER (MAXPUP=100)
78419 c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78420 c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78421 c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78422 c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78426 C...Read info from file.
78427 c IF(MSTP(161).GT.0) THEN
78428 c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
78429 c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78430 c DO 100 IPR=1,NPRUP
78431 c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
78432 c & XMAXUP(IPR),LPRUP(IPR)
78435 C...Error or prematurely reached end of file.
78436 c 110 WRITE(MSTU(11),5000)
78439 C...Else not implemented.
78441 c WRITE(MSTU(11),5100)
78445 C...Format for error printout.
78446 c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
78447 c &1X,'Execution stopped!')
78448 c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
78449 c &1X,'Dummy routine in PYTHIA file called instead.'/
78450 c &1X,'Execution stopped!')
78455 C*********************************************************************
78458 C...Dummy routine, to be replaced by a user implementing external
78459 C...processes. Depending on cross section model chosen, it either has
78460 C...to generate a process of the type IDPRUP requested, or pick a type
78461 C...itself and generate this event. The event is to be stored in the
78462 C...HEPEUP commonblock, including (often) an event weight.
78464 C...New example: handles a standard Les Houches Events File.
78468 C...Double precision and integer declarations.
78469 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78470 IMPLICIT INTEGER(I-N)
78472 C...PYTHIA commonblock: only used to provide read unit MSTP(162).
78473 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78476 C...User process event common block.
78478 PARAMETER (MAXNUP=500)
78479 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78480 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78481 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78482 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78483 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78486 C...Lines to read in assumed never longer than 200 characters.
78487 PARAMETER (MAXLEN=200)
78488 CHARACTER*(MAXLEN) STRING
78490 C...Format for reading lines.
78493 WRITE(STRFMT(3:5),'(I3)') MAXLEN
78495 C...Loop until finds line beginning with "<event>" or "<event ".
78496 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
78499 C...Allow indentation.
78500 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
78501 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
78502 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
78504 C...Read first line of event info.
78505 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
78508 C...Read NUP subsequent lines with information on each particle.
78510 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
78511 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78512 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78516 C...Error exit, typically when no more events.
78517 130 WRITE(*,*) ' Failed to read LHEF event information.'
78518 WRITE(*,*) ' Will assume end of file has been reached.'
78525 C...Old example: handles a simple Pythia 6.4 event file.
78527 c SUBROUTINE UPEVNT
78529 C...Double precision and integer declarations.
78530 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78531 c IMPLICIT INTEGER(I-N)
78534 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78535 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78536 c SAVE /PYDAT1/,/PYPARS/
78538 C...User process event common block.
78540 c PARAMETER (MAXNUP=500)
78541 c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78542 c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78543 c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78544 c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78545 c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78548 C...Read info from file.
78549 c IF(MSTP(162).GT.0) THEN
78550 c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
78553 c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
78554 c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78555 c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78558 C...Special when reached end of file or other error.
78561 C...Else not implemented.
78563 c WRITE(MSTU(11),5000)
78567 C...Format for error printout.
78568 c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
78569 c &1X,'Dummy routine in PYTHIA file called instead.'/
78570 c &1X,'Execution stopped!')
78575 C*********************************************************************
78578 C...Dummy routine, to be replaced by user, to veto event generation
78579 C...on the parton level, after parton showers but before multiple
78580 C...interactions, beam remnants and hadronization is added.
78581 C...If resonances like W, Z, top, Higgs and SUSY particles are handed
78582 C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
78583 C...be undecayed at this stage; if decayed their decay products will
78584 C...have been allowed to shower.
78586 C...All partons at the end of the shower phase are stored in the
78587 C...HEPEVT commonblock. The interesting information is
78588 C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
78589 C...IDHEP(I) = the particle ID code according to PDG conventions,
78590 C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
78591 C...All ISTHEP entries are 1, while the rest is zeroed.
78593 C...The user decision is to be conveyed by the IVETO value.
78594 C...IVETO = 0 : retain current event and generate in full;
78595 C... = 1 : abort generation of current event and move to next.
78597 SUBROUTINE UPVETO(IVETO)
78599 C...HEPEVT commonblock.
78600 PARAMETER (NMXHEP=4000)
78601 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
78602 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
78603 DOUBLE PRECISION PHEP,VHEP
78606 C...Next few lines allow you to see what info PYVETO extracted from
78607 C...the full event record for the first two events.
78608 C...Delete if you don't want it.
78611 IF(NLIST.LE.2) THEN
78612 WRITE(*,*) ' Full event record at time of UPVETO call:'
78614 WRITE(*,*) ' Part of event record made available to UPVETO:'
78619 C...Make decision here.
78625 C*********************************************************************
78627 C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
78629 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
78630 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78631 IMPLICIT INTEGER(I-N)
78632 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
78635 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78638 C...Stop program if this routine is ever called.
78639 WRITE(MSTU(11),5000)
78642 C...Format for error printout.
78643 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78644 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
78645 &1X,'Execution stopped!')
78650 C*********************************************************************
78653 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78656 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78657 IMPLICIT INTEGER(I-N)
78658 CHARACTER*40 VISAJE
78661 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78664 C...Assign default value.
78667 C...Stop program if this routine is ever called.
78668 WRITE(MSTU(11),5000)
78671 C...Format for error printout.
78672 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78673 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
78674 &1X,'Execution stopped!')
78679 C*********************************************************************
78682 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78684 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
78685 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
78686 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
78688 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78689 IMPLICIT INTEGER(I-N)
78690 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
78691 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
78692 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
78694 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78697 C...Stop program if this routine is ever called.
78698 WRITE(MSTU(11),5000)
78701 C...Format for error printout.
78702 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78703 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
78704 &1X,'Execution stopped!')
78708 C*********************************************************************
78711 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78713 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
78714 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78715 IMPLICIT INTEGER(I-N)
78716 Cmssmpart = 4 # full MSSM [recommended]
78717 Cfieldren = 0 # MSbar field ren. [strongly recommended]
78718 Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
78719 Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
78720 Cp2approx = 0 # no approximation [recommended]
78721 Clooplevel= 2 # include 2-loop corrections
78722 Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
78723 Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
78726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78729 C...Stop program if this routine is ever called.
78730 WRITE(MSTU(11),5000)
78733 C...Format for error printout.
78734 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78735 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
78736 &1X,'Execution stopped!')
78740 C*********************************************************************
78743 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78745 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
78746 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
78747 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
78748 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
78749 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78750 IMPLICIT INTEGER(I-N)
78752 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78753 DOUBLE COMPLEX DMU,
78754 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78758 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78761 C...Stop program if this routine is ever called.
78762 WRITE(MSTU(11),5000)
78765 C...Format for error printout.
78766 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78767 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78768 &1X,'Execution stopped!')
78772 C*********************************************************************
78775 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78777 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
78778 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78779 IMPLICIT INTEGER(I-N)
78781 C...FeynHiggs variables
78782 DOUBLE PRECISION RMHIGG(4)
78783 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78784 DOUBLE COMPLEX DMU,
78785 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78789 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78792 C...Stop program if this routine is ever called.
78793 WRITE(MSTU(11),5000)
78796 C...Format for error printout.
78797 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78798 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78799 &1X,'Execution stopped!')
78803 C*********************************************************************
78806 C...Dummy routine, to be replaced by user, to handle the decay of a
78807 C...polarized tau lepton.
78809 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
78810 C...IORIG is the position where the mother of the tau is stored;
78811 C... is 0 when the mother is not stored.
78812 C...KFORIG is the flavour of the mother of the tau;
78813 C... is 0 when the mother is not known.
78814 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
78815 C... e.g. in B hadron semileptonic decays the W propagator
78816 C... is not explicitly stored but the W code is still unambiguous.
78818 C...NDECAY is the number of decay products in the current tau decay.
78819 C...These decay products should be added to the /PYJETS/ common block,
78820 C...in positions N+1 through N+NDECAY. For each product I you must
78821 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
78822 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
78824 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
78826 C...Double precision and integer declarations.
78827 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78828 IMPLICIT INTEGER(I-N)
78829 INTEGER PYK,PYCHGE,PYCOMP
78831 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
78832 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78833 SAVE /PYJETS/,/PYDAT1/
78835 C...Stop program if this routine is ever called.
78836 C...You should not copy these lines to your own routine.
78837 NDECAY=ITAU+IORIG+KFORIG
78838 WRITE(MSTU(11),5000)
78841 C...Format for error printout.
78842 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
78843 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78844 &1X,'Execution stopped!')
78849 C*********************************************************************
78852 C...Finds current date and time.
78853 C...Since this task is not standardized in Fortran 77, the routine
78854 C...is dummy, to be replaced by the user. Examples are given for
78855 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
78856 C...you do not have access to suitable routines.
78858 SUBROUTINE PYTIME(IDATI)
78860 C...Double precision and integer declarations.
78861 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78862 IMPLICIT INTEGER(I-N)
78863 INTEGER PYK,PYCHGE,PYCOMP
78866 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
78868 C...Example 0: if you do not have suitable routines.
78873 C...Example 1: Fortran 90 routine.
78874 C CALL DATE_AND_TIME(VALUES=IVAL)
78882 C...Example 2: DEC Fortran 77. AIX.
78883 C CALL IDATE(IMON,IDAY,IYEAR)
78887 C CALL ITIME(IHOUR,IMIN,ISEC)
78892 C...Example 3: DEC Fortran, IRIX, IRIX64.
78893 C CALL IDATE(IMON,IDAY,IYEAR)
78901 C READ(ATIME(1:2),'(I2)') IHOUR
78902 C READ(ATIME(4:5),'(I2)') IMIN
78903 C READ(ATIME(7:8),'(I2)') ISEC
78908 C...Example 4: GNU LINUX libU77, SunOS.
78909 C CALL IDATE(IDTEMP)
78910 C IDATI(1)=IDTEMP(3)
78911 C IDATI(2)=IDTEMP(2)
78912 C IDATI(3)=IDTEMP(1)
78913 C CALL ITIME(IDTEMP)
78914 C IDATI(4)=IDTEMP(1)
78915 C IDATI(5)=IDTEMP(2)
78916 C IDATI(6)=IDTEMP(3)
78918 C...Common code to ensure right century.
78919 IDATI(1)=2000+MOD(IDATI(1),100)
78923 C... ALICE interface to PDFLIB with possibility to select nuclear structure
78926 C... The MSTP array in the PYPARS common block is used to enable and
78927 C... select the nuclear structure functions.
78928 C... MSTP(52) : (D=1) choice of proton and nuclear structure-function library
78929 C... =1: internal PYTHIA acording to MSTP(51)
78930 C... =2: PDFLIB proton s.f., with MSTP(51) = 1000xNGROUP+NSET
78931 C... MSTP( 51) = 1000xNPGROUP+NPSET
78932 C... MSTP(151) = 1000xNAGROUP+NASET
78933 C... MSTP(192) : Mass number of nucleus side 1
78934 C... MSTP(193) : Mass number of nucleus side 2
78937 C... MINT(124) : side (1 or 2)
78940 SUBROUTINE PDFSET_ALICE(PARM, VALUE)
78942 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78943 IMPLICIT INTEGER(I-N)
78944 C...Interface to PDFLIB.
78945 COMMON/LW50512/QCDL4,QCDL5
78947 DOUBLE PRECISION QCDL4,QCDL5
78948 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
78950 DOUBLE PRECISION XMIN,XMAX,Q2MIN,Q2MAX
78952 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78953 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78954 DOUBLE PRECISION VALUE(20)
78955 CHARACTER*20 PARM(20)
78956 write(6,*) MSTP(52)
78960 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
78964 VALUE(6)=MSTP(191)/1000
78966 VALUE(7)=MOD(MSTP(191),1000)
78967 CALL PDFSET(PARM,VALUE,
78968 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
78970 > XMIN,XMAX,Q2MIN,Q2MAX)
78971 IF (MSTP(194) .EQ. 0) THEN
78972 CALL SETLHAPARM("EKS98")
78974 CALL SETLHAPARM("EPS08")
78977 write(6,*) "-> pdfset"
78978 CALL PDFSET(PARM,VALUE,
78979 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
78981 > XMIN,XMAX,Q2MIN,Q2MAX)
78988 SUBROUTINE STRUCTM_ALICE
78989 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
78991 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78992 IMPLICIT INTEGER(I-N)
78993 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78994 COMMON/PYINT1/MINT(400),VINT(400)
78995 C write(6,*) "structm_alice->"
78996 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
78997 A=MSTP(191+MINT(124))
78998 C write(6,*) mint(124), "-> structa ", A
78999 CALL STRUCTA(XX,QQ,A,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
79001 C write(6,*) mint(124), "-> structm "
79002 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
git://git.uio.no / u / mrichter / AliRoot.git / blob