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 PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
15036 C... Ensure mininimum PT2CR and force creation near threshold.
15037 IF (PT2CR.LT.TMIN*RMQ2) THEN
15039 IF (NTHRES.GT.50) THEN
15040 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
15041 & 'massive quark creation. Gave up trying.')
15043 C...Special return code if failing before any evolution at all: bad event
15044 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
15051 C... Select largest PT2 (brems or creation):
15052 IF (PT2CR.GT.PT2) THEN
15061 C... Compute logarithms for this PT2
15062 TPL=LOG((PT2+VINT(18))/ALAM2)
15063 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
15064 WTCRQQ=TPM/LOG(PT2/RMQ2)
15067 C...Evolve joining separately
15069 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
15070 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
15072 IF (PT2JN.GE.PT2) THEN
15078 C...Loopback if crossed c/b mass thresholds.
15079 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
15082 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
15087 C...Speed up shower. Skip if higher-PT acceptable branching
15088 C...already found somewhere else.
15089 C...Also finish if below lower cutoff.
15091 IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
15093 C...Select parton A flavour (massive Q handled above.)
15094 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
15098 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
15099 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
15100 IF(KFLA.EQ.6) KFLA=21
15101 ELSEIF (MJOIN.EQ.1) THEN
15102 C...Tentative joining accept/reject.
15103 WTRAN=PYR(0)*WTJOIN
15106 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
15107 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
15108 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
15109 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
15113 C...x*pdf (+ sea/val) at new pT2 for parton B.
15114 IF (KSVCB.LE.0) THEN
15117 C.... Store side in MINT(124)
15120 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
15121 IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
15123 C...Companion distributions do not evolve.
15126 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
15127 KFLC=K(IMI(JS,MJ,1),2)
15129 KSVCC=MAX(-1,IMI(JS,MJ,2))
15130 IF (KSVCB.GE.1) KSVCC=-1
15131 C...x*pdf (+ sea/val) at new pT2 for parton C.
15135 C.... Store side in MINT(124)
15138 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
15140 IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
15141 WTVETO=WTVETO/XFJ(KFLC)
15142 C...x and x*pdf (+ sea/val) at new pT2 for parton A.
15145 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
15148 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15152 IF (KSVCA.LE.0) THEN
15155 C.... Store side in MINT(124)
15158 IF (KFLB.EQ.21) MINT(36)=MJ
15159 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15161 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15163 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
15165 WTVETO=WTVETO*XFJ(KFLA)
15166 C...Monte Carlo veto.
15167 IF (WTVETO.LT.PYR(0)) GOTO 200
15168 C...If accept, save PT2 of this joining.
15169 IF (PT2.GT.PT2MX) THEN
15177 C...Exit and continue evolution.
15182 C...Choose z value (still in overestimated range) and corrective weight.
15183 C...Unphysical z will be rejected below when Q2 has is computed.
15186 C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
15187 C...q -> q + g or q -> q + gamma (already set which).
15188 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
15189 IF (KSVCB.LT.0) THEN
15190 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
15192 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
15193 Z=((1-ZFAC)/(1+ZFAC))**2
15195 WTZ=0.5D0*(1D0+Z**2)
15196 C...Massive weight correction.
15197 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
15198 C...Valence quark weight correction (extra sqrt)
15199 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
15202 C...NB: MQ>0 not yet implemented. Forced absent above.
15203 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
15205 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
15206 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
15209 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
15211 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
15212 WTZ=Z**2+(1D0-Z)**2
15213 C...Massive correction
15214 IF (MQMASS.NE.0) THEN
15215 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
15216 C...Extra safety margin for light sea quark creation
15217 ELSEIF (KSVCB.LT.0) THEN
15222 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15224 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
15225 & (ZMAX*(1D0-ZMIN)))**PYR(0))
15226 WTZ=(1D0-Z*(1D0-Z))**2
15229 C...Derive Q2 from pT2.
15231 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
15233 C...Loopback if outside allowed z range for given pT2.
15234 RM2C=PYMASS(KFLC)**2
15235 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
15236 IF (PT2ADJ.LT.1D-6) GOTO 230
15238 C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
15239 C...No modification for very first emission if using ME correction
15241 IF (MECOR.GE.1.AND.NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) THEN
15245 C...For 1st branching, limit phase space by s-hat with color-partner
15246 IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15249 C...Use anticolor tag for antiquark, or for gluon half the time
15250 IF ((KFLB.LT.0.AND.KFLBA.LT.10).OR.(
15251 & KFLB.EQ.21.AND.PYR(0).GT.0.5)) MSIDE=2
15253 MCTAG=MCT(IDIP,MSIDE)
15254 C...Default is to set up phase space using the opposite incoming parton
15255 JDIP=IMI(3-JS,MI,1)
15257 C...Alternatively, look for final-state color partner (pick first if several)
15259 IF (MCT(IPART(IFS),MSIDE).EQ.MCTAG.AND.NDIP.EQ.0) THEN
15264 C...Compute mass of pair
15265 SDIP=(P(IDIP,4)+P(JDIP,4))**2-(P(IDIP,3)+P(JDIP,3))**2
15266 & -(P(IDIP,2)+P(JDIP,2))**2-(P(IDIP,1)+P(JDIP,1))**2
15267 IF (MSTP67.EQ.1) THEN
15268 C...1 Option to completely kill radiation above s_dip * PARP(67)
15269 IF (4*PT2.GT.PARP(67)*SDIP) GOTO 230
15270 ELSE IF (MSTP67.EQ.2) THEN
15271 C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
15272 C... (-> improved power showers?)
15273 IF (4*PT2*PYR(0).GT.PARP(67)*SDIP) GOTO 230
15276 C...For subsequent branchings, loopback if nonordered in angle/rapidity
15277 ELSE IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
15278 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
15282 C...Select phi angle of branching at random.
15285 C...Matrix-element corrections for some processes.
15286 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15287 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
15288 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15290 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
15291 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15293 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
15294 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15296 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15297 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15302 C...Parton distributions at new pT2 but old x.
15305 C.... Store side in MINT(124)
15308 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
15309 C...Treat val and cmp separately
15310 IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
15312 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
15314 IF(XFBN.LT.1D-20) THEN
15315 IF(KFLA.EQ.KFLB) THEN
15328 C...Parton distributions at new pT2 and new x.
15332 C.... Store side in MINT(124)
15335 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
15336 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
15337 C...q -> q + g: only consider respective sea, val, or cmp content.
15338 IF (KSVCB.LE.0) THEN
15339 XFA(KFLA)=XPSVC(KFLA,KSVCB)
15342 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
15346 IF(XFAN.LT.1D-20) THEN
15350 C...If weighting fails continue evolution.
15352 IF (MCRQQ.EQ.0) THEN
15353 WTPDFA=1D0/WTPDF(KFLA)
15354 WTTOT=WTZ*XFAN/XFBN*WTPDFA
15355 ELSEIF(MCRQQ.EQ.1) THEN
15357 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
15359 ELSEIF(MCRQQ.EQ.2) THEN
15360 C...Force massive quark creation.
15364 C...Loop back if trial emission fails.
15365 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
15366 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
15367 IF(WTTOT.LT.0D0) THEN
15368 WRITE(CHWT,'(1P,E12.4)') WTTOT
15369 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
15370 ELSEIF(WTTOT.GT.WTACC) THEN
15371 WRITE(CHWT,'(1P,E12.4)') WTTOT
15372 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
15373 C...Too high weight: write out as error, but do not update error counter
15374 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
15376 & '(PYPTIS:) Weight '//CHWT//' above unity')
15377 IF (PT2.GT.PTEMAX) PTEMAX=PT2
15378 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
15381 & '(PYPTIS:) Weight '//CHWT//' above unity')
15383 C...Useful for debugging but commented out for distribution:
15384 C print*, 'JS, MI',JS, MI
15385 C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
15386 C print*, 'A -> B C',KFLA, KFLB, KFLC
15388 C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
15391 C...Save acceptable branching.
15392 IF(PT2.GT.PT2MX) THEN
15405 C----------------------------------------------------------------------
15406 C...MODE= 1: Accept stored shower branching. Update event record etc.
15407 ELSEIF (MODE.EQ.1) THEN
15412 C...Shift down rest of event record to make room for insertion.
15417 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
15418 KT1=K(I,4)/MSTU(5)**2
15419 KT2=K(I,5)/MSTU(5)**2
15420 ID1=MOD(K(I,4),MSTU(5))
15421 ID2=MOD(K(I,5),MSTU(5))
15422 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
15423 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
15424 IF (ID1.GE.IT) ID1=ID1+2
15425 IF (ID2.GE.IT) ID2=ID2+2
15426 IF (IM1.GE.IT) IM1=IM1+2
15427 IF (IM2.GE.IT) IM2=IM2+2
15428 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
15429 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
15435 MCT(I+2,1)=MCT(I,1)
15436 MCT(I+2,2)=MCT(I,2)
15439 C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
15440 DO 300 JI=1,MINT(31)
15441 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
15442 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
15443 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
15444 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
15445 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
15446 C...Also update companion pointers to the present mother.
15447 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
15450 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
15452 C...Zero entries dedicated for new timelike and mother partons.
15463 C...Define timelike and new mother partons. History.
15470 C...Set mother origin = side.
15471 K(IM,3)=MINT(83)+JS+2
15472 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
15474 C...Define colour flow of branching.
15477 C...q -> q + gamma.
15478 IF(K(IT,2).EQ.22) THEN
15483 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
15487 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
15490 C...qbar -> qbar + g.
15491 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
15494 C...qbar -> g + qbar.
15495 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
15498 C...g -> g + g; g -> q + qbar..
15499 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
15506 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
15507 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
15508 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
15509 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
15510 IF(ID1.NE.ID2) THEN
15511 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
15512 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
15514 IF(K(IT,1).EQ.1) THEN
15518 C...Update IMI and colour tag arrays.
15526 C...If mother flag not yet set for spacelike parton, trace it.
15527 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
15528 IF(MINT(51).NE.0) RETURN
15532 C...If mother flag not yet set for timelike parton, trace it.
15533 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
15534 IF(MINT(51).NE.0) RETURN
15537 C...Boost recoiling parton to compensate for Q2 scale.
15538 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
15539 & (1D0+(1D0+Q2BMX/SHAT)**2)
15541 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
15543 C...Define system to be rotated and boosted
15544 C...(not including the 2 just added partons)
15545 C...(but including the docu lines for first interaction)
15546 IMIN=IMISEP(MI-1)+1
15547 IF (MI.EQ.1) IMIN=MINT(83)+5
15550 C...Rotate back system in phi to compensate for subsequent rotation.
15551 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
15553 C...Define kinematics of new partons in old frame.
15555 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
15556 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
15557 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
15558 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
15560 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
15561 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
15562 P(IT,5)=SQRT(RM2CMX)
15564 C...Update internal line, now spacelike
15565 P(IS,1)=P(IM,1)-P(IT,1)
15566 P(IS,2)=P(IM,2)-P(IT,2)
15567 P(IS,3)=P(IM,3)-P(IT,3)
15568 P(IS,4)=P(IM,4)-P(IT,4)
15569 P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
15570 C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
15571 IF (P(IS,5).LT.0D0) THEN
15572 P(IS,5)=-SQRT(ABS(P(IS,5)))
15574 P(IS,5)=SQRT(P(IS,5))
15577 C...Boost entire system and rotate to new frame.
15578 C...(including docu lines)
15579 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
15580 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
15581 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
15582 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
15587 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
15589 THETA=PYANGL(P(I1,3),P(I1,1))
15590 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
15592 C...Global statistics.
15593 MINT(352)=MINT(352)+1
15594 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
15595 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
15597 C...Add parton with relevant pT scale for timelike shower.
15598 IF (K(IT,2).NE.22) THEN
15601 PTPART(NPART)=SQRT(PT2AMX)
15604 C...Update saved variables.
15605 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15606 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15607 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15608 PT2SAV(JSMX,MIMX)=PT2MX
15613 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15614 C...Gluon reconstructs to quark.
15615 C...Decide whether newly created quark is valence or sea:
15617 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15618 IF(MINT(51).NE.0) RETURN
15620 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15621 C...Quark reconstructs to gluon.
15622 C...Now some guy may have lost his companion. Check.
15624 IF (ICMP.GT.0) THEN
15625 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15626 & //' away. Cannot handle that yet. Giving up.')
15629 ELSEIF(ICMP.LT.0) THEN
15630 C...A sea quark with companion still in BR was reconstructed to a gluon.
15631 C...Companion should now be removed from the beam remnant.
15632 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15635 DO 380 JCMP=ICMP,NVC(JS,IFL)-1
15636 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15637 DO 370 JI=1,MINT(31)
15639 JFL=-K(IMI(JS,JI,1),2)
15640 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15644 NVC(JS,IFL)=NVC(JS,IFL)-1
15646 C...Set gluon IMI(JS,MI,2) = 0.
15648 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15649 C...Quark reconstructing to quark. If sea with companion still in BR
15650 C...then update associated x value.
15651 C...(Momentum integral is automatically updated in next call to PYPDFU.)
15652 IF (IMI(JS,MI,2).LT.0) THEN
15655 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15661 C...If reached this point, normal exit.
15667 C*********************************************************************
15670 C...Generates maximum ME weight in some initial-state showers.
15671 C...Inparameter MECOR: kind of hard scattering process
15672 C...Outparameter WTFF: maximum weight for fermion -> fermion
15673 C... WTGF: maximum weight for gluon/photon -> fermion
15674 C... WTFG: maximum weight for fermion -> gluon/photon
15675 C... WTGG: maximum weight for gluon -> gluon
15677 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15679 C...Double precision and integer declarations.
15680 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15681 IMPLICIT INTEGER(I-N)
15682 INTEGER PYK,PYCHGE,PYCOMP
15684 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15685 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15686 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15687 COMMON/PYINT1/MINT(400),VINT(400)
15688 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15689 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15691 C...Default maximum weight.
15697 C...Select maximum weight by process.
15698 IF(MECOR.EQ.1) THEN
15701 ELSEIF(MECOR.EQ.2) THEN
15709 C*********************************************************************
15712 C...Calculates actual ME weight in some initial-state showers.
15713 C...Inparameter MECOR: kind of hard scattering process
15714 C... IFLCB: flavour combination of branching,
15715 C... 1 for fermion -> fermion,
15716 C... 2 for gluon/photon -> fermion
15717 C... 3 for fermion -> gluon/photon,
15718 C... 4 for gluon -> gluon
15719 C... Q2: Q2 value of shower branching
15720 C... Z: Z value of branching
15721 C...In+outparameter PHIBR: azimuthal angle of branching
15722 C...Outparameter WTME: actual ME weight
15724 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
15726 C...Double precision and integer declarations.
15727 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15728 IMPLICIT INTEGER(I-N)
15729 INTEGER PYK,PYCHGE,PYCOMP
15731 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15732 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15733 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15734 COMMON/PYINT1/MINT(400),VINT(400)
15735 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15736 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15738 C...Default output.
15741 C...Define kinematics of shower branching in Mandelstam variables.
15745 UH=Q2-SQM*(1D0-Z)/Z
15747 C...Matrix-element corrections for f + fbar -> s-channel vector boson.
15748 IF(MECOR.EQ.1) THEN
15749 IF(IFLCB.EQ.1) THEN
15750 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
15751 ELSEIF(IFLCB.EQ.2) THEN
15752 WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
15755 C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
15756 ELSEIF(MECOR.EQ.2) THEN
15757 IF(IFLCB.EQ.3) THEN
15758 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
15759 ELSEIF(IFLCB.EQ.4) THEN
15760 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
15763 C...Matrix-element corrections for q + qbar -> Higgs (h0)
15764 ELSEIF(MECOR.EQ.3) THEN
15765 IF(IFLCB.EQ.2) THEN
15766 WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
15767 1 (SH**2+2D0*SQM*(SQM-SH))
15774 C*********************************************************************
15777 C...Handles the generation of additional interactions in the new
15778 C...multiple interactions framework.
15779 C...MODE=-1 : Initalize MI from scratch.
15780 C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
15781 C... Sudakov for PT2, abort if below PT2CUT.
15782 C...MODE= 1 : Accept interaction at PT2NOW and store variables.
15783 C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
15784 C...PT2NOW : Starting (max) PT2 scale for evolution.
15785 C...PT2CUT : Lower limit for evolution.
15786 C...PT2 : Result of evolution. Generated PT2 for trial interaction.
15787 C...IFAIL : Status return code.
15788 C... = 0: All is well.
15789 C... < 0: Phase space exhausted, generation to be terminated.
15790 C... > 0: Additional interaction vetoed, but continue evolution.
15792 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
15793 C...Double precision and integer declarations.
15794 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15795 IMPLICIT INTEGER(I-N)
15796 INTEGER PYK,PYCHGE,PYCOMP
15797 C...Parameter statement for maximum size of showers.
15798 PARAMETER (MAXNUR=1000)
15800 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15801 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15802 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15803 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15804 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15805 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15806 COMMON/PYINT1/MINT(400),VINT(400)
15807 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15808 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15809 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15810 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15811 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
15812 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
15813 & XMI(2,240),PT2MI(240),IMISEP(0:240)
15814 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
15815 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
15816 COMMON/PYCTAG/NCT,MCT(4000,2)
15817 C...Local arrays and saved variables.
15818 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
15820 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
15821 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
15822 & /PYISMX/,/PYCTAG/
15826 C...Set MI subprocess = QCD 2 -> 2.
15829 C----------------------------------------------------------------------
15830 C...MODE=-1: Initialize from scratch
15831 IF (MODE.EQ.-1) THEN
15832 C...Initialize PT2 array.
15834 C...Initialize list of incoming beams and partons from two sides.
15841 IMI(JS,1,1)=MINT(84)+JS
15843 XMI(JS,1)=VINT(40+JS)
15844 C...Rescale x values to fractions of photon energy.
15845 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
15846 C...Hard reset: hard interaction initiators motherless by definition.
15847 K(MINT(84)+JS,3)=2+JS
15848 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
15849 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
15853 IF (MOD(MSTP(81),10).GE.1) THEN
15854 IF(MSTP(82).LE.1) THEN
15855 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
15857 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
15858 & VINT(317)/(VINT(318)*VINT(320))
15859 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
15861 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
15862 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
15865 C...Zero entries relating to scatterings beyond the first.
15871 IMISEP(MI)=IMISEP(1)
15876 C...Initialize factors for PDF reshaping.
15878 KFBEAM(JS)=MINT(10+JS)
15879 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
15880 KFABM=IABS(KFBEAM(JS))
15881 KFSBM=ISIGN(1,KFBEAM(JS))
15883 C...Zero flavour content of incoming beam particle.
15887 C... Flavour content of baryon.
15888 IF(KFABM.GT.1000) THEN
15889 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
15890 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
15891 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
15892 C... Flavour content of pi+-, K+-.
15893 ELSEIF(KFABM.EQ.211) THEN
15894 KFIVAL(JS,1)=KFSBM*2
15895 KFIVAL(JS,2)=-KFSBM
15896 ELSEIF(KFABM.EQ.321) THEN
15897 KFIVAL(JS,1)=-KFSBM*3
15898 KFIVAL(JS,2)=KFSBM*2
15899 C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
15902 C...Zero initial valence and companion content.
15907 C...Set up colour line tags starting from hard interaction initiators.
15909 C...Reset colour tag array and colour processing flags.
15910 DO 150 I=IMISEP(0)+1,N
15913 K(I,4)=MOD(K(I,4),MSTU(5)**2)
15914 K(I,5)=MOD(K(I,5),MSTU(5)**2)
15916 C... Consider each side in turn.
15921 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15923 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
15925 CALL PYCTTR(I1,KCS,I2)
15926 IF(MINT(51).NE.0) RETURN
15930 C...Range checking for companion quark pdf large-x param.
15931 IF (MSTP(87).LT.0) THEN
15932 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15935 ELSEIF (MSTP(87).GT.4) THEN
15936 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15941 C----------------------------------------------------------------------
15942 C...MODE=0: Generate trial interaction. Return codes:
15943 C...IFAIL < 0: Phase space exhausted, generation to be terminated.
15944 C...IFAIL = 0: Additional interaction generated at PT2.
15945 C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
15946 ELSEIF (MODE.EQ.0) THEN
15947 C...Abolute MI max scale = VINT(62)
15948 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
15949 180 IF(MSTP(82).LE.1) THEN
15950 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
15951 IF(XT2.LT.VINT(149)) IFAIL=-2
15953 IF(XT2.LE.0.01001D0*VINT(149)) THEN
15956 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
15957 & LOG(PYR(0)))-VINT(149)
15960 C...Also exit if below lower limit or if higher trial branching
15962 PT2=0.25D0*VINT(2)*XT2
15963 IF (PT2.LE.PT2CUT) IFAIL=-4
15964 IF (PT2.LE.PT2MX) IFAIL=-5
15965 IF (IFAIL.NE.0) THEN
15969 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
15970 VINT(25)=4D0*PT2/VINT(2)
15973 C...Choose tau and y*. Calculate cos(theta-hat).
15974 IF(PYR(0).LE.COEF(ISUB,1)) THEN
15975 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
15976 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
15978 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
15981 C...New: require shat > 1.
15982 IF(TAU*VINT(2).LT.1D0) GOTO 180
15986 IF(RYST.GT.COEF(ISUB,8)) MYST=2
15987 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
15988 CALL PYKMAP(2,MYST,PYR(0))
15989 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
15991 C...Check that x not used up. Accept or reject kinematical variables.
15992 X1M=SQRT(TAU)*EXP(VINT(22))
15993 X2M=SQRT(TAU)*EXP(-VINT(22))
15994 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
15995 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
15996 CALL PYSIGH(NCHN,SIGS)
15997 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
15998 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
15999 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
16001 C...Save if highest PT so far.
16002 IF (PT2.GT.PT2MX) THEN
16008 C----------------------------------------------------------------------
16009 C...MODE=1: Generate and save accepted scattering.
16010 ELSEIF (MODE.EQ.1) THEN
16012 C...Reset K, P, V, and MCT vectors.
16024 C...Choose flavour of reacting partons (and subprocess).
16026 IF (NTRY.GT.50) THEN
16027 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
16028 & //'interaction. Giving up!')
16036 ICONMI=ISIG(ICHN,3)
16037 RSIGS=RSIGS-SIGH(ICHN)
16038 IF(RSIGS.LE.0D0) GOTO 230
16041 C...Reassign to appropriate process codes.
16042 230 ISUBMI=ICONMI/10
16043 ICONMI=MOD(ICONMI,10)
16045 C...Choose new quark flavour for annihilation graphs
16046 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
16047 SH=VINT(21)*VINT(2)
16048 CALL PYWIDT(21,SH,WDTP,WDTE)
16049 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
16050 DO 250 I=1,MDCY(21,3)
16051 KFLF=KFDP(I+MDCY(21,2)-1,1)
16052 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
16053 IF(RKFL.LE.0D0) GOTO 260
16055 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
16056 IF(KFLF.GE.4) GOTO 240
16057 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
16060 ELSEIF(ISUBMI.EQ.53) THEN
16066 C...Final state flavours and colour flow: default values
16073 IF(ISUBMI.EQ.11) THEN
16074 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
16076 IF(KFL1*KFL2.LT.0) KCC=KCC+2
16078 ELSEIF(ISUBMI.EQ.12) THEN
16079 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
16080 KFL3=ISIGN(KFLF,KFL1)
16084 ELSEIF(ISUBMI.EQ.13) THEN
16085 C...f + fbar -> g + g; th arbitrary
16090 ELSEIF(ISUBMI.EQ.28) THEN
16091 C...f + g -> f + g; th = (p(f)-p(f))**2
16092 IF(KFL1.EQ.21) JS=2
16094 IF(KFL1.EQ.21) KCC=KCC+2
16095 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
16096 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
16098 ELSEIF(ISUBMI.EQ.53) THEN
16099 C...g + g -> f + fbar; th arbitrary
16100 KCS=(-1)**INT(1.5D0+PYR(0))
16101 KFL3=ISIGN(KFLF,KCS)
16105 ELSEIF(ISUBMI.EQ.68) THEN
16106 C...g + g -> g + g; th arbitrary
16108 KCS=(-1)**INT(1.5D0+PYR(0))
16111 C...Check that massive sea quarks have non-zero phase space for g -> Q Q
16112 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
16113 & .OR.IABS(KFL4).EQ.5) THEN
16114 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
16115 IF (PT2.LE.1.05*RMMAX2) THEN
16116 IF (NTRY.EQ.2) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
16117 & //' too close to threshold (2nd try).')
16122 C...Store flavours of scattering.
16130 C...Set flavours and mothers of scattering partons.
16139 K(N+1,3)=MINT(83)+1
16140 K(N+2,3)=MINT(83)+2
16144 C...Store colour connection indices.
16147 IF(KCS.EQ.-1) JC=3-J
16148 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
16149 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
16150 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
16151 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
16154 C...Store incoming and outgoing partons in their CM-frame.
16155 SHR=SQRT(VINT(21))*VINT(1)
16158 P(N+2,3)=-0.5D0*SHR
16160 P(N+3,5)=PYMASS(K(N+3,2))
16161 P(N+4,5)=PYMASS(K(N+4,2))
16162 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
16166 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
16167 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
16168 P(N+4,4)=SHR-P(N+3,4)
16171 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
16173 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
16175 C...Global statistics.
16176 MINT(351)=MINT(351)+1
16177 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
16178 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
16180 C...Keep track of loose colour ends and information on scattering.
16181 MINT(31)=MINT(31)+1
16183 PT2MI(MINT(36))=PT2
16184 IMISEP(MINT(31))=N+4
16186 IMI(JS,MINT(31),1)=N+JS
16187 IMI(JS,MINT(31),2)=0
16188 XMI(JS,MINT(31))=VINT(40+JS)
16190 C...Update cumulative counters
16191 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
16192 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
16195 C...Add to list of final state partons
16198 PTPART(NPART+1)=SQRT(PT2)
16199 PTPART(NPART+2)=SQRT(PT2)
16203 NISGEN(1,MINT(31))=0
16204 NISGEN(2,MINT(31))=0
16208 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
16209 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
16214 C...Finally, assign colour tags to new partons
16216 I1=IMI(JS,MINT(31),1)
16217 I2=IMI(3-JS,MINT(31),1)
16219 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
16221 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
16223 CALL PYCTTR(I1,KCS,I2)
16224 IF(MINT(51).NE.0) RETURN
16228 C----------------------------------------------------------------------
16229 C...MODE=2: Decide whether quarks in last scattering were valence,
16230 C...companion, or sea.
16231 ELSEIF (MODE.EQ.2) THEN
16235 KFSBM=ISIGN(1,MINT(10+JS))
16236 IFL=K(IMI(JS,MI,1),2)
16238 IF (IABS(IFL).GE.6) THEN
16239 IF (IABS(IFL).EQ.6) THEN
16240 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
16244 C...Get PDFs at X(rescaled) and PT2 of the current initiator.
16245 C...(Do not include the parton itself in the X rescaling.)
16247 XRSC=X/(VINT(142+JS)+X)
16248 C...Note: XPSVC = x*pdf.
16251 C.... Store side in MINT(124)
16254 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
16257 C...Ensure that pdfs are positive definite
16258 IF (SEA.LT.0D0) THEN
16259 CALL PYERRM(9,'(PYPTMI:) Sea distribution negative.')
16261 ELSEIF (VAL.LT.0D0) THEN
16262 CALL PYERRM(9,'(PYPTMI:) Val distribution negative.')
16266 DO 310 IVC=1,NVC(JS,IFL)
16267 CMP=CMP+XPSVC(IFL,IVC)
16271 C...Decide (Extra factor x cancels in the dvision).
16272 320 RVCS=PYR(0)*(SEA+VAL+CMP)
16275 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
16276 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
16278 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
16279 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
16280 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
16281 IF(KFIVAL(JS,1).EQ.0) THEN
16282 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
16283 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
16284 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
16285 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
16287 C...Count down valence remaining. Do not count current scattering.
16288 DO 340 I1=1,NMI(JS)
16289 IF (I1.EQ.MINT(36)) GOTO 340
16290 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
16294 IF(IVNOW.EQ.0) GOTO 330
16297 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
16298 IF(KFIVAL(JS,1).EQ.0) THEN
16299 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
16302 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
16304 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
16305 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
16309 ELSEIF (RVCS.LE.VAL+SEA) THEN
16310 C...If sea, add opposite sign companion parton. Store X and I.
16311 NVC(JS,-IFL)=NVC(JS,-IFL)+1
16312 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
16313 C...Set pointer to companion
16314 IMI(JS,MI,2)=-NVC(JS,-IFL)
16317 C...If companion, check whether we've got any in the books
16318 IF (NVC(JS,IFL).EQ.0) THEN
16320 C...Only report error first time for this event
16322 & CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
16323 C...Try a few times
16324 IF (NTRY.LE.10) THEN
16326 C... But if it stil fails, abort this event
16332 C...If several possibilities, decide which one
16336 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
16337 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
16338 C...Find original sea (anti-)quark. Do not consider current scattering.
16340 DO 360 I1=1,NMI(JS)
16341 IF (I1.EQ.MINT(36)) GOTO 360
16342 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
16343 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
16344 IMI(JS,MI,2)=IMI(JS,I1,1)
16345 IMI(JS,I1,2)=IMI(JS,MI,1)
16348 C...Mark companion "out-kicked".
16349 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
16356 C*********************************************************************
16358 C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
16359 C...Giving the x*f pdf of a companion quark, with its partner at XS,
16360 C...using an approximate gluon density like (1-X)^NPOW/X. The value
16361 C...corresponds to an unrescaled range between 0 and 1-X.
16363 FUNCTION PYFCMP(XC,XS,NPOW)
16365 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
16369 C...Parent gluon momentum fraction
16371 IF (Y.GE.1D0) RETURN
16372 C...Common factor (includes factor XC, since PYFCMP=x*f)
16373 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
16374 C...Store normalized companion x*f distribution.
16375 IF (NPOW.LE.0) THEN
16376 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
16377 ELSEIF (NPOW.EQ.1) THEN
16378 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
16379 ELSEIF (NPOW.EQ.2) THEN
16380 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
16381 & +3D0*XS*(1D0+XS)*LOG(XS)))
16382 ELSEIF (NPOW.EQ.3) THEN
16383 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
16384 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16385 ELSEIF (NPOW.GE.4) THEN
16386 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
16387 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
16392 C*********************************************************************
16394 C...PYPCMP: Auxiliary to PYPDFU.
16395 C...Giving the momentum integral of a companion quark, with its
16396 C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
16397 C...The value corresponds to an unrescaled range between 0 and 1-XS.
16399 FUNCTION PYPCMP(XS,NPOW)
16401 DOUBLE PRECISION XS, PYPCMP
16403 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
16405 ELSEIF (NPOW.LE.0) THEN
16406 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
16407 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
16408 ELSEIF (NPOW.EQ.1) THEN
16409 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
16410 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
16411 ELSEIF (NPOW.EQ.2) THEN
16412 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
16413 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
16414 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
16415 & -3D0*XS*LOG(XS)*(1+XS)))
16416 ELSEIF (NPOW.EQ.3) THEN
16417 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
16418 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
16419 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
16420 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16422 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
16423 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
16424 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
16425 & -6D0*XS*LOG(XS)*(1D0+XS)))
16430 C*********************************************************************
16433 C...Rearranges contents of the HEPEUP commonblock so that
16434 C...mothers precede daughters and daughters of a decay are
16435 C...listed consecutively.
16439 C...Double precision and integer declarations.
16440 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16441 IMPLICIT INTEGER(I-N)
16443 C...User process event common block.
16445 PARAMETER (MAXNUP=500)
16446 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
16447 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
16448 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
16449 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
16450 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
16454 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
16455 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
16456 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
16458 C...Check whether a rearrangement is required.
16461 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
16464 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
16468 C...Find the new order that particles should have.
16474 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
16479 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
16480 IF(NNEW.NE.NUP) THEN
16482 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
16486 C...Copy old info into temporary storage.
16490 MOTUPT(1,I)=MOTHUP(1,I)
16491 MOTUPT(2,I)=MOTHUP(2,I)
16492 ICOUPT(1,I)=ICOLUP(1,I)
16493 ICOUPT(2,I)=ICOLUP(2,I)
16497 VTIUPT(I)=VTIMUP(I)
16498 SPIUPT(I)=SPINUP(I)
16501 C...Copy info back into HEPEUP in right order.
16504 IDUP(I)=IDUPT(IOLD)
16505 ISTUP(I)=ISTUPT(IOLD)
16509 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
16510 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
16512 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
16514 MOTHUP(1,I)=MOTHUP(2,I)
16517 ICOLUP(1,I)=ICOUPT(1,IOLD)
16518 ICOLUP(2,I)=ICOUPT(2,IOLD)
16520 PUP(J,I)=PUPT(J,IOLD)
16522 VTIMUP(I)=VTIUPT(IOLD)
16523 SPINUP(I)=SPIUPT(IOLD)
16527 c...If incoming particles are massive recalculate to put them massless.
16528 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
16529 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
16530 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
16531 PUP(4,1)=0.5D0*PPLUS
16534 PUP(4,2)=0.5D0*PMINUS
16542 C*********************************************************************
16545 C...Administers the generation of successive final-state showers
16546 C...in external processes.
16548 SUBROUTINE PYADSH(NFIN)
16550 C...Double precision and integer declarations.
16551 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16552 IMPLICIT INTEGER(I-N)
16553 INTEGER PYK,PYCHGE,PYCOMP
16554 C...Parameter statement for maximum size of showers.
16555 PARAMETER (MAXNUR=1000)
16557 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16558 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16559 COMMON/PYCTAG/NCT,MCT(4000,2)
16560 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16561 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16562 COMMON/PYINT1/MINT(400),VINT(400)
16563 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
16565 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
16567 C...Set primary vertex.
16569 V(MINT(83)+5,J)=0D0
16570 V(MINT(83)+6,J)=0D0
16571 V(MINT(84)+1,J)=0D0
16572 V(MINT(84)+2,J)=0D0
16575 C...Isolate systems of particles with the same mother.
16578 DO 140 I=MINT(84)+3,NFIN
16580 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
16587 C...Set production vertices.
16588 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
16595 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
16598 IF(MSTP(125).GE.1) THEN
16606 C...End loop over systems. Return if no showers to be performed.
16607 IBEG(NSYS+1)=NFIN+1
16608 IF(MSTP(71).LE.0) RETURN
16610 C...Loop through systems of particles; check that sensible size.
16612 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
16613 IF(MINT(35).LE.2) THEN
16614 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
16616 ELSEIF(NSIZ.LE.1) THEN
16617 CALL PYERRM(2,'(PYADSH:) only one particle in system')
16619 ELSEIF(NSIZ.GT.80) THEN
16620 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
16625 C...Save status codes and daughters of showering particles; reset them.
16632 IF(K(I,1).GT.10) THEN
16634 IF(KSAV(II,1).EQ.14) K(I,1)=3
16636 IF(KSAV(II,1).LE.10) THEN
16637 ELSEIF(K(I,1).EQ.1) THEN
16643 KSAV(II,4)=MOD(K(I,4),MSTU(5))
16644 KSAV(II,5)=MOD(K(I,5),MSTU(5))
16645 K(I,4)=K(I,4)-KSAV(II,4)
16646 K(I,5)=K(I,5)-KSAV(II,5)
16649 PSUM(J)=PSUM(J)+P(I,J)
16653 C...Perform shower.
16654 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16656 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16658 IF(MINT(35).LE.2) THEN
16660 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16662 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16665 C...For external processes, first call, also ISR partons radiate.
16666 C...Can use existing PYPART list, removing partons that radiate later.
16667 ELSEIF(ISYS.EQ.1) THEN
16670 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16672 IPART(NPARTN)=IPART(II)
16673 PTPART(NPARTN)=PTPART(II)
16677 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16679 C...For subsequent calls use the systems excluded above.
16685 PTPART(II)=0.5D0*QMAX
16687 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16690 C...Look up showered copies of original showering particles.
16694 C...Particles without daughters need not be studied.
16695 IF(KSAV(II,1).LE.10) GOTO 260
16696 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16697 ELSEIF(K(I,1).EQ.11) THEN
16698 190 IMV=MOD(K(IMV,4),MSTU(5))
16699 IF(K(IMV,1).EQ.11) GOTO 190
16701 KDA1=MOD(K(I,4),MSTU(5))
16703 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16705 KDA2=MOD(K(I,5),MSTU(5))
16707 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16710 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
16713 KDA1=MOD(K(I3,4),MSTU(5))
16715 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16717 KDA2=MOD(K(I3,5),MSTU(5))
16719 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16725 C...Restore daughter info of original partons to showered copies.
16726 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
16727 IF(KSAV(II,1).LE.10) THEN
16728 ELSEIF(K(I,1).EQ.1) THEN
16729 K(IMV,4)=KSAV(II,4)
16730 K(IMV,5)=KSAV(II,5)
16732 K(IMV,4)=K(IMV,4)+KSAV(II,4)
16733 K(IMV,5)=K(IMV,5)+KSAV(II,5)
16736 C...Reset mother info of existing daughters to showered copies.
16737 DO 210 I3=IBEG(ISYS+1),NFIN
16738 IF(K(I3,3).EQ.I) K(I3,3)=IMV
16739 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
16740 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
16741 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
16745 C...Boost all original daughters to new frame of showered copy.
16746 C...Also update their colour tags.
16749 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
16751 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
16753 BETA(J)=FAC*BETA(J)
16755 DO 250 I3=IBEG(ISYS+1),NFIN
16758 IF(MSTP(128).LE.0) THEN
16759 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
16760 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
16762 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16763 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16764 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16767 IF(IMO.EQ.IMV) THEN
16768 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16769 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16770 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16771 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
16779 C...End of loop over showering systems
16785 C*********************************************************************
16788 C...Interface to UPVETO, which allows user to veto event generation
16789 C...on the parton level, after parton showers but before multiple
16790 C...interactions, beam remnants and hadronization is added.
16792 SUBROUTINE PYVETO(IVETO)
16794 C...All real arithmetic in double precision.
16795 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16796 C...Three Pythia functions return integers, so need declaring.
16797 INTEGER PYK,PYCHGE,PYCOMP
16799 C...PYTHIA commonblocks.
16800 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16801 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16802 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16803 COMMON/PYINT1/MINT(400),VINT(400)
16804 SAVE /PYJETS/,/PYPARS/,/PYINT1/
16805 C...HEPEVT commonblock.
16806 PARAMETER (NMXHEP=4000)
16807 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16808 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
16809 DOUBLE PRECISION PHEP,VHEP
16812 DIMENSION IRESO(100)
16814 C...Define longitudinal boost from initiator rest frame to cm frame.
16815 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
16816 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
16818 C...Presentation is different if using pT-ordered shower
16819 IF(MINT(35).EQ.3) THEN
16824 C... Reset counters.
16829 C...Oth pass: identify beam and incoming partons
16830 DO 140 I=MINT(83)+1,MINT(83)+6
16832 IF(K(I,2).EQ.94) THEN
16841 C...First pass: identify final locations of resonances
16842 C...and of their daughters before showering.
16843 DO 150 I=MINT(84)+3,N
16847 C...Skip shower CM frame documentation lines.
16848 IF(K(I,2).EQ.94) THEN
16850 C... Store a new intermediate product, when mother in documentation.
16851 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
16852 & K(I,3).LE.MINT(84)) THEN
16858 IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
16860 C... Store a new intermediate product, when mother in main section.
16861 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
16862 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
16868 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
16871 IF(ISTORE.EQ.1) THEN
16872 C...Copy parton info, boosting momenta along z axis to cm frame.
16877 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16878 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16880 C...Store one mother. Rest of history and vertex info zeroed.
16892 C...Second pass: identify current set of "final" partons.
16893 DO 200 I=MINT(84)+3,N
16897 C...Store a final parton.
16898 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
16902 C..Trace it back through shower, to check if from documented particle.
16906 IF(IHIST.GT.MINT(84)) THEN
16907 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
16909 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
16913 IF(IMOTH.EQ.0) GOTO 160
16914 IMOTH=MAX(0,IMOTH-6)
16915 ELSEIF(IHIST.LE.4) THEN
16916 IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
16925 IF(ISTORE.EQ.1) THEN
16926 C...Copy parton info, boosting momenta along z axis to cm frame.
16931 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16932 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16934 C...Store one mother. Rest of history and vertex info zeroed.
16945 C...Call user-written routine to decide whether to keep events.
16949 C*********************************************************************
16952 C...Allows resonances to decay (including parton showers for hadronic
16955 SUBROUTINE PYRESD(IRES)
16957 C...Double precision and integer declarations.
16958 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16959 IMPLICIT INTEGER(I-N)
16960 INTEGER PYK,PYCHGE,PYCOMP
16961 C...Parameter statement to help give large particle numbers.
16962 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16963 &KEXCIT=4000000,KDIMEN=5000000)
16964 C...Parameter statement for maximum size of showers.
16965 PARAMETER (MAXNUR=1000)
16967 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16968 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16969 COMMON/PYCTAG/NCT,MCT(4000,2)
16970 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16971 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16972 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16973 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16974 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16975 COMMON/PYINT1/MINT(400),VINT(400)
16976 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16977 COMMON/PYINT4/MWID(500),WIDS(500,5)
16978 COMMON/PYPUED/IUED(0:99),RUED(0:99)
16979 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
16980 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/
16981 C...Local arrays and complex and character variables.
16982 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
16983 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
16984 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
16985 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
16986 &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(3),ITRI(3),IOCT(3)
16987 COMPLEX FGK,HA(6,6),HC(6,6)
16989 CHARACTER CODE*9,MASS*9
16991 C...The F, Xi and Xj functions of Gunion and Kunszt
16992 C...(Phys. Rev. D33, 665, plus errata from the authors).
16993 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
16994 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
16995 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
16996 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
16997 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
16998 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
16999 &2D0*(D34/D56+D56/D34))
17001 C...Some general constants.
17004 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
17008 GMMZ=PMAS(23,1)*PMAS(23,2)
17010 GMMW=PMAS(24,1)*PMAS(24,2)
17013 C...Boost and rotate to rest frame of incoming partons,
17014 C...to get proper amount of smearing of decay angles.
17020 C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons
17021 C...(101,102) are off shell and can have inconsistent momenta, resulting
17022 C...in boosts larger than unity. However, the corresponding docu partons
17023 C...(5,6) are kept on shell, and have consistent momenta that can be used
17024 C...to derive this boost instead. Ultimately, should change the way the new
17025 C...shower stores intermediate partons, but just using partons (5,6) for now
17026 C...does define the boost and furnishes a quick and much needed solution.
17027 IF (MINT(35).EQ.3) THEN
17031 ETOTIN=P(IIN1,4)+P(IIN2,4)
17032 BEXIN=(P(IIN1,1)+P(IIN2,1))/ETOTIN
17033 BEYIN=(P(IIN1,2)+P(IIN2,2))/ETOTIN
17034 BEZIN=(P(IIN1,3)+P(IIN2,3))/ETOTIN
17035 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
17036 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
17037 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
17038 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
17039 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
17042 C...Reset original resonance configuration.
17047 C...Define initial one, two or three objects for subprocess.
17051 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
17052 IREF(1,1)=MINT(84)+2+ISET(ISUB)
17053 IREF(1,4)=MINT(83)+6+ISET(ISUB)
17055 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
17056 IREF(1,1)=MINT(84)+1+ISET(ISUB)
17057 IREF(1,2)=MINT(84)+2+ISET(ISUB)
17058 IREF(1,4)=MINT(83)+5+ISET(ISUB)
17059 IREF(1,5)=MINT(83)+6+ISET(ISUB)
17061 ELSEIF(ISET(ISUB).EQ.5) THEN
17062 IREF(1,1)=MINT(84)+3
17063 IREF(1,2)=MINT(84)+4
17064 IREF(1,3)=MINT(84)+5
17065 IREF(1,4)=MINT(83)+7
17066 IREF(1,5)=MINT(83)+8
17067 IREF(1,6)=MINT(83)+9
17071 C...Define original resonance for odd cases.
17074 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
17076 IF(IHDEC.EQ.1) ISUB=3
17078 IREF(1,4)=K(IRES,3)
17080 IF(IREF(1,4).GT.MINT(84)) THEN
17081 110 ITMPMO=IREF(1,4)
17082 IF(K(ITMPMO,2).EQ.94) THEN
17083 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
17084 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
17085 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
17087 C...Explicitly check that reference particle exists, otherwise stop recursion
17088 IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
17089 IREF(1,4)=K(ITMPMO,3)
17094 IF(IREF(1,4).GT.MINT(84)) THEN
17097 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
17098 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
17101 EMATCH=ABS(P(II,4)-P(IREF14,4))
17108 C...Check if initial resonance has been moved (in resonance + jet).
17110 IF(IREF(1,JT).GT.0) THEN
17111 IF(K(IREF(1,JT),1).GT.10) THEN
17112 KFA=IABS(K(IREF(1,JT),2))
17113 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
17114 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17115 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17116 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17117 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17119 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17120 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17122 DO 130 I=IREF(1,JT)+1,N
17123 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
17126 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17127 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17128 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17129 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17131 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17132 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17137 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
17138 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
17144 C...Set decay vertex for initial resonances
17147 V(IREF(1,JT),I)=0D0
17151 C...Loop over decay history.
17157 IF(IREF(IP,2).EQ.0) JTMAX=1
17158 IF(IREF(IP,3).NE.0) JTMAX=3
17162 C...Check for Higgs which appears as decay product of user-process.
17165 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17167 IF(IHDEC.EQ.1) ISUB=3
17170 C...Start treatment of one, two or three resonances in parallel.
17182 C...Check whether particle can/is allowed to decay.
17183 IF(ID.EQ.0) GOTO 330
17186 IF(MWID(KCA).EQ.0) GOTO 330
17187 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
17188 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
17189 & KFA.EQ.18) IT4=IT4+1
17190 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
17191 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
17193 C...Choose lifetime and determine decay vertex.
17194 IF(K(ID,1).EQ.5) THEN
17196 ELSEIF(K(ID,1).NE.4) THEN
17197 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
17200 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
17203 C...Determine whether decay allowed or not.
17205 IF(MSTJ(22).EQ.2) THEN
17206 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
17207 ELSEIF(MSTJ(22).EQ.3) THEN
17208 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
17209 ELSEIF(MSTJ(22).EQ.4) THEN
17210 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
17211 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
17213 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
17218 C...Info for selection of decay channel: sign, pairings.
17219 IF(KCHG(KCA,3).EQ.0) THEN
17222 IPM=(5-ISIGN(1,K(ID,2)))/2
17225 IF(JTMAX.EQ.2) THEN
17226 KFB=IABS(K(IREF(IP,3-JT),2))
17227 ELSEIF(JTMAX.EQ.3) THEN
17229 KFB=IABS(K(IREF(IP,JT2),2))
17230 IF(KFB.NE.KFA) THEN
17231 JT2=JT+2-3*((JT+1)/3)
17232 KFB=IABS(K(IREF(IP,JT2),2))
17236 C...Select decay channel.
17237 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
17238 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
17239 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
17240 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
17241 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
17242 IF(WDTE0S.LE.0D0) GOTO 330
17246 IDC=IDL+MDCY(KCA,2)-1
17247 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
17248 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
17249 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
17251 C...Read out flavours and colour charges of decay channel chosen.
17252 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
17253 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
17254 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
17255 KFC1A=PYCOMP(IABS(KFL1(JT)))
17256 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
17257 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
17258 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
17259 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
17260 KFC2A=PYCOMP(IABS(KFL2(JT)))
17261 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
17262 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
17263 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
17264 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
17266 IF(KFL3(JT).NE.0) THEN
17267 KFC3A=PYCOMP(IABS(KFL3(JT)))
17268 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
17269 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
17270 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
17273 C...Set/save further info on channel.
17275 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
17277 HGZ(JT,1)=VINT(111)
17278 HGZ(JT,2)=VINT(112)
17279 HGZ(JT,3)=VINT(114)
17282 C...Select masses; to begin with assume resonances narrow.
17287 KFLW=IABS(KFL1(JT))
17289 ELSEIF(I.EQ.2) THEN
17290 KFLW=IABS(KFL2(JT))
17292 ELSEIF(I.EQ.3) THEN
17293 IF(KFL3(JT).EQ.0) GOTO 220
17294 KFLW=IABS(KFL3(JT))
17297 P(N+I,5)=PMAS(KCW,1)
17299 C...This prevents SUSY/t particles from becoming too light.
17300 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
17301 PMMN(I)=PMAS(KCW,1)
17302 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
17303 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
17304 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
17305 & PMAS(PYCOMP(KFDP(IDC,2)),1)
17306 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
17307 & PMAS(PYCOMP(KFDP(IDC,3)),1)
17308 PMMN(I)=MIN(PMMN(I),PMSUM)
17312 ELSEIF(KFLW.EQ.6) THEN
17313 PMMN(I)=PMAS(24,1)+PMAS(5,1)
17315 C...UED: select a graviton mass from continuous distribution
17316 C...(stored in PMAS(39,1) so no value returned)
17317 IF (IUED(1).EQ.1.AND.IUED(2).EQ.1.AND.KFLW.EQ.39)
17321 C...Check which two out of three are widest.
17324 PWID1=PMAS(KFC1A,2)
17325 PWID2=PMAS(KFC2A,2)
17326 KFLW1=IABS(KFL1(JT))
17327 KFLW2=IABS(KFL2(JT))
17328 IF(KFL3(JT).NE.0) THEN
17329 PWID3=PMAS(KFC3A,2)
17330 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
17333 KFLW1=IABS(KFL3(JT))
17334 ELSEIF(PWID3.GT.PWID2) THEN
17337 KFLW2=IABS(KFL3(JT))
17341 C...If all narrow then only check that masses consistent.
17342 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
17343 & PWID2.LT.PARP(41))) THEN
17345 C....Handle near degeneracy cases.
17346 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
17347 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17348 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
17349 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
17353 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17354 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
17357 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
17358 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
17363 C...For three wide resonances select narrower of three
17364 C...according to BW decoupled from rest.
17367 IF(KFL3(JT).NE.0) THEN
17368 IWID3=6-IWID1-IWID2
17369 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
17373 P(N+IWID3,5)=PYMASS(KFLW3)
17374 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
17375 PMTOT=PMTOT-P(N+IWID3,5)
17377 C...Select other two correlated within remaining phase space.
17381 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
17382 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
17383 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17388 CKIN(49)=PMMN(IWID1)
17389 CKIN(50)=PMMN(IWID2)
17390 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17395 IF(MINT(51).EQ.1) GOTO 720
17398 C...Begin fill decay products, with colour flow for coloured objects.
17403 C...Three-body decays
17404 IF(KFL3(JT).NE.0) THEN
17421 C...Generate kinematics (default is flat)
17424 C...Set generic colour flows whenever unambiguous,
17425 C...(independently of the order of the decay products)
17426 C...Sum up total colour content
17435 IF (KCQ(J).EQ.-1) THEN
17438 ELSEIF (KCQ(J).EQ.1) THEN
17441 ELSEIF (KCQ(J).EQ.2) THEN
17447 C...Set color flow for generic 1 -> N processes (N arbitrary)
17448 IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
17449 C...All singlets: do nothing
17451 ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
17452 C...Two octets, zero triplets, n singlets:
17453 IF (KCQ(0).EQ.2) THEN
17455 K(ID,4)=K(ID,4)+IOCT(2)
17456 K(ID,5)=K(ID,5)+IOCT(2)
17458 K(IOCT(2),4)=MSTU(5)*ID
17459 K(IOCT(2),5)=MSTU(5)*ID
17460 MCT(IOCT(2),1)=MCT(ID,1)
17461 MCT(IOCT(2),2)=MCT(ID,2)
17463 C...1 -> 8 + 8 + n(1)
17465 K(IOCT(1),4)=MSTU(5)*IOCT(2)
17466 K(IOCT(1),5)=MSTU(5)*IOCT(2)
17468 K(IOCT(2),4)=MSTU(5)*IOCT(1)
17469 K(IOCT(2),5)=MSTU(5)*IOCT(1)
17478 ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
17479 C...Two triplets, zero octets, n singlets.
17480 IF (KCQ(0).EQ.1) THEN
17482 K(ID,4)=K(ID,4)+ITRI(2)
17484 K(ITRI(2),4)=MSTU(5)*ID
17485 MCT(ITRI(2),1)=MCT(ID,1)
17486 ELSEIF (KCQ(0).EQ.-1) THEN
17487 C...3bar -> 3bar + n(1)
17488 K(ID,5)=K(ID,5)+IANT(2)
17490 K(IANT(2),5)=MSTU(5)*ID
17491 MCT(IANT(2),2)=MCT(ID,2)
17493 C...1 -> 3 + 3bar + n(1)
17495 K(ITRI(1),4)=MSTU(5)*IANT(1)
17497 K(IANT(1),5)=MSTU(5)*ITRI(1)
17503 ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
17504 C...Two triplets, one octet, n singlets.
17505 IF (KCQ(0).EQ.2) THEN
17506 C...8 -> 3 + 3bar + n(1)
17507 K(ID,4)=K(ID,4)+ITRI(1)
17508 K(ID,5)=K(ID,5)+IANT(1)
17510 K(ITRI(1),4)=MSTU(5)*ID
17512 K(IANT(1),5)=MSTU(5)*ID
17513 MCT(ITRI(1),1)=MCT(ID,1)
17514 MCT(IANT(1),2)=MCT(ID,2)
17515 ELSEIF (KCQ(0).EQ.1) THEN
17516 C...3 -> 8 + 3 + n(1)
17517 K(ID,4)=K(ID,4)+IOCT(1)
17519 K(IOCT(1),4)=MSTU(5)*ID
17520 K(IOCT(1),5)=MSTU(5)*ITRI(2)
17522 K(ITRI(2),4)=MSTU(5)*IOCT(1)
17523 MCT(IOCT(1),1)=MCT(ID,1)
17527 ELSEIF (KCQ(0).EQ.-1) THEN
17528 C...3bar -> 8 + 3bar + n(1)
17529 K(ID,5)=K(ID,5)+IOCT(1)
17531 K(IOCT(1),5)=MSTU(5)*ID
17532 K(IOCT(1),4)=MSTU(5)*IANT(2)
17534 K(IANT(2),5)=MSTU(5)*IOCT(1)
17535 MCT(IOCT(1),2)=MCT(ID,2)
17540 C...1 -> 3 + 3bar + 8 + n(1)
17542 K(ITRI(1),4)=MSTU(5)*IOCT(1)
17544 K(IOCT(1),5)=MSTU(5)*ITRI(1)
17545 K(IOCT(1),4)=MSTU(5)*IANT(1)
17547 K(IANT(1),5)=MSTU(5)*IOCT(1)
17555 CPS-- End of generic cases
17556 C...(could three octets also be handled?)
17557 C...(could (some of) the RPV cases be made generic as well?)
17559 C...Special cases (= old treatment)
17560 C...Set colour flow for t -> W + b + Z.
17561 ELSEIF(KFA.EQ.6) THEN
17564 IF(KCQM(JT).EQ.-1) ISID=5
17566 K(ID,ISID)=K(ID,ISID)+IDAU
17567 K(IDAU,ISID)=MSTU(5)*ID
17569 C...Set colour flow in three-body decays - programmed as special cases.
17571 ELSEIF(KFC2A.LE.6) THEN
17575 IF(KFL2(JT).LT.0) ISID=5
17576 K(N+2,ISID)=MSTU(5)*(N+3)
17577 K(N+3,9-ISID)=MSTU(5)*(N+2)
17578 C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
17579 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
17580 & .AND.KFL3(JT).NE.0) THEN
17581 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
17582 C...3-body decays of squarks to colour singlets plus one quark
17583 IF (KQSUMA.EQ.1) THEN
17586 IF (KCQ1(JT).NE.0) IQ=1
17587 IF (KCQ2(JT).NE.0) IQ=2
17588 IF (KCQ3(JT).NE.0) IQ=3
17590 IF (K(N+IQ,2).LT.0) ISID=5
17592 K(ID,ISID)=K(ID,ISID)+(N+IQ)
17593 K(N+IQ,ISID)=MSTU(5)*ID
17596 ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
17601 IF(KFL2(JT).LT.0) ISID=5
17602 K(N+1,ISID)=MSTU(5)*(N+2)
17603 K(N+1,9-ISID)=MSTU(5)*(N+3)
17604 K(N+2,ISID)=MSTU(5)*(N+1)
17605 K(N+3,9-ISID)=MSTU(5)*(N+1)
17606 ELSEIF(KFA.EQ.KSUSY1+21) THEN
17610 IF(KFL2(JT).LT.0) ISID=5
17611 K(ID,ISID)=K(ID,ISID)+(N+2)
17612 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
17613 K(N+2,ISID)=MSTU(5)*ID
17614 K(N+3,9-ISID)=MSTU(5)*ID
17617 ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
17618 & IABS(KCQ2(JT)).EQ.1) THEN
17622 IF(KFL2(JT).LT.0) ISID=5
17623 K(N+2,ISID)=MSTU(5)*(N+3)
17624 K(N+3,9-ISID)=MSTU(5)*(N+2)
17629 C...Set colour flow in three-body decays with baryon number violation.
17630 C...Neutralino and chargino decays first.
17631 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
17632 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
17633 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
17634 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17635 C...Insert junction to keep track of colours.
17636 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17637 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17638 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17639 C...Set special junction codes:
17643 C...Order decay products by invariant mass. (will be used in PYSTRF).
17644 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)-
17645 & P(N+1,3)*P(N+2,3)
17646 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)-
17647 & P(N+1,3)*P(N+3,3)
17648 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)-
17649 & P(N+2,3)*P(N+3,3)
17650 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
17651 K(N+4,4)=N+3+K(N+4,4)
17652 K(N+4,5)=N+1+MSTU(5)*(N+2)
17653 ELSEIF(PM13.LT.PM23) THEN
17654 K(N+4,4)=N+2+K(N+4,4)
17655 K(N+4,5)=N+1+MSTU(5)*(N+3)
17657 K(N+4,4)=N+1+K(N+4,4)
17658 K(N+4,5)=N+2+MSTU(5)*(N+3)
17664 C...Connect daughters to junction.
17668 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
17670 C...Particle counter should be stepped up one extra for junction.
17674 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
17675 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
17676 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17677 C...Insert junction to keep track of colours.
17678 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17679 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17680 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17691 C...Start by connecting all daughters to junction.
17692 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
17693 C...Only consider colour topologies with off shell resonances.
17694 RMQ1=PMAS(PYCOMP(K(II,2)),1)
17695 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
17696 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
17697 IF (RMGLU-RMQ1.LT.RMRES) THEN
17698 C...Calculate propagators for each colour topology.
17699 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
17700 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
17701 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
17705 CTMSUM=CTMSUM+CTM2(II-N)
17707 CTMSUM=PYR(0)*CTMSUM
17708 C...Select colour topology J, with most off shell least likely.
17711 CTMSUM=CTMSUM-CTM2(J)
17712 IF (CTMSUM.GT.0D0) GOTO 300
17713 C...The lucky winner gets its colour (anti-colour) directly from gluino.
17714 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
17715 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
17716 C...The other gluino colour is connected to junction
17717 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
17719 K(N+4,4)=K(N+4,4)+ID
17720 C...Lastly, connect junction to remaining daughters.
17721 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
17722 C...Particle counter should be stepped up one extra for junction.
17726 C...Update particle counter.
17729 C...2) Everything else two-body decay.
17731 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
17736 C...First set colour flow as if mother colour singlet.
17737 IF(KCQ1(JT).NE.0) THEN
17739 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
17740 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
17742 IF(KCQ2(JT).NE.0) THEN
17744 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
17745 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
17747 C...Then redirect colour flow if mother (anti)triplet.
17748 IF(KCQM(JT).EQ.0) THEN
17749 ELSEIF(KCQM(JT).NE.2) THEN
17751 IF(KCQM(JT).EQ.-1) ISID=5
17753 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
17754 K(ID,ISID)=K(ID,ISID)+IDAU
17755 K(IDAU,ISID)=MSTU(5)*ID
17756 C...Then redirect colour flow if mother octet.
17757 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
17759 IF(KCQ1(JT).EQ.0) IDAU=N
17760 K(ID,4)=K(ID,4)+IDAU
17761 K(ID,5)=K(ID,5)+IDAU
17762 K(IDAU,4)=MSTU(5)*ID
17763 K(IDAU,5)=MSTU(5)*ID
17766 IF(KCQ1(JT).EQ.-1) ISID=5
17767 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
17768 K(ID,ISID)=K(ID,ISID)+(N-1)
17769 K(ID,9-ISID)=K(ID,9-ISID)+N
17770 K(N-1,ISID)=MSTU(5)*ID
17771 K(N,9-ISID)=MSTU(5)*ID
17774 C...Insert junction
17775 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
17777 C...~q* mother: type 3 junction. ~q mother: type 4.
17778 ITJUNC(JT)=(7+KCQM(JT))/2
17779 C...Specify junction KF and set colour flow from junction
17783 C...Junction type encoded together with mother:
17784 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
17785 K(N,5)=N-1+MSTU(5)*(N-2)
17786 C...Zero P and V for junction (V filled later)
17791 C...Set colour flow from mother to junction
17792 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
17793 C...Set colour flow from daughters to junction
17797 C...(Anti-)colour mother is junction.
17798 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
17803 C...End loop over resonances for daughter flavour and mass selection.
17805 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
17807 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
17808 & KFL1(JT).EQ.0) THEN
17809 WRITE(CODE,'(I9)') K(ID,2)
17810 WRITE(MASS,'(F9.3)') P(ID,5)
17811 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
17812 & CODE//' with mass'//MASS)
17818 C...Check for allowed combinations. Skip if no decays.
17819 IF(JTMAX.EQ.1) THEN
17820 IF(KDCY(1).EQ.0) GOTO 710
17821 ELSEIF(JTMAX.EQ.2) THEN
17822 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
17823 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17824 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17825 ELSEIF(JTMAX.EQ.3) THEN
17826 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
17827 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17828 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17829 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17830 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17831 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17832 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17835 C...Special case: matrix element option for Z0 decay to quarks.
17836 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
17837 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
17839 C...Check consistency of MSTJ options set.
17840 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
17842 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
17845 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
17847 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
17852 C...Select alpha_strong behaviour.
17855 MSTU(111)=MSTJ(108)
17856 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
17858 PARU(112)=PARJ(121)
17859 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
17861 C...Find axial fraction in total cross section for scalar gluon model.
17863 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
17864 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
17865 POLL=1D0-PARJ(131)*PARJ(132)
17866 SFF=1D0/(16D0*XW*XW1)
17867 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
17868 & (PARJ(123)*PARJ(124))**2)
17869 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
17871 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
17872 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
17873 & (PARJ(132)-PARJ(131)))
17876 QF=KCHG(KFLC,1)/3D0
17878 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
17879 & 1D0-(2D0*PMQ/P(ID,5))**2))
17880 VF=SIGN(1D0,QF)-4D0*QF*XW
17881 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
17882 & VF**2*HF1W)+VQ**3*HF1W
17883 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
17886 C...Choice of jet configuration.
17887 CALL PYXJET(P(ID,5),NJET,CUT)
17891 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
17892 ELSEIF(NJET.EQ.3) THEN
17893 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
17898 C...Fill jet configuration; return if incorrect kinematics.
17900 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
17901 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
17902 ELSEIF(NJET.EQ.2) THEN
17903 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
17904 ELSEIF(NJET.EQ.3) THEN
17905 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
17906 ELSEIF(KFLN.EQ.21) THEN
17907 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17910 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17913 IF(MSTU(24).NE.0) THEN
17920 C...Angular orientation according to matrix element.
17921 IF(MSTJ(106).EQ.1) THEN
17922 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
17923 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
17925 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
17926 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
17929 C...Boost partons to Z0 rest frame.
17930 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
17931 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17933 C...Mark decayed resonance and add documentation lines,
17935 IDOC=MINT(83)+MINT(4)
17937 I1=MINT(83)+MINT(4)+1
17939 IF(MSTP(128).GE.1) K(I,3)=ID
17940 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
17951 C...Generate parton shower.
17952 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
17953 CALL PYSHOW(N-1,N,P(ID,5))
17954 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
17958 PTPART(1)=0.5D0*P(ID,5)
17959 PTPART(2)=PTPART(1)
17961 IF(K(N-1,2).GT.0) THEN
17968 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
17971 C... End special case for Z0: skip ahead.
17977 C...Order incoming partons and outgoing resonances.
17978 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
17981 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
17982 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
17983 & ILIN(1)=2*MINT(84)+3-ILIN(1)
17984 ILIN(2)=2*MINT(84)+3-ILIN(1)
17986 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17990 IF(K(IREF(IP,1),2).EQ.23) IORD=2
17991 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
17992 IAKIPD=IABS(K(IREF(IP,IORD),2))
17993 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
17994 IF(KDCY(IORD).EQ.0) IORD=3-IORD
17996 C...Order decay products of resonances.
17997 DO 370 JT=IORD,3-IORD,3-2*IORD
17998 IF(KDCY(JT).EQ.0) THEN
17999 ILIN(IMAX+1)=NSD(JT)
18001 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
18002 ILIN(IMAX+1)=N+2*JT-1
18003 ILIN(IMAX+2)=N+2*JT
18005 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18006 K(N+2*JT,2)=K(NSD(JT)+2,2)
18008 ILIN(IMAX+1)=N+2*JT
18010 ILIN(IMAX+2)=N+2*JT-1
18012 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18013 K(N+2*JT,2)=K(NSD(JT)+2,2)
18017 C...Find charge, isospin, left- and righthanded couplings.
18022 KFA=IABS(K(ILIN(I),2))
18023 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
18024 COUP(I,1)=KCHG(KFA,1)/3D0
18025 COUP(I,2)=(-1)**MOD(KFA,2)
18026 COUP(I,4)=-2D0*COUP(I,1)*XWV
18027 COUP(I,3)=COUP(I,2)+COUP(I,4)
18030 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
18031 IF(ISUB.EQ.22) THEN
18034 IF(I.EQ.5) I1=3-IORD
18037 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
18038 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
18039 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
18044 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18045 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
18046 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
18047 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
18049 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
18053 C...Select angular orientation type - Z'/W' only.
18055 IF(ISUB.EQ.141) THEN
18056 IF(PYR(0).LT.PARU(130)) MZPWP=1
18058 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
18059 IAKIR=IABS(K(IREF(2,2),2))
18060 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18061 IF(IAKIR.LE.20) MZPWP=2
18063 IF(IP.GE.3) MZPWP=2
18064 ELSEIF(ISUB.EQ.142) THEN
18065 IF(PYR(0).LT.PARU(136)) MZPWP=1
18067 IAKIR=IABS(K(IREF(2,2),2))
18068 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18069 IF(IAKIR.LE.20) MZPWP=2
18071 IF(IP.GE.3) MZPWP=2
18074 C...Select random angles (begin of weighting procedure).
18075 430 DO 440 JT=1,JTMAX
18076 IF(KDCY(JT).EQ.0) GOTO 440
18077 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
18078 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
18079 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
18082 CTHE(JT)=2D0*PYR(0)-1D0
18083 PHI(JT)=PARU(2)*PYR(0)
18087 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
18088 C...Construct massless four-vectors.
18097 IF(KDCY(JT).EQ.0) GOTO 470
18099 P(N+2*JT-1,3)=0.5D0*P(ID,5)
18100 P(N+2*JT-1,4)=0.5D0*P(ID,5)
18101 P(N+2*JT,3)=-0.5D0*P(ID,5)
18102 P(N+2*JT,4)=0.5D0*P(ID,5)
18103 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
18104 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
18107 C...Store incoming and outgoing momenta, with random rotation to
18108 C...avoid accidental zeroes in HA expressions.
18112 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
18113 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
18114 P(N+4+I,5)=P(ILIN(I),5)
18116 P(N+4+I,J)=P(ILIN(I),J)
18119 500 THERR=ACOS(2D0*PYR(0)-1D0)
18120 PHIRR=PARU(2)*PYR(0)
18121 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
18123 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
18124 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
18131 C...Calculate internal products.
18132 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
18133 & ISUB.EQ.142) THEN
18134 DO 540 I1=IMIN,IMAX-1
18135 DO 530 I2=I1+1,IMAX
18136 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
18137 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
18138 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
18139 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
18140 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
18141 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
18142 HC(I1,I2)=CONJG(HA(I1,I2))
18143 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
18144 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
18145 HA(I2,I1)=-HA(I1,I2)
18146 HC(I2,I1)=-HC(I1,I2)
18151 C...Calculate four-products.
18158 DO 580 I1=IMIN,IMAX-1
18159 DO 570 I2=I1+1,IMAX
18160 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
18161 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
18162 PKK(I2,I1)=PKK(I1,I2)
18168 KFAGM=IABS(IREF(IP,7))
18169 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
18170 C...Isotropic decay selected by user.
18174 ELSEIF(JTMAX.EQ.3) THEN
18175 C...Isotropic decay when three mother particles.
18179 ELSEIF(IT4.GE.1) THEN
18180 C... Isotropic decay t -> b + W etc for 4th generation q and l.
18184 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
18185 & IREF(IP,7).EQ.36) THEN
18186 C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
18187 C...CP-odd case added by Kari Ertresvag Myklevoll.
18188 C...Now also with mixed Higgs CP-states
18190 IF(IP.EQ.1) WTMAX=SH**2
18191 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
18192 KFA=IABS(K(IREF(IP,1),2))
18193 KFT=IABS(K(IREF(IP,2),2))
18195 IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
18196 & MSTP(25).GE.3) THEN
18197 C...For mixed CP states need epsilon product.
18214 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
18215 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
18216 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
18217 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
18218 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
18219 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
18220 & P22*P30*P41+P13*P22*P31*P40
18221 C...For mixed CP states need gauge boson masses.
18222 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
18223 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
18224 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
18225 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
18230 IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
18231 KFLF1A=IABS(KFL1(1))
18232 EF1=KCHG(KFLF1A,1)/3D0
18233 AF1=SIGN(1D0,EF1+0.1D0)
18234 VF1=AF1-4D0*EF1*XWV
18235 KFLF2A=IABS(KFL1(2))
18236 EF2=KCHG(KFLF2A,1)/3D0
18237 AF2=SIGN(1D0,EF2+0.1D0)
18238 VF2=AF2-4D0*EF2*XWV
18239 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
18240 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18243 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
18244 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
18245 ELSEIF(MSTP(25).LE.2) THEN
18247 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18248 & -2*PKK(3,4)*PKK(5,6)
18249 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18250 & (PKK(3,4)*PKK(5,6))
18251 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18252 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
18254 C...Mixed CP states.
18255 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
18256 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
18257 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
18258 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
18259 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18260 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18261 & +PKK(3,4)*PKK(5,6)
18262 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18263 & +VA12AS*PKK(3,4)*PKK(5,6)
18264 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18265 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18266 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18267 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
18271 ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
18272 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18275 WT=16D0*PKK(3,5)*PKK(4,6)
18276 ELSEIF(MSTP(25).LE.2) THEN
18278 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18279 & -2*PKK(3,4)*PKK(5,6)
18280 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18281 & (PKK(3,4)*PKK(5,6))
18282 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18283 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
18285 C...Mixed CP states.
18286 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
18287 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
18288 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18289 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18290 & +PKK(3,4)*PKK(5,6)
18291 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18292 & +PKK(3,4)*PKK(5,6)
18293 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18294 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18295 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18296 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
18299 C...No angular correlations in other Higgs decays.
18304 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
18305 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
18307 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
18309 IF(MOD(KFAGM,2).EQ.0) THEN
18317 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
18318 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
18319 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
18320 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
18322 ELSEIF(ISUB.EQ.1) THEN
18323 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
18324 EI=KCHG(IABS(MINT(15)),1)/3D0
18325 AI=SIGN(1D0,EI+0.1D0)
18327 EF=KCHG(IABS(KFL1(1)),1)/3D0
18328 AF=SIGN(1D0,EF+0.1D0)
18331 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
18332 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18333 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
18334 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18335 & (VI**2+AI**2)*VINT(114)*VF**2)
18336 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
18337 & 4D0*VI*AI*VINT(114)*VF*AF)
18338 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18339 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18340 WTMAX=2D0*(WT1+ABS(WT3))
18342 ELSEIF(ISUB.EQ.2) THEN
18343 C...Angular weight for W+/- -> 2 quarks/leptons.
18344 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
18345 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
18346 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18347 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18350 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
18351 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
18352 C...-> gluon/gamma + 2 quarks/leptons.
18353 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18354 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18355 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18356 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18357 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18358 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18359 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18360 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18361 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18362 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18363 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18364 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18365 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
18366 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
18367 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18368 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
18370 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
18371 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
18372 C...-> gluon/gamma + 2 quarks/leptons.
18373 WT=PKK(1,3)**2+PKK(2,4)**2
18374 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
18376 ELSEIF(ISUB.EQ.22) THEN
18377 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
18378 S34=P(IREF(IP,IORD),5)**2
18379 S56=P(IREF(IP,3-IORD),5)**2
18380 TI=PKK(1,3)+PKK(1,4)+S34
18381 UI=PKK(1,5)+PKK(1,6)+S56
18384 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
18385 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
18386 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
18387 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
18388 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
18389 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
18390 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
18391 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
18394 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
18395 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
18396 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
18397 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
18398 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18399 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
18400 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
18403 ELSEIF(ISUB.EQ.23) THEN
18404 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
18405 D34=P(IREF(IP,IORD),5)**2
18406 D56=P(IREF(IP,3-IORD),5)**2
18407 DT=PKK(1,3)+PKK(1,4)+D34
18408 DU=PKK(1,5)+PKK(1,6)+D56
18409 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
18410 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18411 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18412 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
18414 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
18415 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
18416 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
18417 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18418 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
18419 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
18421 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
18422 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
18423 C...(or H0, or A0).
18424 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
18425 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
18426 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
18427 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
18428 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18430 ELSEIF(ISUB.EQ.25) THEN
18431 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
18432 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
18433 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
18434 D34=P(IREF(IP,IORD),5)**2
18435 D56=P(IREF(IP,3-IORD),5)**2
18436 DT=PKK(1,3)+PKK(1,4)+D34
18437 DU=PKK(1,5)+PKK(1,6)+D56
18438 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
18439 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
18440 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
18441 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
18442 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
18443 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
18444 & REAL(CBWW)*FGK(1,2,5,6,3,4))
18445 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18446 IF(MSTP(50).LE.0) THEN
18447 WT=FGK135**2+(CCWW*FGK253)**2
18448 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
18449 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
18452 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
18453 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
18454 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
18455 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
18458 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
18459 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
18460 C...(or H0, or A0).
18461 WT=PKK(1,3)*PKK(2,4)
18462 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18464 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
18465 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
18466 C...-> f + 2 quarks/leptons.
18467 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18468 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18469 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18470 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18471 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18472 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18473 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18474 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18475 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18476 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18477 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18478 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18479 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
18480 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
18481 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
18482 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
18483 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18484 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
18486 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
18487 C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
18488 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
18489 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
18490 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
18492 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
18494 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
18495 WT=16D0*PKK(3,5)*PKK(4,6)
18498 ELSEIF(ISUB.EQ.110) THEN
18499 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
18503 ELSEIF(ISUB.EQ.141) THEN
18504 C...Special case: if only branching ratios known then isotropic decay.
18505 IF(MWID(32).EQ.2) THEN
18508 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18509 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
18510 C...Couplings of incoming flavour.
18511 KFAI=IABS(MINT(15))
18512 EI=KCHG(KFAI,1)/3D0
18513 AI=SIGN(1D0,EI+0.1D0)
18516 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
18517 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
18518 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
18519 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
18520 VPI=PARU(119+2*KFAIC)
18521 API=PARU(120+2*KFAIC)
18522 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
18523 VPI=PARJ(178+2*KFAIC)
18524 API=PARJ(179+2*KFAIC)
18526 VPI=PARJ(186+2*KFAIC)
18527 API=PARJ(187+2*KFAIC)
18529 C...Couplings of final flavour.
18531 EF=KCHG(KFAF,1)/3D0
18532 AF=SIGN(1D0,EF+0.1D0)
18535 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
18536 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
18537 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
18538 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
18539 VPF=PARU(119+2*KFAFC)
18540 APF=PARU(120+2*KFAFC)
18541 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
18542 VPF=PARJ(178+2*KFAFC)
18543 APF=PARJ(179+2*KFAFC)
18545 VPF=PARJ(186+2*KFAFC)
18546 APF=PARJ(187+2*KFAFC)
18548 C...Asymmetry and weight.
18549 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
18550 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
18551 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
18552 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18553 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
18554 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
18555 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
18556 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18557 WTMAX=2D0+ABS(ASYM)
18558 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
18559 C...Angular weight for f + fbar -> Z' -> W+ + W-.
18560 RM1=P(NSD(1)+1,5)**2/SH
18561 RM2=P(NSD(1)+2,5)**2/SH
18562 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18563 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18564 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18566 WT=CFLAT+CCOS2*CTHE(1)**2
18567 WTMAX=CFLAT+MAX(0D0,CCOS2)
18568 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
18569 & IABS(KFL1(1)).EQ.37)) THEN
18570 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
18573 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18574 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
18575 RM1=P(NSD(1)+1,5)**2/SH
18576 RM2=P(NSD(1)+2,5)**2/SH
18577 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18578 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18579 WTMAX=1D0+FLAM2/(8D0*RM1)
18580 ELSEIF(MZPWP.EQ.0) THEN
18581 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18582 C...(W:s like if intermediate Z).
18583 D34=P(IREF(IP,IORD),5)**2
18584 D56=P(IREF(IP,3-IORD),5)**2
18585 DT=PKK(1,3)+PKK(1,4)+D34
18586 DU=PKK(1,5)+PKK(1,6)+D56
18587 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18588 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18589 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
18590 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
18591 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18592 ELSEIF(MZPWP.EQ.1) THEN
18593 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18594 C...(W:s approximately longitudinal, like if intermediate H).
18595 WT=16D0*PKK(3,5)*PKK(4,6)
18598 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
18599 C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
18604 ELSEIF(ISUB.EQ.142) THEN
18605 C...Special case: if only branching ratios known then isotropic decay.
18606 IF(MWID(34).EQ.2) THEN
18609 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18610 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
18611 KFAI=IABS(MINT(15))
18613 IF(KFAI.GT.10) KFAIC=2
18614 VI=PARU(129+2*KFAIC)
18615 AI=PARU(130+2*KFAIC)
18618 IF(KFAF.GT.10) KFAFC=2
18619 VF=PARU(129+2*KFAFC)
18620 AF=PARU(130+2*KFAFC)
18621 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
18622 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18623 WTMAX=2D0+ABS(ASYM)
18624 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
18625 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
18626 RM1=P(NSD(1)+1,5)**2/SH
18627 RM2=P(NSD(1)+2,5)**2/SH
18628 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18629 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18630 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18632 WT=CFLAT+CCOS2*CTHE(1)**2
18633 WTMAX=CFLAT+MAX(0D0,CCOS2)
18634 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18635 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
18636 RM1=P(NSD(1)+1,5)**2/SH
18637 RM2=P(NSD(1)+2,5)**2/SH
18638 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18639 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18640 WTMAX=1D0+FLAM2/(8D0*RM1)
18641 ELSEIF(MZPWP.EQ.0) THEN
18642 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18643 C...(W/Z like if intermediate W).
18644 D34=P(IREF(IP,IORD),5)**2
18645 D56=P(IREF(IP,3-IORD),5)**2
18646 DT=PKK(1,3)+PKK(1,4)+D34
18647 DU=PKK(1,5)+PKK(1,6)+D56
18648 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18649 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
18650 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18651 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
18652 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18653 ELSEIF(MZPWP.EQ.1) THEN
18654 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18655 C...(W/Z approximately longitudinal, like if intermediate H).
18656 WT=16D0*PKK(3,5)*PKK(4,6)
18659 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
18660 C...t + bbar -> t + W + bbar.
18665 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
18667 C...Isotropic decay of leptoquarks (assumed spin 0).
18671 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
18672 C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
18674 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
18675 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
18676 WT=1D0+SIDE*CTHE(1)
18678 ELSEIF(IP.EQ.1) THEN
18680 RM1=P(NSD(1)+1,5)**2/SH
18681 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18682 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18684 C...W/Z decay assumed isotropic, since not known.
18689 ELSEIF(ISUB.EQ.149) THEN
18690 C...Isotropic decay of techni-eta.
18694 ELSEIF(ISUB.EQ.191) THEN
18695 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18696 C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
18697 C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
18700 ELSEIF(IP.EQ.1) THEN
18701 C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
18702 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18703 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
18704 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18705 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18706 KFAI=IABS(MINT(15))
18707 EI=KCHG(KFAI,1)/3D0
18708 AI=SIGN(1D0,EI+0.1D0)
18712 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
18713 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
18715 EF=KCHG(KFAF,1)/3D0
18716 AF=SIGN(1D0,EF+0.1D0)
18720 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
18721 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
18722 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
18723 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
18724 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
18725 WTMAX=4D0*MAX(ASAME,AFLIP)
18727 C...Isotropic decay of W/pi_tc produced in rho_tc decay.
18732 ELSEIF(ISUB.EQ.192) THEN
18733 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18734 C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
18735 C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
18738 ELSEIF(IP.EQ.1) THEN
18739 C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
18740 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18744 C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
18749 ELSEIF(ISUB.EQ.193) THEN
18750 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18751 C...Angular weight for f + fbar -> omega_tc0 ->
18752 C...gamma pi_tc0 or Z0 pi_tc0.
18755 ELSEIF(IP.EQ.1) THEN
18756 C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
18757 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18758 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18759 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18760 KFAI=IABS(MINT(15))
18761 EI=KCHG(KFAI,1)/3D0
18762 AI=SIGN(1D0,EI+0.1D0)
18766 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
18767 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
18769 EF=KCHG(KFAF,1)/3D0
18770 AF=SIGN(1D0,EF+0.1D0)
18774 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
18775 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
18776 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
18777 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
18778 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
18779 WTMAX=4D0*MAX(BSAME,BFLIP)
18781 C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
18786 ELSEIF(ISUB.EQ.353) THEN
18787 C...Angular weight for Z_R0 -> 2 quarks/leptons.
18788 EI=KCHG(IABS(MINT(15)),1)/3D0
18789 AI=SIGN(1D0,EI+0.1D0)
18791 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
18792 AF=SIGN(1D0,EF+0.1D0)
18794 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
18795 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
18796 WT2=RMF*(VI**2+AI**2)*VF**2
18797 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
18798 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18799 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18800 WTMAX=2D0*(WT1+ABS(WT3))
18802 ELSEIF(ISUB.EQ.354) THEN
18803 C...Angular weight for W_R+/- -> 2 quarks/leptons.
18804 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
18805 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
18806 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18807 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18810 ELSEIF(ISUB.EQ.391) THEN
18811 C...Angular weight for f + fbar -> G* -> f + fbar
18812 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18813 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
18815 C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
18816 C...implemented by M.-C. Lemaire
18817 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18818 & IABS(KFL1(1)).EQ.22)) THEN
18821 C...Other G* decays not yet implemented angular distributions.
18827 ELSEIF(ISUB.EQ.392) THEN
18828 C...Angular weight for g + g -> G* -> f + fbar
18829 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18832 C...Angular weight for g + g -> G* -> gamma +gamma or g + g
18833 C...implemented by M.-C. Lemaire
18834 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18835 & IABS(KFL1(1)).EQ.22)) THEN
18836 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
18838 C...Other G* decays not yet implemented angular distributions.
18844 C...Obtain correct angular distribution by rejection techniques.
18849 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
18851 C...Construct massive four-vectors using angles chosen.
18852 590 DO 690 JT=1,JTMAX
18853 IF(KDCY(JT).EQ.0) GOTO 690
18858 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
18860 IF(KFL3(JT).EQ.0) THEN
18861 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
18862 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18865 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
18866 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18871 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
18873 C...Fill in position of decay vertex.
18874 DO 630 I=NSD(JT)+1,N0
18883 C...Mark decayed resonances; trace history.
18887 IF(KCQM(JT).NE.0) THEN
18888 C...Do not kill colour flow through coloured resonance!
18892 C...If 3-body or 2-body with junction:
18893 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
18894 C...If 3-body with junction:
18895 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
18898 C...Add documentation lines.
18899 ISUBRG=MAX(1,MIN(500,MINT(1)))
18900 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
18901 IDOC=MINT(83)+MINT(4)
18904 IF(KFL3(JT).NE.0) IHI=IHI+1
18905 DO 650 I=NSD(JT)+1,IHI
18907 I1=MINT(83)+MINT(4)+1
18909 IF(MSTP(128).GE.1) K(I,3)=ID
18910 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18914 K(I1,3)=IREF(IP,JT+3)
18923 C...If 3-body or 2-body with junction:
18924 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
18925 C...If 3-body with junction:
18926 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
18929 C...Do showering of two or three objects.
18931 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
18932 IF(KFL3(JT).EQ.0) THEN
18933 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
18935 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
18938 c...For pT-ordered shower need set up first, especially colour tags.
18939 C...(Need to set up colour tags even if MSTP(71) = 0)
18940 ELSEIF(MINT(35).GE.2) THEN
18942 IF(KFL3(JT).NE.0) NPART=3
18946 PTPART(1)=0.5D0*P(ID,5)
18947 PTPART(2)=PTPART(1)
18948 PTPART(3)=PTPART(1)
18949 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
18950 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
18951 IF(MOTHER.LE.NSD(JT)) THEN
18952 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
18955 MCT(NSD(JT)+1,1)=NCT
18959 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
18960 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
18961 IF(MOTHER.LE.NSD(JT)) THEN
18962 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
18965 MCT(NSD(JT)+1,2)=NCT
18969 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
18970 & KCQ2(JT).EQ.2)) THEN
18971 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
18972 IF(MOTHER.LE.NSD(JT)) THEN
18973 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
18976 MCT(NSD(JT)+2,1)=NCT
18980 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
18981 & KCQ2(JT).EQ.2)) THEN
18982 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
18983 IF(MOTHER.LE.NSD(JT)) THEN
18984 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18987 MCT(NSD(JT)+2,2)=NCT
18991 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
18992 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
18993 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
18994 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
18996 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
18997 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
18998 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
18999 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
19001 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
19004 IF(JT.EQ.1) NAFT1=N
19006 C...Check if decay products moved by shower.
19010 IF(NSHAFT.GT.NSHBEF) THEN
19011 IF(K(NSD1,1).GT.10) THEN
19012 DO 660 I=NSHBEF+1,NSHAFT
19013 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
19016 IF(K(NSD2,1).GT.10) THEN
19017 DO 670 I=NSHBEF+1,NSHAFT
19018 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
19019 & I.NE.NSD1) NSD2=I
19022 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
19023 DO 680 I=NSHBEF+1,NSHAFT
19024 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
19025 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
19030 C...Store decay products for further treatment.
19035 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
19039 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
19040 IREF(NP,7)=K(IREF(IP,JT),2)
19041 IREF(NP,8)=IREF(IP,JT)
19045 C...Fill information for 2 -> 1 -> 2.
19046 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
19047 MINT(7)=MINT(83)+6+2*ISET(ISUB)
19048 MINT(8)=MINT(83)+7+2*ISET(ISUB)
19054 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19055 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
19056 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
19057 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
19058 VINT(47)=SQRT(VINT(48))
19061 C...Possibility of colour rearrangement in W+W- events.
19062 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
19063 IAKF1=IABS(KFL1(1))
19064 IAKF2=IABS(KFL1(2))
19065 IAKF3=IABS(KFL2(1))
19066 IAKF4=IABS(KFL2(2))
19067 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
19068 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
19069 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
19070 IF(MINT(51).NE.0) RETURN
19073 C...Loop back if needed.
19074 710 IF(IP.LT.NP) GOTO 170
19076 C...Boost back to standard frame.
19077 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
19083 C*********************************************************************
19086 C...Initializes treatment of multiple interactions, selects kinematics
19087 C...of hardest interaction if low-pT physics included in run, and
19088 C...generates all non-hardest interactions.
19090 SUBROUTINE PYMULT(MMUL)
19092 C...Double precision and integer declarations.
19093 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19094 IMPLICIT INTEGER(I-N)
19095 INTEGER PYK,PYCHGE,PYCOMP
19097 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19098 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19099 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19100 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19101 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19102 COMMON/PYINT1/MINT(400),VINT(400)
19103 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19104 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19105 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19106 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19107 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
19108 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
19109 C...Local arrays and saved variables.
19110 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
19111 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19112 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19113 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19115 C...Initialization of multiple interaction treatment.
19117 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19125 C...Loop over phase space points: xT2 choice in 20 bins.
19128 NMUL(IXT2)=MSTP(83)
19130 DO 110 ITRY=1,MSTP(83)
19131 RSCA=0.05D0*((21-IXT2)-PYR(0))
19132 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19133 XT2=MAX(0.01D0*VINT(149),XT2)
19136 C...Choose tau and y*. Calculate cos(theta-hat).
19137 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19138 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19139 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19141 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19147 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19148 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19149 CALL PYKMAP(2,MYST,PYR(0))
19150 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19152 C...Calculate differential cross-section.
19153 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19154 CALL PYSIGH(NCHN,SIGS)
19155 SIGM(IXT2)=SIGM(IXT2)+SIGS
19157 SIGSUM=SIGSUM+SIGM(IXT2)
19159 SIGSUM=SIGSUM/(20D0*MSTP(83))
19161 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19162 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19163 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19164 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19165 PARP(82)=0.9D0*PARP(82)
19166 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19171 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19173 C...Start iteration to find k factor.
19174 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19175 P83A=(1D0-PARP(83))**2
19176 P83B=2D0*PARP(83)*(1D0-PARP(83))
19178 CQ2I=1D0/PARP(84)**2
19179 CQ2R=2D0/(1D0+PARP(84)**2)
19187 130 IF(IIT.EQ.0) THEN
19189 ELSEIF(IIT.EQ.1) THEN
19192 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19195 C...Evaluate overlap integrals. Find where to divide the b range.
19196 IF(MSTP(82).EQ.2) THEN
19197 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19200 IF(MSTP(82).EQ.3) THEN
19202 ELSEIF(MSTP(82).EQ.4) THEN
19203 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19205 POWIP=MAX(0.4D0,PARP(83))
19206 RPWIP=2D0/POWIP-1D0
19207 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19217 IF(MSTP(82).EQ.3) THEN
19218 OV=EXP(-B**2)/PARU(2)
19219 ELSEIF(MSTP(82).EQ.4) THEN
19220 OV=(P83A*EXP(-MIN(50D0,B**2))+
19221 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19222 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19224 OV=EXP(-B**POWIP)/PARU(2)
19225 SO=SO+PARU(2)*B*DELTAB*OV
19227 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19228 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19229 SP=SP+PARU(2)*B*DELTAB*PACC
19230 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19231 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19232 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19234 BDIV=B+0.5D0*DELTAB
19236 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19238 YK=PARU(1)*XK*SO/SP
19240 C...Continue iteration until convergence.
19250 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19252 C...Store some results for subsequent use.
19260 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19261 PIK=(VNT146/VNT147)*YKE
19263 C...Find relative weight for low and high impact parameter.
19264 PLOWB=PARU(1)*BDIV**2
19265 IF(MSTP(82).EQ.3) THEN
19266 PHIGHB=PIK*0.5*EXP(-BDIV**2)
19267 ELSEIF(MSTP(82).EQ.4) THEN
19268 S4A=P83A*EXP(-BDIV**2)
19269 S4B=P83B*EXP(-BDIV**2*CQ2R)
19270 S4C=P83C*EXP(-BDIV**2*CQ2I)
19271 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19272 ELSEIF(PARP(83).GE.1.999D0) THEN
19278 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
19282 C...Initialize iteration in xT2 for hardest interaction.
19283 ELSEIF(MMUL.EQ.2) THEN
19287 IF(MSTP(82).LE.0) THEN
19288 ELSEIF(MSTP(82).EQ.1) THEN
19290 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19291 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19292 & VINT(317)/(VINT(318)*VINT(320))
19293 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19294 ELSEIF(MSTP(82).EQ.2) THEN
19296 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19297 & VINT(149)*(1D0+VINT(149))
19299 XC2=4D0*CKIN(3)**2/VINT(2)
19300 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
19303 C...Select impact parameter for hardest interaction.
19304 IF(MSTP(82).LE.2) RETURN
19305 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
19306 C...Treatment in low b region.
19308 B=BDIV*SQRT(PYR(0))
19309 IF(MSTP(82).EQ.3) THEN
19310 OV=EXP(-B**2)/PARU(2)
19311 ELSEIF(MSTP(82).EQ.4) THEN
19312 OV=(P83A*EXP(-MIN(50D0,B**2))+
19313 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19314 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19316 OV=EXP(-B**POWIP)/PARU(2)
19318 VINT(148)=OV/VNT147
19319 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
19321 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19322 & VINT(149)*(1D0+VINT(149))
19324 C...Treatment in high b region.
19326 IF(MSTP(82).EQ.3) THEN
19327 B=SQRT(BDIV**2-LOG(PYR(0)))
19328 OV=EXP(-B**2)/PARU(2)
19329 ELSEIF(MSTP(82).EQ.4) THEN
19330 S4RNDM=PYR(0)*(S4A+S4B+S4C)
19331 IF(S4RNDM.LT.S4A) THEN
19332 B=SQRT(BDIV**2-LOG(PYR(0)))
19333 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
19334 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
19336 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
19338 OV=(P83A*EXP(-MIN(50D0,B**2))+
19339 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19340 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19341 ELSEIF(PARP(83).GE.1.999D0) THEN
19342 144 B2RPW=B2RPDV-LOG(PYR(0))
19343 ACCIP=(B2RPW/B2RPDV)**RPWIP
19344 IF(ACCIP.LT.PYR(0)) GOTO 144
19345 OV=EXP(-B2RPW)/PARU(2)
19346 B=B2RPW**(1D0/POWIP)
19348 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
19349 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
19350 IF(ACCIP.LT.PYR(0)) GOTO 146
19351 OV=EXP(-B2RPW)/PARU(2)
19352 B=B2RPW**(1D0/POWIP)
19354 VINT(148)=OV/VNT147
19355 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
19357 IF(PACC.LT.PYR(0)) GOTO 142
19360 ELSEIF(MMUL.EQ.3) THEN
19361 C...Low-pT or multiple interactions (first semihard interaction):
19362 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19363 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19368 IF(MSTP(82).LE.0) THEN
19370 ELSEIF(MSTP(82).EQ.1) THEN
19371 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19372 C...Use with "Sudakov" for low b values when impact parameter dependence.
19373 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
19374 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
19375 & VINT(149)))).GT.PYR(0)) XT2=1D0
19376 IF(XT2.GE.1D0) THEN
19377 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
19378 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
19381 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
19382 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
19385 XT2=MAX(0.01D0*VINT(149),XT2)
19386 C...Use without "Sudakov" for high b values when impact parameter dep.
19388 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
19389 & PYR(0)*(1D0-XC2))-VINT(149)
19390 XT2=MAX(0.01D0*VINT(149),XT2)
19394 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19395 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
19396 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
19397 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
19400 VINT(21)=0.01D0*VINT(149)
19403 VINT(25)=0.01D0*VINT(149)
19406 C...Multiple interactions (first semihard interaction).
19407 C...Choose tau and y*. Calculate cos(theta-hat).
19408 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19409 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19410 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19412 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19418 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19419 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19420 CALL PYKMAP(2,MYST,PYR(0))
19421 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19423 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
19425 C...Store results of cross-section calculation.
19426 ELSEIF(MMUL.EQ.4) THEN
19432 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
19433 IF(ISET(ISUB).EQ.2)
19434 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
19435 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
19436 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
19437 & (XTS+VINT(149))))
19438 IRBIN=INT(1D0+20D0*RBIN)
19439 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
19440 NMUL(IRBIN)=NMUL(IRBIN)+1
19441 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
19444 C...Choose impact parameter if not already done.
19445 ELSEIF(MMUL.EQ.5) THEN
19450 150 IF(MINT(39).GT.0) THEN
19451 ELSEIF(MSTP(82).EQ.3) THEN
19454 VINT(148)=EXPB2/(PARU(2)*VNT147)
19455 VINT(139)=SQRT(B2)/BAVG
19456 ELSEIF(MSTP(82).EQ.4) THEN
19458 IF(RTYPE.LT.P83A) THEN
19460 ELSEIF(RTYPE.LT.P83A+P83B) THEN
19461 B2=-LOG(PYR(0))/CQ2R
19463 B2=-LOG(PYR(0))/CQ2I
19465 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
19466 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
19467 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
19468 VINT(139)=SQRT(B2)/BAVG
19469 ELSEIF(PARP(83).GE.1.999D0) THEN
19470 POWIP=MAX(2D0,PARP(83))
19471 RPWIP=2D0/POWIP-1D0
19472 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
19473 160 IF(PYR(0).LT.PROB1) THEN
19474 B2RPW=PYR(0)**(0.5D0*POWIP)
19477 B2RPW=1D0-LOG(PYR(0))
19480 IF(ACCIP.LT.PYR(0)) GOTO 160
19481 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19482 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19484 POWIP=MAX(0.4D0,PARP(83))
19485 RPWIP=2D0/POWIP-1D0
19486 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
19487 170 IF(PYR(0).LT.PROB1) THEN
19488 B2RPW=2D0*RPWIP*PYR(0)
19489 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
19491 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
19492 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
19494 IF(ACCIP.LT .PYR(0)) GOTO 170
19495 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19496 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19499 C...Multiple interactions (variable impact parameter) : reject with
19500 C...probability exp(-overlap*cross-section above pT/normalization).
19501 C...Does not apply to low-b region, where "Sudakov" already included.
19503 IF(MINT(39).NE.1) THEN
19504 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
19505 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
19506 DO 180 IBIN=IRBIN+1,20
19507 RNCOR=RNCOR+NMUL(IBIN)
19508 SIGCOR=SIGCOR+SIGM(IBIN)
19510 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
19511 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
19512 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
19513 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
19515 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
19516 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
19517 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
19518 IF(VINT(150).LT.PYR(0)) GOTO 150
19522 C...Generate additional multiple semihard interactions.
19523 ELSEIF(MMUL.EQ.6) THEN
19536 C...Reconstruct strings in hard scattering.
19538 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
19539 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
19541 DO 210 I=MINT(84)+1,NMAX
19542 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
19543 IF(KCS.EQ.0) GOTO 210
19545 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
19546 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
19548 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
19550 IST=MOD(K(I,J+1),MSTU(5))
19552 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
19553 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
19555 IF(J.EQ.1.OR.J.EQ.4) THEN
19565 C...Set up starting values for iteration in xT2.
19566 XT2=4D0*VINT(62)/VINT(2)
19567 IF(MSTP(82).LE.1) THEN
19568 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19569 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19570 & VINT(317)/(VINT(318)*VINT(320))
19571 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19573 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
19574 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
19578 VINT(143)=1D0-VINT(141)
19579 VINT(144)=1D0-VINT(142)
19581 C...Iterate downwards in xT2.
19582 220 IF(MSTP(82).LE.1) THEN
19583 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19584 IF(XT2.LT.VINT(149)) GOTO 270
19586 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
19587 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
19588 & LOG(PYR(0)))-VINT(149)
19589 IF(XT2.LE.0D0) GOTO 270
19590 XT2=MAX(0.01D0*VINT(149),XT2)
19594 C...Choose tau and y*. Calculate cos(theta-hat).
19595 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19596 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19597 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19599 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19605 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19606 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19607 CALL PYKMAP(2,MYST,PYR(0))
19608 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19610 C...Check that x not used up. Accept or reject kinematical variables.
19611 X1M=SQRT(TAU)*EXP(VINT(22))
19612 X2M=SQRT(TAU)*EXP(-VINT(22))
19613 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
19614 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19615 CALL PYSIGH(NCHN,SIGS)
19616 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
19617 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
19619 C...Reset K, P and V vectors. Select some variables.
19628 PT=0.5D0*VINT(1)*SQRT(XT2)
19632 C...Add first parton to event record.
19635 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
19636 & 1+INT((2D0+PARJ(2))*PYR(0))
19637 P(N+1,1)=PT*COS(PHI)
19638 P(N+1,2)=PT*SIN(PHI)
19639 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
19640 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
19643 C...Add second parton to event record.
19646 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
19649 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
19650 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
19653 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
19654 C....Choose relevant string pieces to place gluons on.
19660 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
19661 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
19662 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
19663 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
19664 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
19672 C....Colour flow adjustments, new string pieces.
19673 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
19674 & MOD(K(IST1,4),MSTU(5))
19675 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
19676 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
19677 K(I,5)=MSTU(5)*IST1
19678 K(I,4)=MSTU(5)*IST2
19679 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
19680 & MOD(K(IST2,5),MSTU(5))
19681 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
19682 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
19685 KSTR(NSTR+1,2)=IST2
19689 C...String drawing and colour flow for gluon loop.
19690 ELSEIF(K(N+1,2).EQ.21) THEN
19691 K(N+1,4)=MSTU(5)*(N+2)
19692 K(N+1,5)=MSTU(5)*(N+2)
19693 K(N+2,4)=MSTU(5)*(N+1)
19694 K(N+2,5)=MSTU(5)*(N+1)
19701 C...String drawing and colour flow for qqbar pair.
19703 K(N+1,4)=MSTU(5)*(N+2)
19704 K(N+2,5)=MSTU(5)*(N+1)
19710 C...Global statistics.
19711 MINT(351)=MINT(351)+1
19712 VINT(351)=VINT(351)+PT
19713 IF (MINT(351).EQ.1) VINT(356)=PT
19715 C...Update remaining energy; iterate.
19717 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
19718 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
19722 MINT(31)=MINT(31)+1
19723 VINT(151)=VINT(151)+VINT(41)
19724 VINT(152)=VINT(152)+VINT(42)
19725 VINT(143)=VINT(143)-VINT(41)
19726 VINT(144)=VINT(144)-VINT(42)
19727 C...Allow FSR for UE (always handle with old showers)
19728 IF(MSTP(152).EQ.1) THEN
19730 IF (MSTJ(41).EQ.10) MSTJ(41)=2
19731 MSTJ(41)=MOD(MSTJ(41),10)
19732 CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
19735 IF(MINT(31).LT.240) GOTO 220
19743 C...Format statements for printout.
19744 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
19745 &'actions for MSTP(82) =',I2,' ******')
19746 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19747 &D9.2,' mb: rejected')
19748 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19749 &D9.2,' mb: accepted')
19754 C*********************************************************************
19757 C...Adds on target remnants (one or two from each side) and
19758 C...includes primordial kT for hadron beams.
19760 SUBROUTINE PYREMN(IPU1,IPU2)
19762 C...Double precision and integer declarations.
19763 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19764 IMPLICIT INTEGER(I-N)
19765 INTEGER PYK,PYCHGE,PYCOMP
19767 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19768 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19769 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19770 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19771 COMMON/PYINT1/MINT(400),VINT(400)
19772 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19774 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
19775 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
19777 C...Find event type and remaining energy.
19780 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
19781 VINT(143)=1D0-VINT(141)
19782 VINT(144)=1D0-VINT(142)
19785 C...Define initial partons.
19790 IF(JT.EQ.1) IPU=IPU1
19791 IF(JT.EQ.2) IPU=IPU2
19798 IF(MINT(47).EQ.1) THEN
19802 ELSEIF(ISUB.EQ.95) THEN
19807 C...No primordial kT, or chosen according to truncated Gaussian or
19808 C...exponential, or (for photon) predetermined or power law.
19809 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
19810 IF(MSTP(91).LE.0) THEN
19812 ELSEIF(MSTP(91).EQ.1) THEN
19813 PT=PARP(91)*SQRT(-LOG(PYR(0)))
19817 PT=-PARP(92)*LOG(RPT1*RPT2)
19819 IF(PT.GT.PARP(93)) GOTO 120
19820 ELSEIF(MINT(106+JT).EQ.3) THEN
19821 PTA=SQRT(VINT(282+JT))
19823 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
19824 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
19825 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
19828 PTB=-PARP(99)*LOG(RPT1*RPT2)
19830 IF(PTB.GT.PARP(100)) GOTO 120
19831 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
19832 PT=PT*0.8D0**MINT(57)
19833 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
19834 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
19835 IF(MSTP(93).LE.0) THEN
19837 ELSEIF(MSTP(93).EQ.1) THEN
19838 PT=PARP(99)*SQRT(-LOG(PYR(0)))
19839 ELSEIF(MSTP(93).EQ.2) THEN
19842 PT=-PARP(99)*LOG(RPT1*RPT2)
19843 ELSEIF(MSTP(93).EQ.3) THEN
19846 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
19850 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
19851 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
19853 IF(PT.GT.PARP(100)) GOTO 120
19861 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19864 IF(MINT(47).EQ.1) RETURN
19866 C...Kinematics construction for initial partons.
19869 IF(ISUB.EQ.95) THEN
19873 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
19874 & (P(I1,2)+P(I2,2))**2
19875 SHR=SQRT(MAX(0D0,SHS))
19876 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
19877 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
19878 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
19879 P(I2,4)=SHR-P(I1,4)
19882 C...Transform partons to overall CM-frame.
19883 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
19884 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
19885 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
19886 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
19887 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
19888 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
19889 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
19890 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
19891 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
19892 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
19893 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
19896 C...Optionally fix up x and Q2 definitions for leptoproduction.
19898 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
19899 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
19900 IF(IDISXQ.EQ.1) THEN
19902 C...Find where incoming and outgoing leptons/partons are sitting.
19904 IF(MINT(42).EQ.1) LESD=2
19905 LPIN=MINT(83)+3-LESD
19907 LQIN=MINT(84)+3-LESD
19908 LEOUT=MINT(84)+2+LESD
19909 LQOUT=MINT(84)+5-LESD
19910 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
19911 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
19913 DO 140 I=MINT(84)+5,N
19914 IF(K(I,2).EQ.94) THEN
19921 IF(LESD.EQ.1) LQBG=IPU2
19923 C...Calculate actual and wanted momentum transfer.
19926 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
19927 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
19928 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
19929 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
19930 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
19931 P(N+1,1)=FAC*P(LEOUT,1)
19932 P(N+1,2)=FAC*P(LEOUT,2)
19933 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
19934 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
19935 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
19938 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
19939 QNEW(J)=P(LEIN,J)-P(N+1,J)
19942 C...Boost outgoing electron and daughters.
19943 IF(LSCMS.EQ.0) THEN
19945 P(LEOUT,J)=P(N+1,J)
19949 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
19951 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
19953 DBE(J)=PINV*P(N+2,J)
19957 190 IORIG=K(IORIG,3)
19958 IF(IORIG.GT.LEOUT) GOTO 190
19959 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
19960 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
19964 C...Copy shower initiator and all outgoing partons.
19968 P(NCOP,J)=P(LQBG,J)
19970 DO 240 I=MINT(84)+1,N
19972 IF(K(I,1).GT.10) GOTO 240
19973 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
19977 220 IORIG=K(IORIG,3)
19978 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
19980 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
19993 C...Calculate relative rescaling factors.
19997 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
20000 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
20003 C...Transfer extra three-momentum of current.
20006 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
20008 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20011 C...Iterate change of initiator momentum to get energy right.
20014 PEEX=-P(N+1,4)-QNEW(4)
20015 PEMV=-P(N+1,3)/P(N+1,4)
20018 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
20020 IF(ABS(PEMV).LT.1D-10) THEN
20022 MINT(57)=MINT(57)+1
20026 P(N+1,3)=P(N+1,3)+PZCH
20027 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)
20029 P(I,3)=P(I,3)+V(I,1)*PZCH
20030 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20032 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
20034 C...Modify momenta in event record.
20035 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
20036 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
20037 IF(ABS(HBE).GE.1D0) THEN
20039 MINT(57)=MINT(57)+1
20043 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
20052 C...Check minimum invariant mass of remnant system(s).
20053 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
20054 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
20055 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20056 PMIN(0)=SQRT(PMS(0))
20058 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
20059 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
20061 IF(MINT(44+JT).EQ.1) GOTO 340
20062 MINT(105)=MINT(102+JT)
20063 MINT(109)=MINT(106+JT)
20064 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
20065 IF(MINT(51).NE.0) THEN
20066 MINT(57)=MINT(57)+1
20069 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
20070 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
20071 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
20072 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
20073 & P(MINT(83)+JT+2,2)**2)
20075 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
20076 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
20079 MINT(57)=MINT(57)+1
20083 C...Loop over two remnants; skip if none there.
20087 IF(MINT(44+JT).EQ.1) GOTO 410
20088 IF(JT.EQ.1) IPU=IPU1
20089 IF(JT.EQ.2) IPU=IPU2
20091 C...Store first remnant parton.
20103 P(I,5)=PYMASS(K(I,2))
20105 C...First parton colour connections and kinematics.
20106 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
20109 K(I,4)=MSTU(5)*IPU+IPU
20110 K(I,5)=MSTU(5)*IPU+IPU
20111 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20112 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20113 ELSEIF(KCOL.NE.0) THEN
20115 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
20117 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20119 IF(KFLCH(JT).EQ.0) THEN
20120 P(I,1)=-P(MINT(83)+JT+2,1)
20121 P(I,2)=-P(MINT(83)+JT+2,2)
20122 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20123 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20127 C...When extra remnant parton or hadron: store extra remnant.
20139 P(I,5)=PYMASS(K(I,2))
20141 C...Find parton colour connections of extra remnant.
20142 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
20145 K(I,4)=MSTU(5)*IPU+IPU
20146 K(I,5)=MSTU(5)*IPU+IPU
20147 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20148 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20149 ELSEIF(KCOL.NE.0) THEN
20151 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
20153 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20156 C...Relative transverse momentum when two remnants.
20159 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
20160 IF(IABS(MINT(10+JT)).LT.20) THEN
20164 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
20165 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
20167 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
20168 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
20169 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
20170 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20172 C...Meson or baryon; photon as meson. For splitup below.
20174 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
20176 C***Relative distribution for electron into two electrons. Temporary!
20177 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
20181 C...Relative distribution of electron energy into electron plus parton.
20182 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
20185 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
20187 C...Relative distribution of energy for particle into two jets.
20188 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
20189 CHIK=PARP(92+2*IMB)
20190 IF(MSTP(92).LE.1) THEN
20191 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20192 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20193 ELSEIF(MSTP(92).EQ.2) THEN
20194 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
20195 ELSEIF(MSTP(92).EQ.3) THEN
20196 CUT=2D0*0.3D0/VINT(1)
20197 380 CHI(JT)=PYR(0)**2
20198 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
20199 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
20200 ELSEIF(MSTP(92).EQ.4) THEN
20201 CUT=2D0*0.3D0/VINT(1)
20202 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
20203 390 CHIR=CUT*CUTR**PYR(0)
20204 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
20205 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
20207 CUT=2D0*0.3D0/VINT(1)
20208 CUTA=CUT**(1D0-PARP(98))
20209 CUTB=(1D0+CUT)**(1D0-PARP(98))
20210 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
20211 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
20212 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
20215 C...Relative distribution of energy for particle into jet plus particle.
20217 IF(MSTP(94).LE.1) THEN
20218 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20219 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20220 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20221 ELSEIF(MSTP(94).EQ.2) THEN
20222 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
20223 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20224 ELSEIF(MSTP(94).EQ.3) THEN
20225 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
20228 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
20233 C...Construct total transverse mass; reject if too large.
20234 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
20235 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
20236 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
20237 IF(LOOP.LT.100) THEN
20241 MINT(57)=MINT(57)+1
20245 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20246 VINT(158+JT)=CHI(JT)
20248 C...Subdivide longitudinal momentum according to value selected above.
20249 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
20250 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
20251 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
20252 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
20253 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
20258 C...Check if longitudinal boosts needed - if so pick two systems.
20259 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
20260 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
20261 IF(PDEV.LE.1D-6*VINT(1)) RETURN
20262 IF(ISN(1).EQ.0) THEN
20265 ELSEIF(ISN(2).EQ.0) THEN
20268 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
20271 ELSEIF(VINT(143).GT.0.2D0) THEN
20274 ELSEIF(VINT(144).GT.0.2D0) THEN
20277 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
20286 C...E+-pL wanted for system to be modified.
20287 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
20291 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
20292 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
20295 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
20296 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
20297 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
20298 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
20302 DO 450 I=MINT(84)+1,NS
20303 IF(K(I,1).GT.10) GOTO 450
20306 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20308 IF(IORIG.GT.LPIN) GOTO 430
20309 IF(INCL.EQ.0) GOTO 450
20311 PSYS(0,J)=PSYS(0,J)+P(I,J)
20314 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20315 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
20316 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
20319 C...Construct longitudinal boosts.
20323 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
20324 IF(DSQLAM.LE.1D-6*DPMTB) THEN
20326 MINT(57)=MINT(57)+1
20329 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
20330 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
20331 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
20332 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
20333 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
20334 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
20335 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
20337 C...Perform longitudinal boosts.
20338 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
20340 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
20341 ELSEIF(IR.EQ.1) THEN
20342 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
20343 ELSEIF(IDISXQ.EQ.1) THEN
20347 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20349 IF(IORIG.GT.LPIN) GOTO 460
20350 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
20353 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
20355 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
20357 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
20358 ELSEIF(IL.EQ.2) THEN
20359 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
20360 ELSEIF(IDISXQ.EQ.1) THEN
20364 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20366 IF(IORIG.GT.LPIN) GOTO 480
20367 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
20370 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
20373 C...Final check that energy-momentum conservation worked.
20376 DO 500 I=MINT(84)+1,N
20377 IF(K(I,1).GT.10) GOTO 500
20381 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
20382 IF(PDEV.GT.1D-4*VINT(1)) THEN
20384 MINT(57)=MINT(57)+1
20388 C...Calculate rotation and boost from overall CM frame to
20389 C...hadronic CM frame in leptoproduction.
20391 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20394 IF(MINT(42).EQ.1) LESD=2
20395 LPIN=MINT(83)+3-LESD
20397 C...Sum upp momenta of everything not lepton or photon to define boost.
20402 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
20403 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
20404 IF(K(I,2).EQ.22) GOTO 530
20406 PSUM(J)=PSUM(J)+P(I,J)
20409 VINT(223)=-PSUM(1)/PSUM(4)
20410 VINT(224)=-PSUM(2)/PSUM(4)
20411 VINT(225)=-PSUM(3)/PSUM(4)
20413 C...Boost incoming hadron to hadronic CM frame to determine rotations.
20419 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
20420 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
20421 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
20423 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
20425 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
20432 C*********************************************************************
20435 C...Initializes treatment of new multiple interactions scenario,
20436 C...selects kinematics of hardest interaction if low-pT physics
20437 C...included in run, and generates all non-hardest interactions.
20439 SUBROUTINE PYMIGN(MMUL)
20441 C...Double precision and integer declarations.
20442 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20443 IMPLICIT INTEGER(I-N)
20444 INTEGER PYK,PYCHGE,PYCOMP
20446 DOUBLE PRECISION PYALPS
20448 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20449 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20450 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20451 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20452 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20453 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20454 COMMON/PYINT1/MINT(400),VINT(400)
20455 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20456 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20457 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20458 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20459 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20460 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20461 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20462 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20463 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
20464 C...Local arrays and saved variables.
20465 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
20466 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
20467 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
20468 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
20469 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
20471 C...Initialization of multiple interaction treatment.
20473 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
20481 C...Loop over phase space points: xT2 choice in 20 bins.
20484 NMUL(IXT2)=MSTP(83)
20486 DO 110 ITRY=1,MSTP(83)
20487 RSCA=0.05D0*((21-IXT2)-PYR(0))
20488 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
20489 XT2=MAX(0.01D0*VINT(149),XT2)
20492 C...Choose tau and y*. Calculate cos(theta-hat).
20493 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20494 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20495 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20497 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20503 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20504 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20505 CALL PYKMAP(2,MYST,PYR(0))
20506 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20508 C...Calculate differential cross-section.
20509 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20510 CALL PYSIGH(NCHN,SIGS)
20511 SIGM(IXT2)=SIGM(IXT2)+SIGS
20513 SIGSUM=SIGSUM+SIGM(IXT2)
20515 SIGSUM=SIGSUM/(20D0*MSTP(83))
20517 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
20518 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
20519 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
20520 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
20521 PARP(82)=0.9D0*PARP(82)
20522 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
20526 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
20527 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
20529 C...Start iteration to find k factor.
20530 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
20531 P83A=(1D0-PARP(83))**2
20532 P83B=2D0*PARP(83)*(1D0-PARP(83))
20534 CQ2I=1D0/PARP(84)**2
20535 CQ2R=2D0/(1D0+PARP(84)**2)
20543 130 IF(IIT.EQ.0) THEN
20545 ELSEIF(IIT.EQ.1) THEN
20548 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
20551 C...Evaluate overlap integrals. Find where to divide the b range.
20552 IF(MSTP(82).EQ.2) THEN
20553 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
20556 IF(MSTP(82).EQ.3) THEN
20558 ELSEIF(MSTP(82).EQ.4) THEN
20559 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
20561 POWIP=MAX(0.4D0,PARP(83))
20562 RPWIP=2D0/POWIP-1D0
20563 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
20573 IF(MSTP(82).EQ.3) THEN
20574 OV=EXP(-B**2)/PARU(2)
20575 ELSEIF(MSTP(82).EQ.4) THEN
20576 OV=(P83A*EXP(-MIN(50D0,B**2))+
20577 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20578 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20580 OV=EXP(-B**POWIP)/PARU(2)
20581 SO=SO+PARU(2)*B*DELTAB*OV
20583 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
20584 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
20585 SP=SP+PARU(2)*B*DELTAB*PACC
20586 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
20587 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
20588 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
20590 BDIV=B+0.5D0*DELTAB
20592 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
20594 YK=PARU(1)*XK*SO/SP
20596 C...Continue iteration until convergence.
20606 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
20608 C...Store some results for subsequent use.
20616 C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
20617 PIK=(VNT146/VNT147)*YKE
20619 C...Find relative weight for low and high impact parameter..
20620 PLOWB=PARU(1)*BDIV**2
20621 IF(MSTP(82).EQ.3) THEN
20622 PHIGHB=PIK*0.5*EXP(-BDIV**2)
20623 ELSEIF(MSTP(82).EQ.4) THEN
20624 S4A=P83A*EXP(-BDIV**2)
20625 S4B=P83B*EXP(-BDIV**2*CQ2R)
20626 S4C=P83C*EXP(-BDIV**2*CQ2I)
20627 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
20628 ELSEIF(PARP(83).GE.1.999D0) THEN
20634 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
20638 C...Initialize iteration in xT2 for hardest interaction.
20639 ELSEIF(MMUL.EQ.2) THEN
20643 IF(MSTP(82).LE.0) THEN
20644 ELSEIF(MSTP(82).EQ.1) THEN
20646 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20647 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20648 & VINT(317)/(VINT(318)*VINT(320))
20649 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20650 ELSEIF(MSTP(82).EQ.2) THEN
20652 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20653 & VINT(149)*(1D0+VINT(149))
20655 XC2=4D0*CKIN(3)**2/VINT(2)
20656 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
20659 C...Select impact parameter for hardest interaction.
20660 IF(MSTP(82).LE.2) RETURN
20661 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
20662 C...Treatment in low b region.
20664 B=BDIV*SQRT(PYR(0))
20665 IF(MSTP(82).EQ.3) THEN
20666 OV=EXP(-B**2)/PARU(2)
20667 ELSEIF(MSTP(82).EQ.4) THEN
20668 OV=(P83A*EXP(-MIN(50D0,B**2))+
20669 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20670 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20672 OV=EXP(-B**POWIP)/PARU(2)
20674 VINT(148)=OV/VNT147
20675 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
20677 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20678 & VINT(149)*(1D0+VINT(149))
20680 C...Treatment in high b region.
20682 IF(MSTP(82).EQ.3) THEN
20683 B=SQRT(BDIV**2-LOG(PYR(0)))
20684 OV=EXP(-B**2)/PARU(2)
20685 ELSEIF(MSTP(82).EQ.4) THEN
20686 S4RNDM=PYR(0)*(S4A+S4B+S4C)
20687 IF(S4RNDM.LT.S4A) THEN
20688 B=SQRT(BDIV**2-LOG(PYR(0)))
20689 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
20690 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
20692 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
20694 OV=(P83A*EXP(-MIN(50D0,B**2))+
20695 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20696 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20697 ELSEIF(PARP(83).GE.1.999D0) THEN
20698 144 B2RPW=B2RPDV-LOG(PYR(0))
20699 ACCIP=(B2RPW/B2RPDV)**RPWIP
20700 IF(ACCIP.LT.PYR(0)) GOTO 144
20701 OV=EXP(-B2RPW)/PARU(2)
20702 B=B2RPW**(1D0/POWIP)
20704 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
20705 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
20706 IF(ACCIP.LT.PYR(0)) GOTO 146
20707 OV=EXP(-B2RPW)/PARU(2)
20708 B=B2RPW**(1D0/POWIP)
20710 VINT(148)=OV/VNT147
20711 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
20713 IF(PACC.LT.PYR(0)) GOTO 142
20716 ELSEIF(MMUL.EQ.3) THEN
20717 C...Low-pT or multiple interactions (first semihard interaction):
20718 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
20719 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
20724 IF(MSTP(82).LE.0) THEN
20726 ELSEIF(MSTP(82).EQ.1) THEN
20727 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20728 C...Use with "Sudakov" for low b values when impact parameter dependence.
20729 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
20730 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
20731 & VINT(149)))).GT.PYR(0)) XT2=1D0
20732 IF(XT2.GE.1D0) THEN
20733 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
20734 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
20737 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
20738 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
20741 XT2=MAX(0.01D0*VINT(149),XT2)
20742 C...Use without "Sudakov" for high b values when impact parameter dep.
20744 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
20745 & PYR(0)*(1D0-XC2))-VINT(149)
20746 XT2=MAX(0.01D0*VINT(149),XT2)
20750 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
20751 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
20752 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
20753 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
20756 VINT(21)=1D-12*VINT(149)
20759 VINT(25)=1D-12*VINT(149)
20762 C...Multiple interactions (first semihard interaction).
20763 C...Choose tau and y*. Calculate cos(theta-hat).
20764 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20765 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20766 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20768 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20774 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20775 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20776 CALL PYKMAP(2,MYST,PYR(0))
20777 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20779 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
20781 C...Store results of cross-section calculation.
20782 ELSEIF(MMUL.EQ.4) THEN
20788 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
20789 IF(ISET(ISUB).EQ.2)
20790 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20791 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
20792 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
20793 & (XTS+VINT(149))))
20794 IRBIN=INT(1D0+20D0*RBIN)
20795 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
20796 NMUL(IRBIN)=NMUL(IRBIN)+1
20797 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
20800 C...Choose impact parameter if not already done.
20801 ELSEIF(MMUL.EQ.5) THEN
20806 150 IF(MINT(39).GT.0) THEN
20807 ELSEIF(MSTP(82).EQ.3) THEN
20810 VINT(148)=EXPB2/(PARU(2)*VNT147)
20811 VINT(139)=SQRT(B2)/BAVG
20812 ELSEIF(MSTP(82).EQ.4) THEN
20814 IF(RTYPE.LT.P83A) THEN
20816 ELSEIF(RTYPE.LT.P83A+P83B) THEN
20817 B2=-LOG(PYR(0))/CQ2R
20819 B2=-LOG(PYR(0))/CQ2I
20821 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
20822 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
20823 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
20824 VINT(139)=SQRT(B2)/BAVG
20825 ELSEIF(PARP(83).GE.1.999D0) THEN
20826 POWIP=MAX(2D0,PARP(83))
20827 RPWIP=2D0/POWIP-1D0
20828 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
20829 160 IF(PYR(0).LT.PROB1) THEN
20830 B2RPW=PYR(0)**(0.5D0*POWIP)
20833 B2RPW=1D0-LOG(PYR(0))
20836 IF(ACCIP.LT.PYR(0)) GOTO 160
20837 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20838 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20840 POWIP=MAX(0.4D0,PARP(83))
20841 RPWIP=2D0/POWIP-1D0
20842 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
20843 170 IF(PYR(0).LT.PROB1) THEN
20844 B2RPW=2D0*RPWIP*PYR(0)
20845 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
20847 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
20848 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
20850 IF(ACCIP.LT .PYR(0)) GOTO 170
20851 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20852 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20855 C...Multiple interactions (variable impact parameter) : reject with
20856 C...probability exp(-overlap*cross-section above pT/normalization).
20857 C...Does not apply to low-b region, where "Sudakov" already included.
20859 IF(MINT(39).NE.1) THEN
20860 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
20861 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
20862 DO 180 IBIN=IRBIN+1,20
20863 RNCOR=RNCOR+NMUL(IBIN)
20864 SIGCOR=SIGCOR+SIGM(IBIN)
20866 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
20867 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
20868 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
20869 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
20871 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
20872 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
20873 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20874 IF(VINT(150).LT.PYR(0)) GOTO 150
20878 C...Generate additional multiple semihard interactions.
20879 ELSEIF(MMUL.EQ.6) THEN
20881 C...Save data for hardest initeraction, to be restored.
20898 C...Store data on hardest interaction.
20905 C...Change process to generate; sum of x values so far.
20908 VINT(143)=1D0-VINT(141)
20909 VINT(144)=1D0-VINT(142)
20913 C...Initialize factors for PDF reshaping.
20917 KFSBM=ISIGN(1,KFBEAM)
20919 C...Zero flavour content of incoming beam particle.
20923 C...Flavour content of baryon.
20924 IF(KFABM.GT.1000) THEN
20925 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
20926 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
20927 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
20928 C...Flavour content of pi+-, K+-.
20929 ELSEIF(KFABM.EQ.211) THEN
20930 KFIVAL(JS,1)=KFSBM*2
20931 KFIVAL(JS,2)=-KFSBM
20932 ELSEIF(KFABM.EQ.321) THEN
20933 KFIVAL(JS,1)=-KFSBM*3
20934 KFIVAL(JS,2)=KFSBM*2
20935 C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
20938 C...Zero initial valence and companion content.
20943 C...Initiate listing of all incoming partons from two sides.
20945 DO 210 I=MINT(84)+1,N
20946 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
20952 C...Decide whether quarks in hard scattering were valence or sea.
20953 IFL=K(IMI(JS,1,1),2)
20954 IF (IABS(IFL).GT.6) GOTO 230
20956 C...Get PDFs at X and Q2 of the parton shower initiator for the
20957 C...hard scattering.
20959 IF(MSTP(61).GE.1) THEN
20964 C...Note: XPSVC = x*pdf.
20967 C.... Store side in MINT(124)
20970 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20974 C...Decide (Extra factor x cancels in the division).
20975 RVCS=PYR(0)*(SEA+VAL)
20977 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20978 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20980 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20981 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20982 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20983 IF(KFIVAL(JS,1).EQ.0) THEN
20984 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20985 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20986 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20987 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20989 IF(IVNOW.EQ.0) GOTO 220
20992 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20993 IF(KFIVAL(JS,1).EQ.0) THEN
20994 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20997 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
20999 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21000 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21004 C...If sea, add opposite sign companion parton. Store X and I.
21006 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21007 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21008 C...Set pointer to companion
21009 IMI(JS,1,2)=-NVC(JS,-IFL)
21013 C...Update counter number of multiple interactions.
21017 C...Set up starting values for iteration in xT2.
21018 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
21019 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
21020 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
21021 & ISUBSV.NE.96)) THEN
21022 XT2=(1D0-VINT(141))*(1D0-VINT(142))
21025 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
21026 IF(ISET(ISUBSV).EQ.2)
21027 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
21028 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
21030 IF(MSTP(82).LE.1) THEN
21031 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
21032 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
21033 & VINT(317)/(VINT(318)*VINT(320))
21034 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
21036 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
21037 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
21042 C...Iterate downwards in xT2.
21043 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
21046 ELSEIF(MSTP(82).LE.1) THEN
21047 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
21048 IF(XT2.LT.VINT(149)) GOTO 440
21050 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
21051 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
21052 & LOG(PYR(0)))-VINT(149)
21053 IF(XT2.LE.0D0) GOTO 440
21054 XT2=MAX(0.01D0*VINT(149),XT2)
21058 C...Choose tau and y*. Calculate cos(theta-hat).
21059 IF(PYR(0).LE.COEF(ISUB,1)) THEN
21060 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
21061 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
21063 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
21066 C...New: require shat > 1.
21067 IF(TAU*VINT(2).LT.1D0) GOTO 240
21071 IF(RYST.GT.COEF(ISUB,8)) MYST=2
21072 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21073 CALL PYKMAP(2,MYST,PYR(0))
21074 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21076 C...Check that x not used up. Accept or reject kinematical variables.
21077 X1M=SQRT(TAU)*EXP(VINT(22))
21078 X2M=SQRT(TAU)*EXP(-VINT(22))
21079 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
21080 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
21081 CALL PYSIGH(NCHN,SIGS)
21082 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
21083 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
21084 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
21086 C...Reset K, P and V vectors.
21094 PT=0.5D0*VINT(1)*SQRT(XT2)
21096 C...Choose flavour of reacting partons (and subprocess).
21101 ICONMI=ISIG(ICHN,3)
21102 RSIGS=RSIGS-SIGH(ICHN)
21103 IF(RSIGS.LE.0D0) GOTO 280
21106 C...Reassign to appropriate process codes.
21107 280 ISUBMI=ICONMI/10
21108 ICONMI=MOD(ICONMI,10)
21110 C...Choose new quark flavour for annihilation graphs
21111 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
21113 CALL PYWIDT(21,SH,WDTP,WDTE)
21114 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
21115 DO 300 I=1,MDCY(21,3)
21116 KFLF=KFDP(I+MDCY(21,2)-1,1)
21117 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
21118 IF(RKFL.LE.0D0) GOTO 310
21120 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
21121 IF(KFLF.GE.4) GOTO 290
21122 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
21125 ELSEIF(ISUBMI.EQ.53) THEN
21131 C...Final state flavours and colour flow: default values
21138 IF(ISUBMI.EQ.11) THEN
21139 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
21141 IF(KFL1*KFL2.LT.0) KCC=KCC+2
21143 ELSEIF(ISUBMI.EQ.12) THEN
21144 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
21145 KFL3=ISIGN(KFLF,KFL1)
21149 ELSEIF(ISUBMI.EQ.13) THEN
21150 C...f + fbar -> g + g; th arbitrary
21155 ELSEIF(ISUBMI.EQ.28) THEN
21156 C...f + g -> f + g; th = (p(f)-p(f))**2
21157 IF(KFL1.EQ.21) JS=2
21159 IF(KFL1.EQ.21) KCC=KCC+2
21160 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
21161 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
21163 ELSEIF(ISUBMI.EQ.53) THEN
21164 C...g + g -> f + fbar; th arbitrary
21165 KCS=(-1)**INT(1.5D0+PYR(0))
21166 KFL3=ISIGN(KFLF,KCS)
21170 ELSEIF(ISUBMI.EQ.68) THEN
21171 C...g + g -> g + g; th arbitrary
21173 KCS=(-1)**INT(1.5D0+PYR(0))
21176 C...Store flavours of scattering.
21184 C...Set flavours and mothers of scattering partons.
21193 K(N+1,3)=MINT(83)+1
21194 K(N+2,3)=MINT(83)+2
21198 C...Store colour connection indices.
21201 IF(KCS.EQ.-1) JC=3-J
21202 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
21203 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
21204 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
21205 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
21208 C...Store incoming and outgoing partons in their CM-frame.
21209 SHR=SQRT(TAU)*VINT(1)
21212 P(N+2,3)=-0.5D0*SHR
21214 P(N+3,5)=PYMASS(K(N+3,2))
21215 P(N+4,5)=PYMASS(K(N+4,2))
21216 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
21217 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
21218 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
21219 P(N+4,4)=SHR-P(N+3,4)
21222 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
21224 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
21226 C...Set up default values before showers.
21227 MINT(31)=MINT(31)+1
21236 C...Showering of initial state partons (optional).
21237 C...Note: no showering of final state partons here; it comes later.
21238 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21245 KSAV(I,J)=K(N-4+I,J)
21246 PSAV(I,J)=P(N-4+I,J)
21249 CALL PYSSPA(IPU1,IPU2)
21251 C...If shower failed then restore to situation before shower.
21252 IF(MINT(51).GE.1) THEN
21256 K(N-4+I,J)=KSAV(I,J)
21257 P(N-4+I,J)=PSAV(I,J)
21267 C...Keep track of loose colour ends and information on scattering.
21268 370 IMI(1,MINT(31),1)=IPU1
21269 IMI(2,MINT(31),1)=IPU2
21270 IMI(1,MINT(31),2)=0
21271 IMI(2,MINT(31),2)=0
21272 XMI(1,MINT(31))=VINT(141)
21273 XMI(2,MINT(31))=VINT(142)
21274 PT2MI(MINT(31))=VINT(54)
21277 C...Decide whether quarks in last scattering were valence, companion or
21281 KFSBM=ISIGN(1,MINT(10+JS))
21282 IFL=K(IMI(JS,MINT(31),1),2)
21283 IMI(JS,MINT(31),2)=0
21284 IF (IABS(IFL).GT.6) GOTO 430
21286 C...Get PDFs at X and Q2 of the parton shower initiator for the
21287 C...last scattering. At this point VINT(143:144) do not yet
21288 C...include the scattered x values VINT(141:142).
21289 X=VINT(140+JS)/VINT(142+JS)
21290 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21295 C...Note: XPSVC = x*pdf.
21298 C.... Store side in MINT(124)
21301 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
21305 DO 380 IVC=1,NVC(JS,IFL)
21306 CMP=CMP+XPSVC(IFL,IVC)
21309 C...Decide (Extra factor x cancels in the dvision).
21310 RVCS=PYR(0)*(SEA+VAL+CMP)
21312 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
21313 C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21315 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
21316 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
21317 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
21318 IF(KFIVAL(JS,1).EQ.0) THEN
21319 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
21320 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
21321 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
21322 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
21324 DO 400 I1=1,NMI(JS)
21325 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
21329 IF(IVNOW.EQ.0) GOTO 390
21331 IMI(JS,MINT(31),2)=0
21332 C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21333 IF(KFIVAL(JS,1).EQ.0) THEN
21334 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21337 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21339 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21340 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21344 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
21345 C...If sea, add opposite sign companion parton. Store X and I.
21346 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21347 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21348 C...Set pointer to companion
21349 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
21351 C...If companion, decide which one.
21355 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
21356 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
21357 C...Find original sea (anti-)quark:
21359 DO 420 I1=1,NMI(JS)
21360 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
21361 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
21362 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
21363 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
21366 C...Change X to what associated companion had, so that the correct
21367 C...amount of momentum can be subtracted from the companion sum below.
21368 X=XASSOC(JS,IFL,ISEL)
21369 C...Mark companion read.
21370 XASSOC(JS,IFL,ISEL)=0D0
21374 C...Global statistics.
21375 MINT(351)=MINT(351)+1
21376 VINT(351)=VINT(351)+PT
21377 IF (MINT(351).EQ.1) VINT(356)=PT
21379 C...Update remaining energy and other counters.
21380 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
21381 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
21387 VINT(151)=VINT(151)+VINT(41)
21388 VINT(152)=VINT(152)+VINT(42)
21389 VINT(143)=VINT(143)-VINT(141)
21390 VINT(144)=VINT(144)-VINT(142)
21392 C...Iterate, with more interactions allowed.
21393 IF(MINT(31).LT.240) GOTO 240
21396 C...Restore saved quantities for hardest interaction.
21412 C...Format statements for printout.
21413 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
21414 &'actions for MSTP(82) =',I2,' ******')
21415 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21416 &D9.2,' mb: rejected')
21417 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21418 &D9.2,' mb: accepted')
21423 C*********************************************************************
21426 C...Finds left-behind remnant flavour content and hooks up
21427 C...the colour flow between the hard scattering and remnants
21431 C...Double precision and integer declarations.
21432 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21433 IMPLICIT INTEGER(I-N)
21434 INTEGER PYK,PYCHGE,PYCOMP
21435 C...The event record
21436 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21438 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21439 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21440 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21441 COMMON/PYINT1/MINT(400),VINT(400)
21442 C...The common block of dangling ends
21443 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
21444 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
21445 & XMI(2,240),PT2MI(240),IMISEP(0:240)
21446 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
21447 C...Local variables
21448 PARAMETER (NERSIZ=4000)
21449 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
21451 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
21452 SAVE /PYCBLS/,/PYCTAG/
21453 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
21454 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
21457 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)
21459 C...Set up error checkers
21462 C...Initialize colour arrays: MCO (Original) and MCT (New)
21463 DO 110 I=MINT(84)+1,NERSIZ
21468 C...Also zero colour tracing information, if existed.
21470 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21471 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21475 C...Initialize colour tag collapse arrays:
21476 C...JCCO (Original) and JCCN (New).
21477 DO 130 MG=MINT(84)+1,NERSIZ
21484 C...Zero gluon insertion array
21491 C...Compute hard scattering system rapidities
21492 IF (MSTP(89).EQ.1) THEN
21494 IF (IM.LE.MINT(31)) THEN
21495 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
21497 C...Set (unsigned) rapidity = 100 for beam remnant systems.
21503 C...Treat each side separately
21506 C...Initialize side.
21509 KFS=ISIGN(1,MINT(10+JS))
21511 C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
21512 IF(KFIVAL(JS,1).EQ.0) THEN
21513 IF(MINT(10+JS).EQ.111) THEN
21514 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
21515 KFIVAL(JS,2)=-KFIVAL(JS,1)
21516 ELSEIF(MINT(10+JS).EQ.22) THEN
21519 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
21520 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
21521 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
21522 KFIVAL(JS,2)=-KFIVAL(JS,1)
21523 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
21524 IF(PYR(0).GT.0.5D0) THEN
21534 C...Initialize beam remnant sea and valence content flavour by flavour.
21538 C...Count up original number of JFA valence quarks and antiquarks.
21543 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
21544 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
21546 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
21547 C...Subtract kicked out valence and determine sea from flavour cons.
21548 DO 180 IM=1,NMI(JS)
21549 IFL = K(IMI(JS,IM,1),2)
21552 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
21553 C...Subtract K.O. valence quark from remainder.
21555 JV=NVSUM(JS)-NVALQ-NVALQB
21556 IV(JS,JV)=IMI(JS,IM,1)
21557 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
21558 C...Subtract K.O. valence antiquark from remainder.
21560 JV=NVSUM(JS)-NVALQ-NVALQB
21561 IV(JS,JV)=IMI(JS,IM,1)
21562 ELSEIF (IFA.EQ.JFA) THEN
21563 C...Outside sea without companion: add opposite sea flavour inside.
21564 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
21567 C...Check if space left in PYJETS for additional BR flavours
21568 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
21569 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
21570 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
21571 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
21575 C...Add required val+sea content to beam remnant.
21576 IF (NFLSUM.GT.0) THEN
21578 C...Insert beam remnant quark as p.t. symbolic parton in ER.
21586 K(N,2)=ISIGN(JFA,NSEA)
21587 IF (IA.LE.NVALQ) K(N,2)=JFA
21588 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
21590 C...Also update NMI, IMI, and IV arrays.
21592 IMI(JS,NMI(JS),1)=N
21593 IMI(JS,NMI(JS),2)=-1
21594 IF (IA.LE.NVALQ+NVALQB) THEN
21595 IMI(JS,NMI(JS),2)=0
21597 IV(JS,JV)=IMI(JS,NMI(JS),1)
21605 IF (IM.LE.NMI(JS)) THEN
21606 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
21608 C...Add fictitious parent gluons for companion pairs.
21609 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
21610 C...Randomly assign companions to sea quarks which have none.
21611 IF (IMI(JS,IM,2).LT.0) THEN
21613 230 IMC=MOD(IMC,NMI(JS))+1
21614 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
21615 IF (IMI(JS,IMC,2).GE.0) GOTO 230
21616 IMI(JS, IM,2) = IMI(JS,IMC,1)
21617 IMI(JS,IMC,2) = IMI(JS, IM,1)
21619 C...Add fictitious parent gluon
21629 C...Set gluon (anti-)colour daughter pointers
21630 K(N,4)=IMI(JS, IM,1)
21631 K(N,5)=IMI(JS, IM,2)
21632 C...Set quark (anti-)colour parent pointers
21633 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
21634 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
21635 C...Add gluon to IMI
21637 IMI(JS,NMI(JS),1)=N
21638 IMI(JS,NMI(JS),2)=0
21643 C...If incoming (anti-)baryon, insert inside (anti-)junction.
21644 C...Set up initial v-v-j-v configuration. Otherwise set up
21645 C...mesonic v-vbar configuration
21646 IF (IABS(MINT(10+JS)).GT.1000) THEN
21647 C...Determine junction type (1: B=1 2: B=-1)
21648 ITJUNC(JS) = (3-KFS)/2
21649 C...Insert junction.
21656 C...Set special junction codes:
21659 C...Set parent to side.
21661 K(N,4)=ITJUNC(JS)*MSTU(5)
21663 C...Connect valence quarks to junction.
21666 C...Set (anti)colour mother = junction.
21668 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21670 C...Keep track of partons adjacent to junction:
21671 JST(JS,JV)=IV(JS,JV)
21674 C...Mesons: set up initial q-qbar topology
21676 IF (K(IV(JS,1),2).GT.0) THEN
21687 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21688 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21689 C...Special for mesons. Insert gluon if BR empty.
21690 IF (NBRTOT(JS).EQ.0) THEN
21704 C...Add gluon to IMI
21706 IMI(JS,NMI(JS),1)=N
21707 IMI(JS,NMI(JS),2)=0
21712 C...Count up number of valence quarks outside BR.
21714 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
21715 & MOUT(JS)=MOUT(JS)+1
21720 C...Now both sides have been prepared in an initial vvjv (baryonic) or
21721 C...v(g)vbar (mesonic) configuration.
21723 C...Create colour line tags starting from initiators.
21725 DO 320 IM=1,MINT(31)
21726 C...Consider each side in turn.
21731 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
21733 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
21736 CALL PYCTTR(I1,KCS,I2)
21737 IF(MINT(51).NE.0) RETURN
21744 C...Create colour tags for beam remnant partons.
21745 DO 330 IM=MINT(31)+1,NMI(JS)
21747 IF (K(IP,2).NE.21) THEN
21748 JC=(3-ISIGN(1,K(IP,2)))/2
21749 IF (MCT(IP,JC).EQ.0) THEN
21758 C...Fictituous gluons just inherit from their quark daughters.
21762 C...Real beam remnant gluons get their own colours
21773 C...Create colour tags for colour lines which are detached from the
21777 DO 350 I=MINT(84)+1,N
21779 C...Look for coloured string endpoint, or (later) leftover gluon.
21780 IF (K(I,1).NE.3) GOTO 350
21782 IF(KC.EQ.0) GOTO 350
21784 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
21786 C...Pick up loose string end with no previous tag.
21788 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
21789 IF(MCT(I,KCS-3).NE.0) GOTO 350
21791 CALL PYCTTR(I,KCS,I)
21792 IF(MINT(51).NE.0) RETURN
21797 C...Store original colour tags
21798 DO 370 I=MINT(84)+1,N
21803 C...Iteratively add gluons to already existing string pieces, enforcing
21804 C...various possible orderings, and rejecting insertions that would give
21805 C...rise to singlet gluons.
21806 C...<kappa tau> normalization.
21811 C...Set up simplified kinematics.
21812 C...Boost hard interaction systems.
21814 DO 380 IM=1,MINT(31)
21815 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21816 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21818 C...Assign preliminary beam remnant momenta.
21819 DO 390 I=MINT(53)+1,N
21823 IF (K(I,2).NE.88) THEN
21824 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
21826 IF (JS.EQ.2) P(I,3)=-P(I,3)
21828 C...Junctions are wildcards for the present.
21834 C...Reset colour processing information.
21835 400 DO 410 I=MINT(84)+1,N
21836 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21837 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21842 C...If meson, without gluon in BR, collapse q-qbar colour tags:
21843 IF (ITJUNC(JS).EQ.0) THEN
21844 JC1=MCT(JST(JS,1),1)
21845 JC2=MCT(JST(JS,2),2)
21847 JCCO(NCC,1)=MAX(JC1,JC2)
21848 JCCO(NCC,2)=MIN(JC1,JC2)
21849 C...Collapse colour tags in event record
21850 DO 420 I=MINT(84)+1,N
21851 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
21852 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
21858 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
21859 IF (NG(JS).GT.0) THEN
21862 C...Start at random gluon (optimizes speed for random attachments)
21864 IMGL=PYR(0)*NMI(JS)+1
21865 450 IMGL=MOD(IMGL,NMI(JS))+1
21867 C...Only loop through NMI once (with upper limit to save time)
21868 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
21869 IGL = IMI(JS,IMGL,1)
21870 C...If not gluon or if already connected, try next.
21871 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
21872 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
21873 C...Now loop through all possible insertions of this gluon.
21875 IMP1=PYR(0)*NMI(JS)+1
21876 460 IMP1=MOD(IMP1,NMI(JS))+1
21878 IF (IMP1.EQ.IMGL) GOTO 460
21879 C...Only loop through NMI once (with upper limit to save time).
21880 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
21881 IP1 = IMI(JS,IMP1,1)
21882 C...Try both colour mother and colour anti-mother.
21883 C...Randomly select which one to try first.
21886 470 MANTI=MOD(MANTI+1,2)
21888 IF (NANTI.LE.2) THEN
21889 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
21890 C...Reject if no appropriate mother (or if mother is fictitious
21892 IF (IP2.LE.0) GOTO 470
21893 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
21894 C...Also reject if this link has already been tried.
21895 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21896 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21897 C...Set flag to indicate that this link has now been tried for this
21898 C...gluon. IP2 may be junction, which has several mothers.
21899 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
21900 IF (K(IP2,2).NE.88) THEN
21901 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
21904 C...JCG1: Original colour tag of gluon on IP1 side
21905 C...JCG2: Original colour tag of gluon on IP2 side
21906 C...JCP1: Original colour tag of IP1 on gluon side
21907 C...JCP2: Original colour tag of IP2 on gluon side.
21908 JCG1=MCO(IGL,2-MANTI)
21909 JCG2=MCO(IGL,1+MANTI)
21910 JCP1=MCO(IP1,1+MANTI)
21911 JCP2=MCO(IP2,2-MANTI)
21913 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
21914 C...Reject gluon attachments that give rise to singlet gluons.
21915 IF (MACCPT.EQ.0) GOTO 470
21918 JCG1=MCT(IGL,2-MANTI)
21919 JCG2=MCT(IGL,1+MANTI)
21920 JCP1=MCT(IP1,1+MANTI)
21921 JCP2=MCT(IP2,2-MANTI)
21923 C...Select whether to accept this insertion
21924 IF (MSTP(89).EQ.0) THEN
21925 C...Random insertions: no measure.
21927 C...For random ordering, we want to suppress beam remnant breakups
21928 C...already at this point.
21929 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
21930 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
21935 ELSEIF (MSTP(89).EQ.1) THEN
21936 C...Rapidity ordering:
21937 C...YGL = Rapidity of gluon.
21939 C...If fictitious gluon
21940 IF (YGL.EQ.100D0) THEN
21942 IDA1=MOD(K(IGL,4),MSTU(5))
21943 IDA2=MOD(K(IGL,5),MSTU(5))
21944 DO 480 IMT=1,NMI(JS)
21945 C...Select (arbitrarily) the most central daughter.
21946 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21948 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
21952 C...YP1 = Rapidity IP1
21954 C...If fictitious gluon
21955 IF (YP1.EQ.100D0) THEN
21957 IDA1=MOD(K(IP1,4),MSTU(5))
21958 IDA2=MOD(K(IP1,5),MSTU(5))
21959 DO 490 IMT=1,NMI(JS)
21960 C...Select (arbitrarily) the most central daughter.
21961 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21963 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
21967 C...YP2 = Rapidity of mother system
21968 IF (K(IP2,2).NE.88) THEN
21969 DO 500 IMT=1,NMI(JS)
21970 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
21972 C...If fictitious gluon
21973 IF (YP2.EQ.100D0) THEN
21975 IDA1=MOD(K(IP2,4),MSTU(5))
21976 IDA2=MOD(K(IP2,5),MSTU(5))
21977 DO 510 IMT=1,NMI(JS)
21978 C...Select (arbitrarily) the most central daughter.
21979 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
21981 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
21985 C...Assign (arbitrarily) 100D0 to junction also
21989 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
21990 ELSEIF (MSTP(89).EQ.2) THEN
21991 C...Lambda ordering:
21992 C...Compute lambda measure for this insertion.
21997 C...If IP2 is junction, not caught below.
21998 IF (JCP2.EQ.0) THEN
21999 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
22000 C...Anti-junction is colour endpoint et vv., always on JCG2.
22003 DO 530 I=MINT(84)+1,N
22004 IF (K(I,1).LT.10) THEN
22005 C...The new string pieces
22006 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
22007 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
22008 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
22009 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
22012 C...Also identify junctions as string endpoints.
22013 DO 540 I=MINT(84)+1,N
22014 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
22015 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
22016 C...Find partons adjacent to junctions.
22017 IF (ICMO.GT.0.AND.ICMO.LE.N) THEN
22018 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
22019 & .EQ.0) ISTR(2) = ICMO
22020 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
22021 & .EQ.0) ISTR(4) = ICMO
22023 IF (IAMO.GT.0.AND.IAMO.LE.N) THEN
22024 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
22025 & .EQ.0) ISTR(1) = IAMO
22026 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
22027 & .EQ.0) ISTR(3) = IAMO
22030 C...The old string piece
22031 ISTR(5)=ISTR(1+2*MANTI)
22032 ISTR(6)=ISTR(4-2*MANTI)
22033 IF (ISTR(1).EQ.0.OR.ISTR(2).EQ.0.OR.ISTR(3).EQ.0.OR.
22034 & ISTR(4).EQ.0.OR.ISTR(5).EQ.0.OR.ISTR(6).EQ.0) THEN
22035 C...If one or more of the colour tags for this connection is/are still
22036 C...dangling, skip this attempt for the time being.
22039 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
22040 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
22044 C...Allow some breadth to speed things up.
22045 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
22047 ELSEIF (RL.GT.RLOPT) THEN
22053 C...INSR(NOPT,1)=Gluon colour mother
22054 C...INSR(NOPT,2)=Gluon
22055 C...INSR(NOPT,3)=Gluon anticolour mother
22056 IF (NOPT.GT.1000) GOTO 470
22057 INSR(NOPT,1+2*MANTI)=IP2
22059 INSR(NOPT,3-2*MANTI)=IP1
22060 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
22062 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
22064 C...Reset link test information.
22065 DO 550 I=MINT(84)+1,N
22066 K(I,4)=MOD(K(I,4),MSTU(5)**2)
22067 K(I,5)=MOD(K(I,5),MSTU(5)**2)
22069 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
22071 C...Now we have a list of best gluon insertions, none of which cause
22072 C...singlets to arise. If list is empty, try again a few times. Note:
22073 C...this should never happen if we have a meson with a gluon inserted
22074 C...in the beam remnant, since that breaks up the colour line.
22075 IF (NOPT.EQ.0) THEN
22076 C...Abandon BR-g-BR suppression for retries. This is not serious, it
22077 C...just means we happened to start with trying a bad sequence.
22079 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
22080 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
22083 IF (ITJUNC(JS).NE.0) THEN
22087 C...Reset valence quark parent pointers
22088 DO 560 I=MINT(53)+1,N
22089 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
22092 C...Set (anti)colour mother = junction.
22094 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
22098 C...Same for mesons. JST unchanged, so needn't be restored.
22101 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
22102 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
22104 C...Also reset gluon parent pointers.
22106 DO 580 IM=1,NMI(JS)
22108 IF (K(I,2).EQ.21) THEN
22109 K(I,4)=MOD(K(I,4),MSTU(5))
22110 K(I,5)=MOD(K(I,5),MSTU(5))
22115 C...Reset colour tags
22116 DO 600 I=MINT(84)+1,N
22122 IF(NERRPR.LT.5) THEN
22125 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
22126 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
22128 C...Kill event and start another.
22133 C...Select between insertions, suppressing insertions wholly in the BR.
22135 610 IIN=MOD(IIN,NOPT)+1
22136 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
22137 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
22140 C...Now we know which gluon to insert where. Colour tags in JCCO and
22141 C...colour connection information should be updated, NG(JS) should be
22142 C...counted down, and a new loop performed if there are still gluons
22143 C...left on any side.
22147 C...JCG : Original gluon colour tag
22148 C...JCAG: Original gluon anticolour tag.
22149 C...JCM : Original anticolour tag of gluon colour mother
22150 C...JACM: Original colour tag of gluon anticolour mother
22156 CALL PYMIHG(JACM,JACG,JCM,JCG)
22157 IF (MACCPT.EQ.0) THEN
22158 IF(NERRPR.LT.5) THEN
22161 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
22162 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
22164 C...Kill event and start another.
22168 C...If everything went fine, store new JCCN in JCCO.
22171 JCCO(ICC,1)=JCCN(ICC,1)
22172 JCCO(ICC,2)=JCCN(ICC,2)
22176 C...One gluon attached is counted as equivalent to one end outside.
22178 C...Set IGL colour mother = ICM.
22179 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
22180 C...Set ICM anticolour mother = IGL colour.
22181 IF (K(ICM,2).NE.88) THEN
22182 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
22184 C...If ICM is junction, just update JST array for now.
22186 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
22189 C...Set IGL anticolour mother = IACM.
22190 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
22191 C...Set IACM anticolour mother = IGL anticolour.
22192 IF (K(IACM,2).NE.88) THEN
22193 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
22195 C...If IACM is junction, just update JST array for now.
22197 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
22200 C...Count down # unconnected gluons.
22203 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
22206 C...Collapse fictitious gluons.
22207 DO 670 IGL=MINT(53)+1,N
22208 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
22209 & K(IGL,1).EQ.14) THEN
22210 ICM=K(IGL,4)/MSTU(5)
22211 IAM=K(IGL,5)/MSTU(5)
22212 ICD=MOD(K(IGL,4),MSTU(5))
22213 IAD=MOD(K(IGL,5),MSTU(5))
22214 C...Set gluon daughters pointing to gluon mothers
22215 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
22216 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
22217 C...Set gluon mothers pointing to gluon daughters.
22218 IF (K(ICM,2).NE.88) THEN
22219 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
22221 C...Special case: mother=junction. Just update JST array for now.
22223 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
22226 IF (K(IAM,2).NE.88) THEN
22227 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
22230 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
22236 C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
22239 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
22240 IF (IM.GT.MINT(31)) THEN
22242 DO 690 IMR=IM,NMI(JS)
22243 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
22244 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
22249 C...Finally, connect junction.
22250 IF (ITJUNC(JS).NE.0) THEN
22251 DO 700 I=MINT(53)+1,N
22252 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
22254 C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
22259 C...Find jq with no glue inbetween inside beam remnant.
22260 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
22263 C...Set IDQ = -I if q non-valence and = +I if q valence.
22264 IDQ(NBRJQ)=-JST(JS,MSJ)
22266 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
22267 IDQ(NBRJQ)=JST(JS,MSJ)
22274 IF (MSJ.EQ.3) I45=4
22275 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
22278 C...Check if diquark can be formed.
22279 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
22281 C...If there is less than 2 valence quarks connected to junction
22282 C...and MSTP(88)>1, use random non-valence quarks to fill up.
22283 IF (NBRVQ.LE.1) THEN
22285 730 JFLIP=NBRJQ*PYR(0)+1
22286 IF (IDQ(JFLIP).LT.0) THEN
22287 IDQ(JFLIP)=-IDQ(JFLIP)
22290 IF (NDIQ.LE.1) GOTO 730
22292 C...Place selected quarks first in IDQ, ordered in flavour.
22294 IF (IDQ(JDQ).LE.0) THEN
22298 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
22305 C...Choose diquark spin.
22306 IF (NBRVQ.EQ.2) THEN
22307 C...If the selected quarks are both valence, we may use SU(6) rules
22308 C...to figure out which spin the diquark has, by a subdivision of the
22309 C...original beam hadron into the selected diquark system plus a kicked
22310 C...out quark, IKO.
22314 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
22318 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
22320 C...If one or more of the selected quarks are not valence, we cannot use
22321 C...SU(6) subdivisions of the original beam hadron. Instead, with the
22322 C...flavours of the diquark already selected, we assume for now
22323 C...50:50 spin-1:spin-0 (where spin-0 possible).
22324 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
22326 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
22327 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
22328 KFDQ=KFDQ+ISIGN(IS,KFDQ)
22331 C...Collapse diquark-j-quark system to baryon, if allowed and possible.
22332 C...Note: third quark can per definition not also be valence,
22333 C...therefore we can only do this if we are allowed to use sea quarks.
22334 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
22337 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
22338 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
22340 ELSEIF(NTRY.GT.100) THEN
22341 C...If no baryon can be found, give up and form diquark.
22345 C...Replace junction by baryon.
22348 K(IJU,3)=MINT(83)+JS
22351 P(IJU,5)=PYMASS(KFBAR)
22353 C...Prepare removal of participating quarks from ER.
22354 K(JST(JS,MSJ),1)=-1
22358 C...If collapse to baryon not possible or not allowed, replace junction
22359 C...by diquark. This way, collapsed gluons that were pointing at the
22360 C...junction will now point (correctly) at diquark.
22364 K(IJU,3)=MINT(83)+JS
22369 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
22371 K(IJU,5-MANTI)=IP*MSTU(5)
22372 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
22374 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
22376 C...Prepare removal of participating quarks from ER.
22382 C...Update so ER pointers to collapsed quarks
22383 C...now go to collapsed object.
22384 DO 820 I=MINT(84)+1,N
22385 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
22386 & .K(I,1).GT.0) THEN
22388 IMO=K(I,ISID)/MSTU(5)
22389 IDA=MOD(K(I,ISID),MSTU(5))
22391 IF (K(IMO,1).EQ.-1) IMO=IJU
22394 IF (K(IDA,1).EQ.-1) IDA=IJU
22396 K(I,ISID)=IDA+MSTU(5)*IMO
22403 C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
22404 C...(this only happens for baryons, where we want to force the gluon
22405 C...to sit next to the junction. Mesons handled above.)
22406 IF (NBRTOT(JS).EQ.0) THEN
22416 K(IGL,3)=MINT(83)+JS
22417 IF (ITJUNC(JS).NE.0) THEN
22418 C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
22419 JLEG=PYR(0)*NVSUM(JS)+1
22422 JCT=MCT(I1,ITJUNC(JS))
22423 MCT(IGL,3-ITJUNC(JS))=JCT
22425 MCT(IGL,ITJUNC(JS))=NCT
22428 C...Meson. Should not happen.
22429 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
22430 IF(NERRPR.LT.5) THEN
22431 WRITE(MSTU(11),*) 'This should not have been possible!'
22438 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
22439 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
22440 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
22441 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
22442 IF (K(I2,2).NE.88) THEN
22443 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
22445 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
22446 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
22447 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
22448 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
22450 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
22456 C...Remove collapsed quarks and junctions from ER and update IMI.
22459 C...Also update beam remnant part of IMI.
22462 DO 850 I=MINT(53)+1,N
22463 IF (K(I,1).LE.0) GOTO 850
22464 C...Restore BR quark/diquark/baryon pointers in IMI.
22465 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
22468 IMI(JS,NMI(JS),1)=I
22469 IMI(JS,NMI(JS),2)=0
22473 C...Restore companion information from collapsed gluons.
22474 DO 870 I=MINT(53)+1,N
22475 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
22477 JCD=MOD(K(I,4),MSTU(5))
22478 JAD=MOD(K(I,5),MSTU(5))
22479 DO 860 IM=1,NMI(JS)
22480 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
22481 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
22483 IMI(JS,IMC,2)=IMI(JS,IMA,1)
22484 IMI(JS,IMA,2)=IMI(JS,IMC,1)
22488 C...Renumber colour lines (since some have disappeared)
22496 IF (MFOUND.EQ.0) JCD=JCD+1
22497 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
22500 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
22504 IF (I.LE.N) GOTO 890
22505 IF (JCT.LT.NCT) GOTO 880
22508 C...Reset hard interaction subsystems to their CM frames.
22509 IF (IBOOST.EQ.1) THEN
22510 DO 900 IM=1,MINT(31)
22511 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22512 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
22514 C...Zero beam remnant longitudinal momenta and energies
22515 DO 910 I=MINT(53)+1,N
22521 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
22522 C...Kill event and start another.
22529 C*********************************************************************
22532 C...Adapted from PYPREP.
22533 C...Assigns LHA1 colour tags to coloured partons based on
22534 C...K(I,4) and K(I,5) colour connection record.
22535 C...KCS negative signifies that a previous tracing should be continued.
22536 C...(in case the tag to be continued is empty, the routine exits)
22537 C...Starts at I and ends at I or IEND.
22538 C...Special considerations for systems with junctions.
22539 C...Special: if IEND=-1, means trace this parton to its color partner,
22540 C... then exit. If no partner found, exit with 0.
22542 SUBROUTINE PYCTTR(I,KCS,IEND)
22543 C...Double precision and integer declarations.
22544 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22545 INTEGER PYK,PYCHGE,PYCOMP
22547 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22548 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22549 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22550 COMMON/PYINT1/MINT(400),VINT(400)
22551 C...The common block of colour tags.
22552 COMMON/PYCTAG/NCT,MCT(4000,2)
22553 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
22557 C...Skip if parton not existing or does not have KCS
22558 IF (K(I,1).LE.0) GOTO 120
22560 IF (KC.EQ.0) GOTO 120
22562 IF (KQ.EQ.0) GOTO 120
22563 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
22568 C...Set colour tag of first parton.
22574 IF (NCS.EQ.0) GOTO 120
22580 IF(NSTP.GT.4*N) THEN
22581 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
22585 C...Finished if reached final-state triplet.
22586 IF(K(IA,1).EQ.3) THEN
22587 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
22590 C...Also finished if reached junction.
22591 IF(K(IA,1).EQ.42) THEN
22595 C...GOTO next parton in colour space.
22597 C...If IB's KCS daughter not traced and exists, goto KCS daughter.
22598 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
22600 IA=MOD(K(IB,KCS),MSTU(5))
22601 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
22604 C...If KCS mother traced or KCS mother nonexistent, switch colour.
22605 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
22606 & MSTU(5)).EQ.0) THEN
22610 C...Assign new colour tag on other side of old parton.
22613 C...Goto (new) KCS mother, set mother traced tag
22614 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
22615 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
22618 IF(IA.LE.0.OR.IA.GT.N) THEN
22619 IF (IEND.EQ.-1) THEN
22623 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
22624 IF(NERRPR.LT.5) THEN
22625 write(*,*) 'began at ',I
22626 write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
22627 & ' NCS=',NCS,' MREV=',MREV
22634 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
22635 & MSTU(5)).EQ.IB) THEN
22636 IF(MREV.EQ.1) KCS=9-KCS
22637 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
22638 C...Set KSC mother traced tag for IA
22639 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
22641 IF(MREV.EQ.0) KCS=9-KCS
22642 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
22643 C...Set KCS daughter traced tag for IA
22644 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
22646 C...Assign new colour tag
22648 C...Finish if IEND=-1 and found final-state color partner
22649 IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN
22653 IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100
22658 *********************************************************************
22661 C...Collapse JCP1 and connecting tags to JCG1.
22662 C...Collapse JCP2 and connecting tags to JCG2.
22664 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
22665 C...Double precision and integer declarations.
22666 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22667 IMPLICIT INTEGER(I-N)
22668 INTEGER PYK,PYCHGE,PYCOMP
22669 C...The event record
22670 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22672 COMMON/PYINT1/MINT(400),VINT(400)
22673 SAVE /PYJETS/,/PYINT1/
22674 C...Local variables
22675 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
22676 COMMON /PYCTAG/NCT,MCT(4000,2)
22677 SAVE /PYCBLS/,/PYCTAG/
22679 C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
22680 C...in temporary tag collapse array JCCN. Only break up one connection.
22684 JCCN(ICC,1)=JCCO(ICC,1)
22685 JCCN(ICC,2)=JCCO(ICC,2)
22686 C...If there was a mother, it was previously connected to JCP1.
22687 C...Should be changed to JCP2.
22688 IF (MCLPS.EQ.0) THEN
22689 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
22691 JCCN(ICC,1)=MAX(JCG2,JCP2)
22692 JCCN(ICC,2)=MIN(JCG2,JCP2)
22697 C...Also collapse colours on JCP1 side of JCG1
22698 IF (JCP1.NE.0) THEN
22699 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
22700 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
22702 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
22703 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
22706 C...Initialize event record colour tag array MCT array to MCO.
22707 DO 110 I=MINT(84)+1,N
22713 C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
22714 C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
22715 C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
22716 C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
22718 C...Skip if junction.
22719 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
22720 C...Define starting point in tag space.
22721 C...JCA = previous tag
22722 C...JCO = present tag
22724 IF (MOD(IS,2).EQ.1) THEN
22728 ELSEIF (MOD(IS,2).EQ.0) THEN
22734 120 ITRACE=ITRACE+1
22735 IF (ITRACE.GT.1000) THEN
22736 C...NB: Proper error message should be defined here.
22738 & ,'(PYMIHG:) Inf loop when collapsing colours.')
22739 MINT(57)=MINT(57)+1
22743 C...Collapse all JCN tags to JCALL
22744 DO 130 I=MINT(84)+1,N
22745 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22746 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22748 C...IS = 1,2: first step forward. IS = 3,4: first step backward.
22749 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
22756 C...If possible, step from JCO to new tag JCN not equal to JCA.
22758 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
22760 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
22763 C...Iterate if new colour was arrived at, but don't go in circles.
22764 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
22765 C...Change all JCN tags in MCO to JCALL in MCT.
22766 DO 150 I=MINT(84)+1,N
22767 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22768 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22769 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22770 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22775 DO 200 JCL=NCT,1,-1
22780 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
22782 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
22785 C...Overpaint all JCN with JCL
22786 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
22787 DO 190 I=MINT(84)+1,N
22788 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
22789 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
22790 C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22791 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22802 C*********************************************************************
22805 C...Picks primordial kT and shares longitudinal momentum among
22810 C...Double precision and integer declarations.
22811 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22812 IMPLICIT INTEGER(I-N)
22813 INTEGER PYK,PYCHGE,PYCOMP
22814 C...The event record
22815 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22817 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22818 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22819 COMMON/PYINT1/MINT(400),VINT(400)
22820 C...The common block of colour tags.
22821 COMMON/PYCTAG/NCT,MCT(4000,2)
22822 C...The common block of dangling ends
22823 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
22824 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
22825 & XMI(2,240),PT2MI(240),IMISEP(0:240)
22826 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
22827 C...Local variables
22828 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
22829 C...W(I,J)| J=0 | 1 | 2 |
22830 C... I=0 | Wrem**2 | W+ | W- |
22831 C... 1 | W1**2 | W1+ | W1- |
22832 C... 2 | W2**2 | W2+ | W2- |
22834 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)
22835 C...Tentative parametrization of <kT> as a function of Q.
22836 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
22837 C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
22838 C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
22839 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
22840 C...Lambda kinematic function.
22841 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
22843 C...Beginning and end of beam remnant partons
22847 C...Loopback point if kinematic choices gives impossible configuration.
22851 C...Assign kT values on each side separately.
22854 C...First zero all kT on this side. Skip if no kT to generate.
22855 DO 110 IM=1,NMI(JS)
22856 P(IMI(JS,IM,1),1)=0D0
22857 P(IMI(JS,IM,1),2)=0D0
22859 IF(MSTP(91).LE.0) GOTO 180
22861 C...Now assign kT to each (non-collapsed) parton in IMI.
22862 DO 170 IM=1,NMI(JS)
22864 C...Select kT according to truncated gaussian or 1/kt6 tails.
22865 C...For first interaction, either use rms width = PARP(91) or fitted.
22868 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
22873 C...For subsequent interactions and BR partons use fragmentation width.
22878 IF(NTRY.LE.100) THEN
22879 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
22883 ELSEIF (MSTP(91).EQ.2) THEN
22884 CALL PYERRM(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
22885 & 'available, using MSTP(91)=1.')
22886 CALL PYGIVE('MSTP(91)=1')
22888 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
22889 C...Use distribution with kt**6 tails, rms width = PARP(91).
22890 EPS=SQRT(3D0/2D0)*SIGMA
22891 C...Generate PTX and PTY separately, each propto 1/KT**6
22893 C...Decide which interval to try
22894 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
22895 IF (PYR(0).LT.P12) THEN
22896 C...Use flat approx with accept/reject up to EPS.
22898 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
22899 IF (PYR(0).GT.WT) GOTO 112
22901 C...Above EPS, use 1/kt**6 approx with accept/reject.
22902 PT=EPS/(PYR(0)**(1D0/5D0))
22903 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
22904 IF (PYR(0).GT.WT) GOTO 112
22907 IF (PYR(0).GT.0.5D0) MSIGN=-1
22908 IF (IXY.EQ.1) PTX=MSIGN*PT
22909 IF (IXY.EQ.2) PTY=MSIGN*PT
22911 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
22912 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22913 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22915 C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
22916 PT=SQRT(PTX**2+PTY**2)
22918 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
22919 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
22922 PT=SQRT(PTX**2+PTY**2)
22928 C...Compensation kicks, with varying degree of local anticorrelations.
22930 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
22931 PTCX=-PTX/(NMI(JS)-1)
22932 PTCY=-PTY/(NMI(JS)-1)
22933 IF(ISUB.EQ.95) THEN
22934 PTCX=-PTX/(NMI(JS)-2)
22935 PTCY=-PTY/(NMI(JS)-2)
22937 DO 120 IMC=1,NMI(JS)
22938 IF (IMC.EQ.IM) GOTO 120
22939 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
22940 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
22941 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
22943 ELSEIF (MCORR.GE.1) THEN
22946 C...Count up # of neighbours on either side
22948 130 IMO=K(IMO,MSID)/MSTU(5)
22949 IF (IMO.EQ.0) GOTO 140
22950 NNXT(MSID-3)=NNXT(MSID-3)+1
22951 C...Stop at quarks and junctions
22952 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
22954 C...How should compensation be shared when unequal numbers on the
22955 C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
22956 NSUM=NNXT(1)+NNXT(2)
22959 C...Total momentum to be compensated on this side
22960 IF (NNXT(MSID-3).EQ.0) GOTO 160
22961 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
22962 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
22963 C...RS: compensation supression factor as we go out from parton I.
22964 C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
22965 C...since (for now) MSTP(90) provides enough variability.
22967 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
22970 IMO=K(IMO,MSID)/MSTU(5)
22971 IF (IMO.EQ.0) GOTO 160
22973 IF (K(IMO,2).NE.88) THEN
22974 P(IMO,1)=P(IMO,1)+FAC*PTCX
22975 P(IMO,2)=P(IMO,2)+FAC*PTCY
22976 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
22977 C...If we reach junction, divide out the kT that would have been
22978 C...assigned to the junction on each of its other legs.
22980 L1=MOD(K(IMO,4),MSTU(5))
22981 L2=K(IMO,5)/MSTU(5)
22982 L3=MOD(K(IMO,5),MSTU(5))
22983 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
22984 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
22985 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
22986 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
22987 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
22988 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
22989 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
22990 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
22996 C...End assignment of kT values to initiators and remnants.
22999 C...Check kinematics constraints for non-BR partons.
23000 DO 190 IM=1,MINT(31)
23001 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
23002 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
23003 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
23004 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
23005 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
23006 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
23007 IF(NTRY.GE.100) THEN
23008 C...Kill this event and start another.
23010 & '(PYMIRM:) No consistent (x,kT) sets found')
23018 C...Calculate W+ and W- available for combined remnant system.
23021 DO 200 IM=1,MINT(31)
23022 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
23023 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
23024 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
23025 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
23026 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
23028 C...Also store Wrem**2 = W+ * W-
23029 W(0,0)=W(0,1)*W(0,2)
23031 IF ((W(0,0).LT.0D0.OR.W(0,1)+W(0,2).LT.0D0).AND.NTRY.LE.100) THEN
23032 IF(NTRY.GE.100) THEN
23033 C...Kill this event and start another.
23035 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
23042 C...Assign unscaled x values to partons/hadrons in each of the
23043 C...beam remnants and calculate unscaled W+ and W- from them.
23049 DO 270 IM=MINT(31)+1,NMI(JS)
23055 C...Skip collapsed gluons and junctions. Reset.
23056 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
23057 IF (KFA.EQ.88) GOTO 270
23064 C...If gluon then only beam remnant, so takes all.
23067 C...If valence quark then use parametrized valence distribution.
23068 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
23070 C...If companion quark then derive from companion x.
23071 ELSEIF(KFA.LE.6) THEN
23073 C...If valence diquark then use two parametrized valence distributions.
23074 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23076 IVALQ(1)=ISIGN(KFA/1000,KF)
23077 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
23078 C...If valence+sea diquark then combine valence + companion choices.
23079 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23080 & ICOMP.LT.MSTU(5)) THEN
23081 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
23082 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
23084 IVALQ(1)=ISIGN(KFA/1000,KF)
23087 C...Extra code: workaround for diquark made out of two sea
23088 C...quarks, but where not (yet) ICOMP > MSTU(5).
23089 DO 220 IM1=1,MINT(31)
23090 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
23091 ICOMQ(2)=IMI(JS,IM1,1)
23095 C...If sea diquark then sum of two derived from companion x.
23096 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
23097 ICOMQ(1)=MOD(ICOMP,MSTU(5))
23098 ICOMQ(2)=ICOMP/MSTU(5)
23099 C...If meson or baryon then use fragmentation function.
23100 C...Somewhat arbitrary split into old and new flavour, but OK normally.
23102 KFL3=MOD(KFA/10,10)
23103 IF(MOD(KFA/1000,10).EQ.0) THEN
23104 KFL1=MOD(KFA/100,10)
23106 KFL1=MOD(KFA,10000)-10*KFL3-1
23107 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
23108 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
23110 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
23111 CALL PYZDIS(KFL1,KFL3,PR,X)
23115 C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
23116 C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
23117 C...In other baryons combine u and d from proton appropriately.
23118 IF(IVALQ(IQ).NE.0) THEN
23120 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
23121 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
23122 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
23124 IF(KFIVAL(JS,3).EQ.0) THEN
23126 C...Baryon with three identical quarks: mix u and d forms.
23127 ELSEIF(NVAL.EQ.3) THEN
23128 MDU=INT(PYR(0)+5D0/3D0)
23129 C...Baryon, one of two identical quarks: u form.
23130 ELSEIF(NVAL.EQ.2) THEN
23132 C...Baryon with two identical quarks, but not the one picked: d form.
23133 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
23134 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
23136 C...Baryon with three nonidentical quarks: mix u and d forms.
23138 MDU=INT(PYR(0)+5D0/3D0)
23141 IF(MDU.EQ.1) XPOW=3.5D0
23142 IF(MDU.EQ.2) XPOW=2D0
23144 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
23148 C...Calculation of x of companion quark.
23149 IF(ICOMQ(IQ).NE.0) THEN
23151 DO 240 IM1=1,MINT(31)
23152 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
23154 NPOW=MAX(0,MIN(4,MSTP(87)))
23155 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
23156 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
23157 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
23158 IF(CORR.LT.PYR(0)) GOTO 250
23163 C...Optionally enchance x of composite systems (e.g. diquarks)
23164 IF (KFA.GT.100) X=PARP(79)*X
23166 C...Store x. Also calculate light cone energies of each system.
23168 W(JS,JS)=W(JS,JS)+X
23169 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
23171 W(JS,JS)=W(JS,JS)*W(0,JS)
23172 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
23173 W(JS,0)=W(JS,1)*W(JS,2)
23176 C...Check W1 W2 < Wrem (can be done before rescaling, since W
23177 C...insensitive to global rescalings of the BR x values).
23178 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
23181 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
23183 ELSEIF (NTRYX.GT.100) THEN
23184 CALL PYERRM(1,'(PYMIRM:) No consistent (x,kT) sets found')
23185 MINT(57)=MINT(57)+1
23190 C...Compute x rescaling factors
23191 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
23192 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
23193 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
23195 IF (R1.LT.0.OR.R2.LT.0) THEN
23196 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
23197 MINT(57)=MINT(57)+1
23201 C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
23207 C...Rescale BR x values.
23208 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
23209 XMI(1,IM)=XMI(1,IM)*R1
23210 XMI(2,IM)=XMI(2,IM)*R2
23213 C...Now we have a consistent set of x and kT values.
23214 C...First set up the initiators and their daughters correctly.
23215 DO 300 IM=1,MINT(31)
23218 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
23219 & (P(I1,2)+P(I2,2))**2
23220 PT12=P(I1,1)**2+P(I1,2)**2
23221 PT22=P(I2,1)**2+P(I2,2)**2
23223 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
23225 C...Energies (masses should be zero at this stage)
23226 P(I1,4)=SQRT(PT12+P(I1,3)**2)
23227 P(I2,4)=SQRT(PT22+P(I2,3)**2)
23229 C...Transverse 12 system initiator velocity:
23230 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
23231 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
23232 C...Boost to overall initiator system rest frame
23233 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
23234 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
23236 C...Compute phi,theta coordinates of I1 and rotate z axis.
23237 PHI=PYANGL(P(I1,1),P(I1,2))
23238 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
23239 IMIN=IMISEP(IM-1)+1
23240 C...(include documentation lines if MI = 1)
23241 IF (IM.EQ.1) IMIN=MINT(83)+5
23243 C...Rotate entire system in phi
23244 CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
23245 C...Only rotate 12 system in theta
23246 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
23247 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
23249 C...Now boost entire system back to LAB
23250 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
23251 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
23252 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
23257 C...For the beam remnant partons/hadrons, we only need to set pz and E.
23259 DO 310 IM=MINT(31)+1,NMI(JS)
23261 C...Skip collapsed gluons and junctions.
23262 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
23263 IF (KFA.EQ.88) GOTO 310
23264 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
23265 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
23266 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
23267 IF (JS.EQ.2) P(I,3)=-P(I,3)
23272 C...Documentation lines
23278 K(IN,3)=MINT(83)+JS
23285 MCT(IN,1)=MCT(IO,1)
23286 MCT(IN,2)=MCT(IO,2)
23289 C...Final state colour reconnections.
23290 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
23292 C...Number of colour tags for which a recoupling will be tried.
23294 C...Number of recouplings to try
23302 IF (IITER.LE.PARP(78)*NTOT) THEN
23303 C...Select two colour tags at random
23304 C...NB: jj strings do not have colour tags assigned to them,
23305 C...thus they are as yet not affected by anything done here.
23307 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
23312 C...Find final state partons with this (anti)colour
23313 DO 370 I=MINT(84)+1,N
23314 IF (K(I,1).EQ.3) THEN
23315 IF (MCT(I,1).EQ.JCT) IJ1=I
23316 IF (MCT(I,2).EQ.JCT) IJ2=I
23317 IF (MCT(I,1).EQ.KCT) IK1=I
23318 IF (MCT(I,2).EQ.KCT) IK2=I
23321 C...Only consider recouplings not involving junctions for now.
23322 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
23324 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
23325 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
23326 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
23329 C...Count up number of reconnections
23330 MINT(34)=MINT(34)+1
23332 IF (MINT(34).LE.1000) THEN
23335 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
23339 IF (NRECP.LT.MINT(34)) GOTO 350
23341 C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
23347 C*********************************************************************
23350 C...Performs colour annealing.
23351 C...MSTP(95) : CR Type
23352 C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
23353 C... = 2 : Type I(no gg loops); hadron-hadron only
23354 C... = 3 : Type I(no gg loops); all beams
23355 C... = 4 : Type II(gg loops) ; hadron-hadron only
23356 C... = 5 : Type II(gg loops) ; all beams
23357 C... = 6 : Type S ; hadron-hadron only
23358 C... = 7 : Type S ; all beams
23359 C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
23360 C...Type S is driven by starting only from free triplets, not octets.
23361 C...A string piece remains unchanged with probability
23362 C... PKEEP = (1-PARP(78))**N
23363 C...This scaling corresponds to each string piece having to go through
23364 C...N other ones, each with probability PARP(78) for reconnection, where
23365 C...N is here chosen simply as the number of multiple interactions,
23366 C...for a rough scaling with the general level of activity.
23368 SUBROUTINE PYFSCR(IP)
23369 C...Double precision and integer declarations.
23370 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23371 INTEGER PYK,PYCHGE,PYCOMP
23373 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23374 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23375 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23376 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23377 COMMON/PYINT1/MINT(400),VINT(400)
23378 C...The common block of colour tags.
23379 COMMON/PYCTAG/NCT,MCT(4000,2)
23380 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
23382 C...MCN: Temporary storage of new colour tags
23383 INTEGER MCN(4000,2)
23384 C...Arrays for storing color string lengths
23385 INTEGER ICR(4000),MSCR(4000)
23387 DOUBLE PRECISION RLOPTC(4000)
23389 C...Function to give four-product.
23390 FOUR(I,J)=P(I,4)*P(J,4)
23391 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
23393 C...Check valid range of MSTP(95), local copy
23394 IF (MSTP(95).LE.1.OR.MSTP(95).GE.10) RETURN
23395 MSTP95=MOD(MSTP(95),10)
23396 C...Set whether CR allowed inside resonance systems or not
23397 C...(not implemented yet)
23399 C IF (MSTP(95).GE.10) MRESCR=0
23401 C...Check whether colour tags already defined
23402 IF (MINT(33).EQ.0) THEN
23403 C...Erase any existing colour tags for this event
23408 C...Create colour tags for this event
23410 IF (K(I,1).EQ.3) THEN
23413 IF (MCT(I,KCSIN-3).EQ.0) THEN
23414 CALL PYCTTR(I,KCSIN,I)
23419 C...Instruct PYPREP to use colour tags
23423 C...For MSTP(95) even, only apply to hadron-hadron
23426 IF (MOD(MSTP(95),2).EQ.0.AND.(KA1.LT.100.OR.KA2.LT.100)) GOTO 9999
23428 C...Initialize new tag array (but do not delete old yet)
23430 DO 130 I=MAX(1,IP),N
23435 C...For each final-state dipole, check whether string should be
23444 DO 140 I=MAX(1,IP),N
23445 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
23446 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
23448 IF (IC.NE.0.AND.IA.NE.0) THEN
23450 C...Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
23451 C...(so far ignores the possibility that the whole "muck" may be moving.)
23452 IF (PARP(77).GT.0D0) THEN
23453 PT2STR=(P(IA,1)+P(IC,1))**2+(P(IA,2)+P(IC,2))**2
23454 C...For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
23455 IF (KA1.LT.100.AND.KA2.LT.100) THEN
23456 P2STR = PT2STR + (P(IA,3)+P(IC,3))**2
23458 P2STR = 3D0/2D0 * PT2STR
23460 RM2STR=(P(IA,4)+P(IC,4))**2-(P(IA,3)+P(IC,3))**2-PT2STR
23461 RM2STR=MAX(RM2STR,PMAS(PYCOMP(111),1)**2)
23462 C...Estimate number of particles ~ log(M2), cut off at 1.
23463 RLOGM2=MAX(1D0,LOG(RM2STR))
23465 C...Supress reconnection probability by 1/(1+P77*P2AVG)
23466 CRMODF=1D0/(1D0+PARP(77)**2*P2AVG)
23468 PKEEP=(1D0-PARP(78)*CRMODF)**MINT(31)
23469 IF (PYR(0).LE.PKEEP) THEN
23474 C...Add coloured parton
23480 C...Add anti-coloured parton
23490 C...Skip if there is only one possibility
23495 C...Reorder, so ordered in I (in order to correspond to old algorithm)
23506 MSCR(IC1)=MSCR(IC1+1)
23512 C...Max do 1000 reordering loops
23513 IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 151
23515 C...Loop over CR partons
23516 C...(Ignore junctions for now.)
23521 C...Loop over coloured partons
23523 C...Retrieve parton Event Record index and Colour Side
23526 C...Skip already connected partons
23527 IF (MCN(I,MSI).NE.0) GOTO 230
23528 C...Shorthand for colour charge
23529 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
23530 C...For Seattle algorithm, only start from partons with one dangling
23532 IF (MSTP(95).GE.6.AND.MSTP(95).LE.9) THEN
23533 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
23535 C...Retrieve saved optimal partner
23538 C...Reject saved optimal partner if latter is now connected
23539 C...(Also reject if using model S1, since saved partner may
23540 C...now give rise to gg loop.)
23541 IF (MCN(IO,3-MSI).NE.0.OR.MSTP(95).LE.3) THEN
23547 C...Search for new optimal partner if necessary
23548 IF (IOPT(IC1).EQ.0) THEN
23552 C...Loop over partons you can connect to
23556 C...Skip if already connected
23557 IF (MCN(J,MSJ).NE.0) GOTO 210
23558 C...Skip if this not colour-anticolour pair
23559 IF (MSI.EQ.MSJ) GOTO 210
23560 C...And do not let gluons connect to themselves
23561 IF (I.EQ.J) GOTO 210
23562 C...Suppress direct connections between partons in same Beam Remnant
23564 IF (K(I,3).LE.2.AND.K(I,3).GE.1.AND.K(I,3).EQ.K(J,3))
23566 C...Shorthand for colour charge
23567 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
23568 C...Check for gluon loops
23570 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
23571 IF (MCN(I,2).EQ.MCN(J,1).AND.MSTP(95).LE.3.AND.
23572 & MCN(I,2).NE.0) MGGSTR=1
23574 C...Save connection with smallest lambda measure
23576 C...Optional: Seattle v2: multiply gluons by 1/2 since two strings connected
23577 IF (MSTP(95).GE.7.AND.MSTP(95).LE.8) THEN
23578 IF (K(I,2).EQ.21) RL=0.5D0*RL
23579 IF (K(J,2).EQ.21) RL=0.5D0*RL
23581 C...If best so far was a BR string and this is not, also save.
23582 C...If best so far was a gg string and this is not, also save.
23583 C...NB: this is not fool-proof. If the algorithm finds a BR or gg
23584 C...string with a small Lambda measure as the last step, this connection
23585 C...will be saved regardless of whether other possibilities existed.
23586 C...I.e., there should really be a check whether another possibility has
23587 C...already been found, but since these models are now actively in use
23588 C...and uncertainties are anyway large, the algorithm is left as it is.
23589 C...(correction --> Pythia 8 ?)
23590 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
23591 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
23592 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
23601 IF (IOPT(IC1).NE.0) THEN
23602 C...Save pair with largest RLOPT so far
23603 IF (RLOPT.GE.RLMAX) THEN
23609 C...Save and iterate
23610 IF (ICRMAX.GT.0) THEN
23616 MCN(ILMAX,ICMAX)=LCT
23617 MCN(JLMAX,JCMAX)=LCT
23618 IF (NLOOP.LE.2*(N-IP)) THEN
23621 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
23625 C...Save and exit. First check for leftover gluon(s)
23626 DO 260 I=MAX(1,IP),N
23627 C...Check colour charge
23628 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
23629 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
23630 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
23631 C...Decide where to put left-over gluon (minimal insertion)
23634 DO 250 KCT=NCT+1,LCT
23635 DO 240 IT=MAX(1,IP),N
23636 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
23637 IF (MCN(IT,1).EQ.KCT) IC=IT
23638 IF (MCN(IT,2).EQ.KCT) IA=IT
23640 RL=FOUR(IC,I)*FOUR(IA,I)
23641 IF (RL.LT.RLMAX) THEN
23648 MCN(I,1)=MCN(ICMAX,1)
23653 C...Here we need to loop over entire event.
23654 DO 270 IZ=MAX(1,IP),N
23655 C...Do not erase parton shower colour history
23656 IF (K(IZ,1).NE.3) GOTO 270
23657 C...Check colour charge
23658 MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2))
23659 IF (MCI.EQ.0) GOTO 270
23660 IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1)
23661 IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2)
23668 C*********************************************************************
23671 C...Handles diffractive and elastic scattering.
23675 C...Double precision and integer declarations.
23676 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23677 IMPLICIT INTEGER(I-N)
23678 INTEGER PYK,PYCHGE,PYCOMP
23680 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23681 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23682 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23683 COMMON/PYINT1/MINT(400),VINT(400)
23684 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
23686 C...Reset K, P and V vectors. Store incoming particles.
23687 DO 110 JT=1,MSTP(126)+10
23707 P(I,J)=VINT(285+5*JT+J)
23712 C...Subprocess; kinematics.
23713 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
23714 PZ=SQRT(SQLAM)/(2D0*VINT(1))
23717 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
23720 C...Elastically scattered particle. (Except elastic GVMD states.)
23721 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
23722 & MINT(106+JT).NE.3)) THEN
23727 P(N,3)=PZ*(-1)**(JT+1)
23729 P(N,5)=SQRT(VINT(62+JT))
23731 C...Decay rho from elastic scattering of gamma with sin**2(theta)
23732 C...distribution of decay products (in rho rest frame).
23733 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
23735 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
23739 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
23740 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
23741 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
23742 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
23743 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
23744 140 CTHE=2D0*PYR(0)-1D0
23745 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
23746 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
23748 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
23751 C...Diffracted particle: low-mass system to two particles.
23752 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
23758 PMMAS=SQRT(VINT(62+JT))
23761 IF(NTRY.LT.20) THEN
23762 MINT(105)=MINT(102+JT)
23763 MINT(109)=MINT(106+JT)
23764 CALL PYSPLI(KFH,21,KFL1,KFL2)
23765 CALL PYKFDI(KFL1,0,KFL3,KF1)
23766 IF(KF1.EQ.0) GOTO 150
23767 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
23768 IF(KF2.EQ.0) GOTO 150
23775 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
23780 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
23781 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
23784 P(N-1,4)=SQRT(PM1**2+PZP**2)
23785 P(N,4)=SQRT(PM2**2+PZP**2)
23786 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
23788 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
23789 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
23791 C...Diffracted particle: valence quark kicked out.
23792 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
23799 MINT(105)=MINT(102+JT)
23800 MINT(109)=MINT(106+JT)
23801 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
23802 P(N-1,5)=PYMASS(K(N-1,2))
23803 P(N,5)=PYMASS(K(N,2))
23804 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
23805 & 4D0*P(N-1,5)**2*P(N,5)**2
23806 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
23807 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
23808 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
23809 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
23810 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23812 C...Diffracted particle: gluon kicked out.
23821 MINT(105)=MINT(102+JT)
23822 MINT(109)=MINT(106+JT)
23823 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
23825 P(N-2,5)=PYMASS(K(N-2,2))
23827 P(N,5)=PYMASS(K(N,2))
23828 C...Energy distribution for particle into two jets.
23830 IF(MOD(KFH/1000,10).NE.0) IMB=2
23831 CHIK=PARP(92+2*IMB)
23832 IF(MSTP(92).LE.1) THEN
23833 IF(IMB.EQ.1) CHI=PYR(0)
23834 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23835 ELSEIF(MSTP(92).EQ.2) THEN
23836 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
23837 ELSEIF(MSTP(92).EQ.3) THEN
23838 CUT=2D0*0.3D0/VINT(1)
23840 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
23842 ELSEIF(MSTP(92).EQ.4) THEN
23843 CUT=2D0*0.3D0/VINT(1)
23844 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
23845 180 CHIR=CUT*CUTR**PYR(0)
23846 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
23847 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
23849 CUT=2D0*0.3D0/VINT(1)
23850 CUTA=CUT**(1D0-PARP(98))
23851 CUTB=(1D0+CUT)**(1D0-PARP(98))
23852 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
23853 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
23854 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
23856 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
23857 & VINT(62+JT)) GOTO 160
23858 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
23859 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
23860 & (2D0*VINT(62+JT))
23861 PEI=SQRT(PZI**2+SQM)
23862 PQQP=(1D0-CHI)*(PEI+PZI)
23863 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
23864 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
23865 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
23866 P(N-1,3)=P(N-1,4)*(-1)**JT
23867 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
23868 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23871 C...Documentation lines.
23873 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
23874 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
23875 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
23877 P(I+2,3)=PZ*(-1)**(JT+1)
23879 P(I+2,5)=SQRT(VINT(62+JT))
23882 C...Rotate outgoing partons/particles using cos(theta).
23883 IF(VINT(23).LT.0.9D0) THEN
23884 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
23886 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
23892 C*********************************************************************
23895 C...Set up a DIS process as gamma* + f -> f, with beam remnant
23896 C...and showering added consecutively. Photon flux by the PYGAGA
23897 C...routine (if at all).
23901 C...Double precision and integer declarations.
23902 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23903 IMPLICIT INTEGER(I-N)
23904 INTEGER PYK,PYCHGE,PYCOMP
23905 C...Parameter statement to help give large particle numbers.
23906 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23907 &KEXCIT=4000000,KDIMEN=5000000)
23909 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23910 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23911 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23912 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23913 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23914 COMMON/PYINT1/MINT(400),VINT(400)
23915 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
23919 C...Choice of subprocess, number of documentation lines
23927 IF(MINT(107).EQ.4) ISIDE=2
23929 C...Reset K, P and V vectors. Store incoming particles
23930 DO 110 JT=1,MSTP(126)+20
23943 P(I,J)=VINT(285+5*JT+J)
23948 C...Store incoming partons in hadronic CM-frame
23953 K(I,3)=MINT(83)+2+JT
23955 IF(MINT(15).EQ.22) THEN
23956 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
23957 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
23958 P(MINT(84)+1,5)=-SQRT(VINT(307))
23959 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
23960 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
23964 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
23965 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
23966 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
23967 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
23968 P(MINT(84)+1,5)=-SQRT(VINT(308))
23972 SIDESG=(-1D0)**(ISIDE-1)
23974 C...Copy incoming partons to documentation lines.
23985 C...Second copy for partons before ISR shower, since no such.
23995 C...Define initial partons.
23998 IF(NTRY.GT.100) THEN
24003 C...Scattered quark in hadronic CM frame.
24008 P(IPU3,5)=PYMASS(KFRES)
24009 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
24010 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
24014 K(I,3)=MINT(83)+4+ISIDE
24022 C...No primordial kT, or chosen according to truncated Gaussian or
24023 C...exponential, or (for photon) predetermined or power law.
24024 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
24025 IF(MSTP(91).LE.0) THEN
24027 ELSEIF(MSTP(91).EQ.1) THEN
24028 PT=PARP(91)*SQRT(-LOG(PYR(0)))
24032 PT=-PARP(92)*LOG(RPT1*RPT2)
24034 IF(PT.GT.PARP(93)) GOTO 190
24035 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
24036 PTA=SQRT(VINT(282+ISIDE))
24038 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
24039 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
24040 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
24043 PTB=-PARP(99)*LOG(RPT1*RPT2)
24045 IF(PTB.GT.PARP(100)) GOTO 190
24046 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
24047 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
24048 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
24049 IF(MSTP(93).LE.0) THEN
24051 ELSEIF(MSTP(93).EQ.1) THEN
24052 PT=PARP(99)*SQRT(-LOG(PYR(0)))
24053 ELSEIF(MSTP(93).EQ.2) THEN
24056 PT=-PARP(99)*LOG(RPT1*RPT2)
24057 ELSEIF(MSTP(93).EQ.3) THEN
24060 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
24064 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
24065 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
24067 IF(PT.GT.PARP(100)) GOTO 190
24073 P(IPU3,1)=PT*COS(PHI)
24074 P(IPU3,2)=PT*SIN(PHI)
24075 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
24076 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
24077 PCP=P(IPU3,4)+ABS(P(IPU3,3))
24079 C...Find one or two beam remnants.
24080 MINT(105)=MINT(102+ISIDE)
24081 MINT(109)=MINT(106+ISIDE)
24082 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
24083 IF(MINT(51).NE.0) THEN
24088 C...Store first remnant parton, with colour info and kinematics.
24092 K(I,3)=MINT(83)+ISIDE
24093 P(I,5)=PYMASS(K(I,2))
24094 KCOL=KCHG(PYCOMP(KFLSP),2)
24097 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
24098 K(I,KFLS+3)=MSTU(5)*IPU3
24099 K(IPU3,6-KFLS)=MSTU(5)*I
24102 IF(KFLCH.EQ.0) THEN
24105 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24107 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
24108 PRP=P(I,4)+ABS(P(I,3))
24110 C...When extra remnant parton or hadron: store extra remnant.
24115 K(I,3)=MINT(83)+ISIDE
24116 P(I,5)=PYMASS(K(I,2))
24117 KCOL=KCHG(PYCOMP(KFLCH),2)
24120 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
24121 K(I,KFLS+3)=MSTU(5)*IPU3
24122 K(IPU3,6-KFLS)=MSTU(5)*I
24126 C...Relative transverse momentum when two remnants.
24129 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
24130 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
24131 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
24132 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
24133 P(I,1)=-P(IPU3,1)-P(I-1,1)
24134 P(I,2)=-P(IPU3,2)-P(I-1,2)
24135 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24137 C...Relative distribution of energy for particle into jet plus particle.
24139 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
24140 IF(MSTP(94).LE.1) THEN
24141 IF(IMB.EQ.1) CHI=PYR(0)
24142 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
24143 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24144 ELSEIF(MSTP(94).EQ.2) THEN
24145 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
24146 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24147 ELSEIF(MSTP(94).EQ.3) THEN
24148 CALL PYZDIS(1,0,PMS(4),ZZ)
24151 CALL PYZDIS(1000,0,PMS(4),ZZ)
24155 C...Construct total transverse mass; reject if too large.
24156 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
24157 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
24158 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
24159 IF(LOOP.LT.10) GOTO 200
24162 VINT(158+ISIDE)=CHI
24164 C...Subdivide longitudinal momentum according to value selected above.
24165 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
24167 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
24168 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
24170 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
24171 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
24175 C...Boost current and remnant systems to correct frame.
24176 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
24177 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
24178 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
24180 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
24182 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
24183 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
24184 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
24185 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
24187 C...Let current quark shower; recoil but no showering by colour partner.
24188 QMAX=2D0*SQRT(VINT(309-ISIDE))
24193 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
24200 C*********************************************************************
24203 C...Handles the documentation of the process in MSTI and PARI,
24204 C...and also computes cross-sections based on accumulated statistics.
24208 C...Double precision and integer declarations.
24209 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24210 IMPLICIT INTEGER(I-N)
24211 INTEGER PYK,PYCHGE,PYCOMP
24213 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24214 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24215 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24216 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24217 COMMON/PYINT1/MINT(400),VINT(400)
24218 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24219 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
24220 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
24223 C...Calculate Monte Carlo estimates of cross-sections.
24225 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
24226 NGEN(0,3)=NGEN(0,3)+1
24229 IF(I.EQ.96.OR.I.EQ.97) THEN
24231 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
24232 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
24233 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24234 & DBLE(NGEN(96,2)))
24235 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
24236 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24237 & DBLE(NGEN(96,2)))
24238 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
24240 ELSEIF(NGEN(I,2).EQ.0) THEN
24241 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
24244 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
24247 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
24250 C...Rescale to known low-pT cross-section for standard QCD processes.
24251 IF(MSUB(95).EQ.1) THEN
24252 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
24253 & XSEC(68,3)+XSEC(95,3)
24254 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
24255 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
24257 XSEC(11,3)=FAC*XSEC(11,3)
24258 XSEC(12,3)=FAC*XSEC(12,3)
24259 XSEC(13,3)=FAC*XSEC(13,3)
24260 XSEC(28,3)=FAC*XSEC(28,3)
24261 XSEC(53,3)=FAC*XSEC(53,3)
24262 XSEC(68,3)=FAC*XSEC(68,3)
24263 XSEC(95,3)=FAC*XSEC(95,3)
24264 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
24268 C...Save information for gamma-p and gamma-gamma.
24269 IF(MINT(121).GT.1) THEN
24275 C...Reset information on hard interaction.
24281 C...Copy integer valued information from MINT into MSTI.
24285 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
24287 C...Store cross-section variables in PARI.
24289 PARI(2)=XSEC(0,3)/MINT(5)
24293 VINT(98)=VINT(98)+VINT(100)
24294 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
24296 C...Store kinematics variables in PARI.
24299 IF(ISUB.NE.95) THEN
24309 PARI(35)=PARI(33)-PARI(34)
24316 PARI(42)=2D0*VINT(47)/VINT(1)
24319 C...Store information on scattered partons in PARI.
24320 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
24323 PARI(36+IS)=P(I,3)/VINT(1)
24324 PARI(38+IS)=P(I,4)/VINT(1)
24325 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
24326 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24327 & SQRT(PR),1D20)),P(I,3))
24328 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
24329 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24330 & SQRT(PR),1D20)),P(I,3))
24331 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
24332 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
24333 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
24337 C...Store sum up transverse and longitudinal momenta.
24338 PARI(65)=2D0*PARI(17)
24339 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
24340 DO 150 I=MSTP(126)+1,N
24341 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
24342 PT=SQRT(P(I,1)**2+P(I,2)**2)
24343 PARI(69)=PARI(69)+PT
24344 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
24345 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
24357 C...Store various other pieces of information into PARI.
24365 C...Store information on lepton -> lepton + gamma in PYGAGA.
24368 PARI(101)=VINT(301)
24369 PARI(102)=VINT(302)
24371 PARI(I)=VINT(I+202)
24374 C...Set information for PYTABU.
24375 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
24378 ELSEIF(ISET(ISUB).EQ.5) THEN
24389 C*********************************************************************
24392 C...Performs transformations between different coordinate frames.
24394 SUBROUTINE PYFRAM(IFRAME)
24396 C...Double precision and integer declarations.
24397 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24398 IMPLICIT INTEGER(I-N)
24399 INTEGER PYK,PYCHGE,PYCOMP
24401 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24402 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24403 COMMON/PYINT1/MINT(400),VINT(400)
24404 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
24406 C...Check that transformation can and should be done.
24407 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
24408 &MINT(91).EQ.1)) THEN
24409 IF(IFRAME.EQ.MINT(6)) RETURN
24411 WRITE(MSTU(11),5000) IFRAME,MINT(6)
24415 IF(MINT(6).EQ.1) THEN
24416 C...Transform from fixed target or user specified frame to
24417 C...overall CM frame.
24418 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
24419 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
24420 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
24421 ELSEIF(MINT(6).EQ.3) THEN
24422 C...Transform from hadronic CM frame in DIS to overall CM frame.
24423 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
24427 IF(IFRAME.EQ.1) THEN
24428 C...Transform from overall CM frame to fixed target or user specified
24430 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
24431 ELSEIF(IFRAME.EQ.3) THEN
24432 C...Transform from overall CM frame to hadronic CM frame in DIS.
24433 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
24434 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
24435 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
24438 C...Set information about new frame.
24442 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
24443 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
24449 C*********************************************************************
24452 C...Calculates full and partial widths of resonances.
24454 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
24456 C...Double precision and integer declarations.
24457 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24458 IMPLICIT INTEGER(I-N)
24459 INTEGER PYK,PYCHGE,PYCOMP
24460 C...Parameter statement to help give large particle numbers.
24461 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24462 &KEXCIT=4000000,KDIMEN=5000000)
24464 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24465 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24466 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
24467 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24468 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24469 COMMON/PYINT1/MINT(400),VINT(400)
24470 COMMON/PYINT4/MWID(500),WIDS(500,5)
24471 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24472 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24473 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
24474 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
24475 COMMON/PYPUED/IUED(0:99),RUED(0:99)
24476 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
24477 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/
24478 C...Local arrays and saved variables.
24479 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
24480 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
24481 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
24482 C...UED: equivalences between ordered particles (451->475)
24483 C...and UED particle code (5 000 000 + id)
24484 PARAMETER(KKFLMI=451,KKFLMA=475)
24485 DIMENSION CHIDEL(3), IUEDPR(25)
24486 DIMENSION IUEDEQ(KKFLMA),MUED(2)
24487 COMMON/SW1/SW21,CW21
24488 DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/
24489 & 6100001,6100002,6100003,6100004,6100005,6100006,
24490 & 5100001,5100002,5100003,5100004,5100005,5100006,
24491 & 6100011,6100013,6100015,
24492 & 5100012,5100011,5100014,5100013,5100016,5100015,
24493 & 5100021,5100022,5100023,5100024/
24494 C...Save local variables
24495 SAVE MOFSV,WIDWSV,WID2SV
24497 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
24498 DATA CHIDEL/1.1D-03,1.D0,7.4D+2/
24500 C...UED: inline functions used in kk width calculus
24501 FKAC1(X,Y)=1.-X**2/Y**2
24502 FKAC2(X,Y)=2.+X**2/Y**2
24504 C...Compressed code and sign; mass.
24511 C...Reset width information.
24512 DO 110 I=0,MDCY(KC,3)
24519 C...Allow for fudge factor to rescale resonance width.
24521 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
24522 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
24523 IF(MSTP(110).EQ.KFLA) THEN
24525 ELSEIF(MSTP(110).EQ.-1) THEN
24526 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
24527 ELSEIF(MSTP(110).EQ.-2) THEN
24532 C...Not to be treated as a resonance: return.
24533 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
24542 C...Treatment as a resonance based on tabulated branching ratios.
24543 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
24544 C...Loop over possible decay channels; skip irrelevant ones.
24545 DO 120 I=1,MDCY(KC,3)
24547 IF(MDME(IDC,1).LT.0) GOTO 120
24549 C...Read out decay products and nominal masses.
24552 C...Skip dummy modes or unrecognized particles
24553 IF (KFD1.EQ.0.OR.KFC1.EQ.0) GOTO 120
24554 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
24558 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
24564 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
24568 C...Naive partial width and alternative threshold factors.
24569 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
24570 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
24571 & PM1+PM2+PM3.GE.SHR) THEN
24573 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
24574 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
24575 & 4D0*PM1**2*PM2**2))/SH
24576 ELSEIF(MDME(IDC,2).EQ.52) THEN
24577 PMA=MAX(PM1,PM2,PM3)
24578 PMC=MIN(PM1,PM2,PM3)
24579 PMB=PM1+PM2+PM3-PMA-PMC
24580 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
24585 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
24586 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24587 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24588 & ((SHR-PMA)**2-(PMB+PMC)**2)*
24589 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
24590 & ((1D0-PMBCN)*PMBCN*SH)
24591 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
24592 WDTP(I)=WDTP(I)*SQRT(
24593 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
24594 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
24595 ELSEIF(MDME(IDC,2).EQ.53) THEN
24596 PMA=MAX(PM1,PM2,PM3)
24597 PMC=MIN(PM1,PM2,PM3)
24598 PMB=PM1+PM2+PM3-PMA-PMC
24599 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
24604 FACACT=SQRT(MAX(0D0,
24605 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24606 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24607 & ((SHR-PMA)**2-(PMB+PMC)**2)*
24608 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
24609 & ((1D0-PMBCN)*PMBCN*SH)
24610 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
24614 PMBCN=PMBC**2/PMR**2
24615 FACNOM=SQRT(MAX(0D0,
24616 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24617 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24618 & ((PMR-PMA)**2-(PMB+PMC)**2)*
24619 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
24620 & ((1D0-PMBCN)*PMBCN*PMR**2)
24621 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
24623 WDTP(I)=FUDGE*WDTP(I)
24624 WDTP(0)=WDTP(0)+WDTP(I)
24626 C...Calculate secondary width (at most two identical/opposite).
24628 IF(MDME(IDC,1).GT.0) THEN
24629 IF(KFD2.EQ.KFD1) THEN
24630 IF(KCHG(KFC1,3).EQ.0) THEN
24632 ELSEIF(KFD1.GT.0) THEN
24638 WID2=WID2*WIDS(KFC3,2)
24639 ELSEIF(KFD3.LT.0) THEN
24640 WID2=WID2*WIDS(KFC3,3)
24642 ELSEIF(KFD2.EQ.-KFD1) THEN
24645 WID2=WID2*WIDS(KFC3,2)
24646 ELSEIF(KFD3.LT.0) THEN
24647 WID2=WID2*WIDS(KFC3,3)
24649 ELSEIF(KFD3.EQ.KFD1) THEN
24650 IF(KCHG(KFC1,3).EQ.0) THEN
24652 ELSEIF(KFD1.GT.0) THEN
24658 WID2=WID2*WIDS(KFC2,2)
24659 ELSEIF(KFD2.LT.0) THEN
24660 WID2=WID2*WIDS(KFC2,3)
24662 ELSEIF(KFD3.EQ.-KFD1) THEN
24665 WID2=WID2*WIDS(KFC2,2)
24666 ELSEIF(KFD2.LT.0) THEN
24667 WID2=WID2*WIDS(KFC2,3)
24669 ELSEIF(KFD3.EQ.KFD2) THEN
24670 IF(KCHG(KFC2,3).EQ.0) THEN
24672 ELSEIF(KFD2.GT.0) THEN
24678 WID2=WID2*WIDS(KFC1,2)
24679 ELSEIF(KFD1.LT.0) THEN
24680 WID2=WID2*WIDS(KFC1,3)
24682 ELSEIF(KFD3.EQ.-KFD2) THEN
24685 WID2=WID2*WIDS(KFC1,2)
24686 ELSEIF(KFD1.LT.0) THEN
24687 WID2=WID2*WIDS(KFC1,3)
24696 WID2=WID2*WIDS(KFC2,2)
24698 WID2=WID2*WIDS(KFC2,3)
24701 WID2=WID2*WIDS(KFC3,2)
24702 ELSEIF(KFD3.LT.0) THEN
24703 WID2=WID2*WIDS(KFC3,3)
24707 C...Store effective widths according to case.
24708 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24709 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24710 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24711 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24721 C...Here begins detailed dynamical calculation of resonance widths.
24722 C...Shared treatment of Higgs states.
24725 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
24730 C...Common electroweak and strong constants.
24733 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
24736 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
24738 RADC=1D0+AS/PARU(1)
24742 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24743 RADCT=1D0-2.5D0*AS/PARU(1)
24744 DO 140 I=1,MDCY(KC,3)
24746 IF(MDME(IDC,1).LT.0) GOTO 140
24747 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24748 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24749 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
24751 IF(I.GE.4.AND.I.LE.7) THEN
24752 C...t -> W + q; including approximate QCD correction factor.
24753 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
24754 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24755 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24758 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24761 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24763 ELSEIF(I.EQ.9) THEN
24765 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
24766 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24767 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
24768 & 4D0*SQRT(RM2R*RM2))
24770 IF(KFLR.LT.0) WID2=WIDS(37,3)
24772 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
24773 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
24776 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
24779 KFC1=PYCOMP(KFDP(IDC,1))
24780 KFC2=PYCOMP(KFDP(IDC,2))
24781 PMNCHI=PMAS(KFC1,1)
24782 PMSTOP=PMAS(KFC2,1)
24783 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24786 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
24788 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
24789 AR=-ET*ZMIXC(IZ,1)*TANW
24790 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
24792 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
24793 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
24794 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24795 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24796 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
24797 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
24798 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
24800 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24802 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24805 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
24807 KFC1=PYCOMP(KFDP(IDC,1))
24808 KFC2=PYCOMP(KFDP(IDC,2))
24809 PMNCHI=PMAS(KFC1,1)
24810 PMSTOP=PMAS(KFC2,1)
24811 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24814 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24815 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24816 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
24817 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
24819 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24821 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24824 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
24825 C...t -> ~gravitino + ~t
24827 KFC1=PYCOMP(KFDP(IDC,1))
24828 XMGR2=PMAS(KFC1,1)**2
24829 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
24830 KFC2=PYCOMP(KFDP(IDC,2))
24832 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
24835 WDTP(I)=FUDGE*WDTP(I)
24836 WDTP(0)=WDTP(0)+WDTP(I)
24837 IF(MDME(IDC,1).GT.0) THEN
24838 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24839 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24840 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24841 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24845 ELSEIF(KFLA.EQ.7) THEN
24847 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24848 DO 150 I=1,MDCY(KC,3)
24850 IF(MDME(IDC,1).LT.0) GOTO 150
24851 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24852 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24853 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
24855 IF(I.GE.4.AND.I.LE.7) THEN
24857 WDTP(I)=FAC*VCKM(I-3,4)*
24858 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24859 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24862 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
24863 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
24866 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
24867 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
24870 IF(KFLR.LT.0) WID2=WIDS(24,2)
24871 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24873 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24874 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24877 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
24880 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
24883 WDTP(I)=FUDGE*WDTP(I)
24884 WDTP(0)=WDTP(0)+WDTP(I)
24885 IF(MDME(IDC,1).GT.0) THEN
24886 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24887 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24888 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24889 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24893 ELSEIF(KFLA.EQ.8) THEN
24895 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24896 DO 160 I=1,MDCY(KC,3)
24898 IF(MDME(IDC,1).LT.0) GOTO 160
24899 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24900 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24901 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
24903 IF(I.GE.4.AND.I.LE.7) THEN
24905 WDTP(I)=FAC*VCKM(4,I-3)*
24906 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24907 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24910 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24913 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24915 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24917 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24918 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24921 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
24924 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
24927 WDTP(I)=FUDGE*WDTP(I)
24928 WDTP(0)=WDTP(0)+WDTP(I)
24929 IF(MDME(IDC,1).GT.0) THEN
24930 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24931 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24932 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24933 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24937 ELSEIF(KFLA.EQ.17) THEN
24939 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24940 DO 170 I=1,MDCY(KC,3)
24942 IF(MDME(IDC,1).LT.0) GOTO 170
24943 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24944 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24945 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
24948 C...tau' -> W + nu'_tau.
24949 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24950 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24953 WID2=WID2*WIDS(18,2)
24956 WID2=WID2*WIDS(18,3)
24958 ELSEIF(I.EQ.5) THEN
24959 C...tau' -> H + nu'_tau.
24960 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24961 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24964 WID2=WID2*WIDS(18,2)
24967 WID2=WID2*WIDS(18,3)
24970 WDTP(I)=FUDGE*WDTP(I)
24971 WDTP(0)=WDTP(0)+WDTP(I)
24972 IF(MDME(IDC,1).GT.0) THEN
24973 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24974 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24975 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24976 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24980 ELSEIF(KFLA.EQ.18) THEN
24981 C...nu'_tau neutrino.
24982 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24983 DO 180 I=1,MDCY(KC,3)
24985 IF(MDME(IDC,1).LT.0) GOTO 180
24986 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24987 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24988 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
24991 C...nu'_tau -> W + tau'.
24992 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24993 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24996 WID2=WID2*WIDS(17,2)
24999 WID2=WID2*WIDS(17,3)
25001 ELSEIF(I.EQ.3) THEN
25002 C...nu'_tau -> H + tau'.
25003 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25004 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
25007 WID2=WID2*WIDS(17,2)
25010 WID2=WID2*WIDS(17,3)
25013 WDTP(I)=FUDGE*WDTP(I)
25014 WDTP(0)=WDTP(0)+WDTP(I)
25015 IF(MDME(IDC,1).GT.0) THEN
25016 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25017 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25018 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25019 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25023 ELSEIF(KFLA.EQ.21) THEN
25025 C***Note that widths are not given in dimensional quantities here.
25026 DO 190 I=1,MDCY(KC,3)
25028 IF(MDME(IDC,1).LT.0) GOTO 190
25029 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25030 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25031 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
25034 C...QCD -> q + qbar
25035 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25036 IF(I.EQ.6) WID2=WIDS(6,1)
25037 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25039 WDTP(I)=FUDGE*WDTP(I)
25040 WDTP(0)=WDTP(0)+WDTP(I)
25041 IF(MDME(IDC,1).GT.0) THEN
25042 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25043 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25044 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25045 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25049 ELSEIF(KFLA.EQ.22) THEN
25051 C***Note that widths are not given in dimensional quantities here.
25052 DO 200 I=1,MDCY(KC,3)
25054 IF(MDME(IDC,1).LT.0) GOTO 200
25055 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25056 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25057 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
25060 C...QED -> q + qbar.
25063 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25064 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25065 IF(I.EQ.6) WID2=WIDS(6,1)
25066 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25067 ELSEIF(I.LE.12) THEN
25068 C...QED -> l+ + l-.
25069 EF=KCHG(9+2*(I-8),1)/3D0
25070 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25071 IF(I.EQ.12) WID2=WIDS(17,1)
25073 WDTP(I)=FUDGE*WDTP(I)
25074 WDTP(0)=WDTP(0)+WDTP(I)
25075 IF(MDME(IDC,1).GT.0) THEN
25076 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25077 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25078 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25079 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25083 ELSEIF(KFLA.EQ.23) THEN
25086 XWC=1D0/(16D0*XW*XW1)
25087 FAC=(AEM*XWC/3D0)*SHR
25089 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25094 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25096 IF(KFI.GT.20) KFI=IABS(MINT(16))
25102 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
25103 IF(MSTP(43).EQ.3) VINT(112)=
25104 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25105 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25106 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25108 DO 220 I=1,MDCY(KC,3)
25110 IF(MDME(IDC,1).LT.0) GOTO 220
25111 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25112 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25113 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
25118 AF=SIGN(1D0,EF+0.1D0)
25121 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25122 IF(I.EQ.6) WID2=WIDS(6,1)
25123 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25124 ELSEIF(I.LE.16) THEN
25125 C...Z0 -> l+ + l-, nu + nubar
25127 AF=SIGN(1D0,EF+0.1D0)
25130 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25132 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25133 IF(ICASE.EQ.1) THEN
25134 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
25136 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25137 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25138 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
25139 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
25140 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25141 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25142 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25143 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25145 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
25146 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
25147 IF(MDME(IDC,1).GT.0) THEN
25148 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25149 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25150 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25151 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25152 & WDTE(I,MDME(IDC,1))
25153 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25154 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25156 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25157 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
25158 & VINT(111)+FGGF*WID2
25159 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
25160 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25161 & VINT(114)+FZZF*WID2
25165 IF(MINT(61).GE.1) ICASE=3-ICASE
25166 IF(ICASE.EQ.2) GOTO 210
25168 ELSEIF(KFLA.EQ.24) THEN
25170 FAC=(AEM/(24D0*XW))*SHR
25171 DO 230 I=1,MDCY(KC,3)
25173 IF(MDME(IDC,1).LT.0) GOTO 230
25174 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25175 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25176 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
25179 C...W+/- -> q + qbar'
25180 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
25182 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25183 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25184 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25186 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25187 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25188 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25190 ELSEIF(I.LE.20) THEN
25191 C...W+/- -> l+/- + nu
25194 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25196 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25199 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25200 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25201 WDTP(I)=FUDGE*WDTP(I)
25202 WDTP(0)=WDTP(0)+WDTP(I)
25203 IF(MDME(IDC,1).GT.0) THEN
25204 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25205 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25206 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25207 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25211 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
25212 C...h0 (or H0, or A0):
25214 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25215 DO 270 I=1,MDCY(KFHIGG,3)
25216 IDC=I+MDCY(KFHIGG,2)-1
25217 IF(MDME(IDC,1).LT.0) GOTO 270
25218 KFC1=PYCOMP(KFDP(IDC,1))
25219 KFC2=PYCOMP(KFDP(IDC,2))
25220 RM1=PMAS(KFC1,1)**2/SH
25221 RM2=PMAS(KFC2,1)**2/SH
25222 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
25228 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
25229 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
25230 C...A0 behaves like beta, ho and H0 like beta**3.
25231 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25232 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25233 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
25234 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
25235 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
25236 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
25237 IF(IHIGG.NE.3) THEN
25238 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
25239 & PARU(151+10*IHIGG))**2
25243 IF(I.EQ.6) WID2=WIDS(6,1)
25244 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25245 ELSEIF(I.LE.12) THEN
25247 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
25248 C...A0 behaves like beta, ho and H0 like beta**3.
25249 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25250 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25251 & PARU(153+10*IHIGG)**2
25252 IF(I.EQ.12) WID2=WIDS(17,1)
25254 ELSEIF(I.EQ.13) THEN
25255 C...h0 -> g + g; quark loop contribution only
25258 DO 240 J=1,2*MSTP(1)
25259 EPS=(2D0*PMAS(J,1))**2/SH
25260 C...Loop integral; function of eps=4m^2/shat; different for A0.
25261 IF(EPS.LE.1D0) THEN
25262 IF(EPS.GT.1D-4) THEN
25264 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25266 RLN=LOG(4D0/EPS-2D0)
25268 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25269 PHIIM=0.5D0*PARU(1)*RLN
25271 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25274 IF(IHIGG.LE.2) THEN
25275 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25276 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
25278 ETAREJ=-0.5D0*EPS*PHIRE
25279 ETAIMJ=-0.5D0*EPS*PHIIM
25281 C...Couplings (=1 for standard model Higgs).
25282 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25283 IF(MOD(J,2).EQ.1) THEN
25284 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
25285 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
25287 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
25288 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
25294 ETA2=ETARE**2+ETAIM**2
25295 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
25297 ELSEIF(I.EQ.14) THEN
25298 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
25302 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25304 IF(J.LE.2*MSTP(1)) THEN
25306 EPS=(2D0*PMAS(J,1))**2/SH
25307 ELSEIF(J.LE.3*MSTP(1)) THEN
25308 JL=2*(J-2*MSTP(1))-1
25309 EJ=KCHG(10+JL,1)/3D0
25310 EPS=(2D0*PMAS(10+JL,1))**2/SH
25311 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25312 EPS=(2D0*PMAS(24,1))**2/SH
25314 EPS=(2D0*PMAS(37,1))**2/SH
25316 C...Loop integral; function of eps=4m^2/shat.
25317 IF(EPS.LE.1D0) THEN
25318 IF(EPS.GT.1D-4) THEN
25320 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25322 RLN=LOG(4D0/EPS-2D0)
25324 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25325 PHIIM=0.5D0*PARU(1)*RLN
25327 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25330 IF(J.LE.3*MSTP(1)) THEN
25331 C...Fermion loops: loop integral different for A0; charges.
25332 IF(IHIGG.LE.2) THEN
25333 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25334 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
25336 PHIPRE=-0.5D0*EPS*PHIRE
25337 PHIPIM=-0.5D0*EPS*PHIIM
25339 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25341 EJH=PARU(151+10*IHIGG)
25342 ELSEIF(J.LE.2*MSTP(1)) THEN
25344 EJH=PARU(152+10*IHIGG)
25347 EJH=PARU(153+10*IHIGG)
25349 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
25350 ETAREJ=EJC*EJH*PHIPRE
25351 ETAIMJ=EJC*EJH*PHIPIM
25352 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25353 C...W loops: loop integral and charges.
25354 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
25355 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
25356 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25357 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
25358 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
25361 C...Charged H loops: loop integral and charges.
25362 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
25363 & PARU(158+10*IHIGG+2*(IHIGG/3))
25364 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
25365 ETAIMJ=-EPS**2*PHIIM*FACHHH
25370 ETA2=ETARE**2+ETAIM**2
25371 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
25373 ELSEIF(I.EQ.15) THEN
25374 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
25378 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25380 IF(J.LE.2*MSTP(1)) THEN
25382 AJ=SIGN(1D0,EJ+0.1D0)
25384 EPS=(2D0*PMAS(J,1))**2/SH
25385 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
25386 ELSEIF(J.LE.3*MSTP(1)) THEN
25387 JL=2*(J-2*MSTP(1))-1
25388 EJ=KCHG(10+JL,1)/3D0
25389 AJ=SIGN(1D0,EJ+0.1D0)
25391 EPS=(2D0*PMAS(10+JL,1))**2/SH
25392 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
25394 EPS=(2D0*PMAS(24,1))**2/SH
25395 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
25397 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
25398 IF(EPS.LE.1D0) THEN
25400 IF(EPS.GT.1D-4) THEN
25401 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25403 RLN=LOG(4D0/EPS-2D0)
25405 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25406 PHIIM=0.5D0*PARU(1)*RLN
25407 PSIRE=0.5D0*ROOT*RLN
25408 PSIIM=-0.5D0*ROOT*PARU(1)
25410 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25412 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
25415 IF(EPSP.LE.1D0) THEN
25416 ROOT=SQRT(1D0-EPSP)
25417 IF(EPSP.GT.1D-4) THEN
25418 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25420 RLN=LOG(4D0/EPSP-2D0)
25422 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
25423 PHIIMP=0.5D0*PARU(1)*RLN
25424 PSIREP=0.5D0*ROOT*RLN
25425 PSIIMP=-0.5D0*ROOT*PARU(1)
25427 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
25429 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
25432 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
25433 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
25434 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
25435 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
25436 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
25437 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
25438 IF(J.LE.3*MSTP(1)) THEN
25439 C...Fermion loops: loop integral different for A0; charges.
25440 IF(IHIGG.EQ.3) FXYRE=0D0
25441 IF(IHIGG.EQ.3) FXYIM=0D0
25442 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25444 EJH=PARU(151+10*IHIGG)
25445 ELSEIF(J.LE.2*MSTP(1)) THEN
25447 EJH=PARU(152+10*IHIGG)
25450 EJH=PARU(153+10*IHIGG)
25452 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
25453 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
25454 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
25455 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25456 C...W loops: loop integral and charges.
25457 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
25458 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
25459 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
25460 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25461 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
25462 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
25465 C...Charged H loops: loop integral and charges.
25466 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
25467 & PARU(158+10*IHIGG+2*(IHIGG/3))
25468 ETAREJ=FACHHH*FXYRE
25469 ETAIMJ=FACHHH*FXYIM
25474 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
25475 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
25478 ELSEIF(I.LE.17) THEN
25479 C...h0 -> Z0 + Z0, W+ + W-
25480 PM1=PMAS(IABS(KFDP(IDC,1)),1)
25481 PG1=PMAS(IABS(KFDP(IDC,1)),2)
25482 IF(MINT(62).GE.1) THEN
25483 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
25484 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
25485 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
25486 MOFSV(IHIGG,I-15)=0
25487 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
25491 MOFSV(IHIGG,I-15)=1
25492 RMAS=SQRT(MAX(0D0,SH))
25493 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
25495 WIDWSV(IHIGG,I-15)=WIDW
25496 WID2SV(IHIGG,I-15)=WID2
25499 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
25500 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
25504 WIDW=WIDWSV(IHIGG,I-15)
25505 WID2=WID2SV(IHIGG,I-15)
25508 WDTP(I)=FAC*WIDW/(2D0*(18-I))
25509 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
25510 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25511 & PARU(138+I+10*IHIGG)**2
25512 WID2=WID2*WIDS(7+I,1)
25514 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
25515 C...H0 -> Z0 + h0, A0-> Z0 + h0
25516 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
25517 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25518 IF(IHIGG.EQ.2) THEN
25519 WDTP(I)=WDTP(I)*PARU(179)**2
25520 ELSEIF(IHIGG.EQ.3) THEN
25521 WDTP(I)=WDTP(I)*PARU(186)**2
25523 WID2=WIDS(23,2)*WIDS(25,2)
25525 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
25526 C...H0 -> h0 + h0, A0-> h0 + h0
25527 WDTP(I)=FAC*0.25D0*
25528 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25529 IF(IHIGG.EQ.2) THEN
25530 WDTP(I)=WDTP(I)*PARU(176)**2
25531 ELSEIF(IHIGG.EQ.3) THEN
25532 WDTP(I)=WDTP(I)*PARU(169)**2
25535 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
25536 C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
25537 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
25538 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25539 & *PARU(195+IHIGG)**2
25541 WID2=WIDS(24,2)*WIDS(37,3)
25542 ELSEIF(I.EQ.21) THEN
25543 WID2=WIDS(24,3)*WIDS(37,2)
25546 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
25548 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
25549 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25550 WID2=WIDS(36,2)*WIDS(23,2)
25552 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
25554 WDTP(I)=FAC*0.5D0*PARU(180)**2*
25555 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25556 WID2=WIDS(25,2)*WIDS(36,2)
25558 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
25560 WDTP(I)=FAC*0.25D0*PARU(177)**2*
25561 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25566 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25569 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25570 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25571 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25576 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25578 IF(KFC2.EQ.KFC1) THEN
25582 IF(KFDP(IDC,1).LT.0) KSGN1=3
25584 IF(KFDP(IDC,2).LT.0) KSGN2=3
25585 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25588 WDTP(I)=FUDGE*WDTP(I)
25589 WDTP(0)=WDTP(0)+WDTP(I)
25590 IF(MDME(IDC,1).GT.0) THEN
25591 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25592 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25593 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25594 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25598 ELSEIF(KFLA.EQ.32) THEN
25601 XWC=1D0/(16D0*XW*XW1)
25602 FAC=(AEM*XWC/3D0)*SHR
25605 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25613 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25614 KFAI=IABS(MINT(15))
25615 EI=KCHG(KFAI,1)/3D0
25616 AI=SIGN(1D0,EI+0.1D0)
25619 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
25620 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
25621 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
25622 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
25623 VPI=PARU(119+2*KFAIC)
25624 API=PARU(120+2*KFAIC)
25625 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
25626 VPI=PARJ(178+2*KFAIC)
25627 API=PARJ(179+2*KFAIC)
25629 VPI=PARJ(186+2*KFAIC)
25630 API=PARJ(187+2*KFAIC)
25634 SQMZP=PMAS(32,1)**2
25636 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25637 & MSTP(44).EQ.7) VINT(111)=1D0
25638 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
25639 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25640 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
25641 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
25642 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25643 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25644 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
25645 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
25646 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
25647 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25648 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
25650 DO 290 I=1,MDCY(KC,3)
25652 IF(MDME(IDC,1).LT.0) GOTO 290
25653 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25654 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25655 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
25659 C...Z'0 -> q + qbar
25661 AF=SIGN(1D0,EF+0.1D0)
25664 VPF=PARU(123-2*MOD(I,2))
25665 APF=PARU(124-2*MOD(I,2))
25666 ELSEIF(I.LE.4) THEN
25667 VPF=PARJ(182-2*MOD(I,2))
25668 APF=PARJ(183-2*MOD(I,2))
25670 VPF=PARJ(190-2*MOD(I,2))
25671 APF=PARJ(191-2*MOD(I,2))
25674 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
25675 & PYHFTH(SH,SH*RM1,1D0)
25676 IF(I.EQ.6) WID2=WIDS(6,1)
25677 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25678 ELSEIF(I.LE.16) THEN
25679 C...Z'0 -> l+ + l-, nu + nubar
25681 AF=SIGN(1D0,EF+0.1D0)
25684 VPF=PARU(127-2*MOD(I,2))
25685 APF=PARU(128-2*MOD(I,2))
25686 ELSEIF(I.LE.12) THEN
25687 VPF=PARJ(186-2*MOD(I,2))
25688 APF=PARJ(187-2*MOD(I,2))
25690 VPF=PARJ(194-2*MOD(I,2))
25691 APF=PARJ(195-2*MOD(I,2))
25694 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25696 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25697 IF(ICASE.EQ.1) THEN
25698 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25699 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
25700 & APF**2*(1D0-4D0*RM1))*BE34
25701 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25702 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25703 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
25704 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
25705 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
25706 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
25707 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
25708 ELSEIF(MINT(61).EQ.2) THEN
25709 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25710 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25711 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
25712 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25713 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
25715 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
25718 ELSEIF(I.EQ.17) THEN
25720 WDTPZP=PARU(129)**2*XW1**2*
25721 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25722 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25723 IF(ICASE.EQ.1) THEN
25726 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25727 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25728 ELSEIF(MINT(61).EQ.2) THEN
25737 ELSEIF(I.EQ.18) THEN
25739 CZC=2D0*(1D0-2D0*XW)
25740 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25741 IF(ICASE.EQ.1) THEN
25742 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
25743 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
25744 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25745 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
25746 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
25747 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
25748 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
25749 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
25750 ELSEIF(MINT(61).EQ.2) THEN
25752 FGZF=0.25D0*PARU(142)*CZC*BE34C
25753 FGZPF=0.25D0*PARU(143)*CZC*BE34C
25754 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
25755 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
25756 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
25759 ELSEIF(I.EQ.19) THEN
25760 C...Z'0 -> Z0 + gamma.
25761 ELSEIF(I.EQ.20) THEN
25763 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25764 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
25765 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
25766 IF(ICASE.EQ.1) THEN
25769 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25770 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25771 ELSEIF(MINT(61).EQ.2) THEN
25779 WID2=WIDS(23,2)*WIDS(25,2)
25780 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
25781 C...Z' -> h0 + A0 or H0 + A0.
25782 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25790 IF(ICASE.EQ.1) THEN
25791 WDTPZ=CZAH**2*BE34C
25792 WDTP(I)=FAC*CZPAH**2*BE34C
25793 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25794 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
25795 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
25797 ELSEIF(MINT(61).EQ.2) THEN
25802 FZZPF=CZAH*CZPAH*BE34C
25803 FZPZPF=CZPAH**2*BE34C
25805 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
25806 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
25808 IF(ICASE.EQ.1) THEN
25809 VINT(117)=VINT(117)+FAC*WDTPZ
25810 WDTP(I)=FUDGE*WDTP(I)
25811 WDTP(0)=WDTP(0)+WDTP(I)
25813 IF(MDME(IDC,1).GT.0) THEN
25814 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25815 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25816 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25817 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25818 & WDTE(I,MDME(IDC,1))
25819 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25820 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25822 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25823 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25824 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
25825 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
25827 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
25829 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25830 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
25831 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
25833 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25834 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
25838 IF(MINT(61).GE.1) ICASE=3-ICASE
25839 IF(ICASE.EQ.2) GOTO 280
25841 ELSEIF(KFLA.EQ.34) THEN
25843 FAC=(AEM/(24D0*XW))*SHR
25844 DO 300 I=1,MDCY(KC,3)
25846 IF(MDME(IDC,1).LT.0) GOTO 300
25847 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25848 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25849 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
25853 C...W'+/- -> q + qbar'
25854 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
25855 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
25857 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25858 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25859 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25861 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25862 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25863 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25865 ELSEIF(I.LE.20) THEN
25866 C...W'+/- -> l+/- + nu
25867 FCOF=PARU(133)**2+PARU(134)**2
25869 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25871 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25874 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
25875 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25876 ELSEIF(I.EQ.21) THEN
25877 C...W'+/- -> W+/- + Z0
25878 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
25879 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25880 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25881 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
25882 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
25883 ELSEIF(I.EQ.23) THEN
25884 C...W'+/- -> W+/- + h0
25885 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25886 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
25887 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25888 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25890 WDTP(I)=FUDGE*WDTP(I)
25891 WDTP(0)=WDTP(0)+WDTP(I)
25892 IF(MDME(IDC,1).GT.0) THEN
25893 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25894 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25895 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25896 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25900 ELSEIF(KFLA.EQ.37) THEN
25902 C IF(MSTP(49).EQ.0) THEN
25905 C SHFS=PMAS(37,1)**2
25907 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25908 DO 310 I=1,MDCY(KC,3)
25910 IF(MDME(IDC,1).LT.0) GOTO 310
25911 KFC1=PYCOMP(KFDP(IDC,1))
25912 KFC2=PYCOMP(KFDP(IDC,2))
25913 RM1=PMAS(KFC1,1)**2/SH
25914 RM2=PMAS(KFC2,1)**2/SH
25915 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
25918 C...H+/- -> q + qbar'
25919 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
25920 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25921 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
25922 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
25923 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25925 IF(I.EQ.3) WID2=WIDS(6,2)
25926 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
25928 IF(I.EQ.3) WID2=WIDS(6,3)
25929 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
25931 ELSEIF(I.LE.8) THEN
25932 C...H+/- -> l+/- + nu
25933 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
25934 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
25935 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25937 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
25939 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
25941 ELSEIF(I.EQ.9) THEN
25942 C...H+/- -> W+/- + h0.
25943 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
25944 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25945 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25946 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25950 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25953 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25954 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25955 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25960 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25963 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
25965 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
25966 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25968 WDTP(I)=FUDGE*WDTP(I)
25969 WDTP(0)=WDTP(0)+WDTP(I)
25970 IF(MDME(IDC,1).GT.0) THEN
25971 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25972 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25973 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25974 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25978 ELSEIF(KFLA.EQ.41) THEN
25980 FAC=(AEM/(12D0*XW))*SHR
25981 DO 320 I=1,MDCY(KC,3)
25983 IF(MDME(IDC,1).LT.0) GOTO 320
25984 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25985 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25986 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
25991 ELSEIF(I.LE.9) THEN
25995 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25996 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25998 IF(I.EQ.4) WID2=WIDS(6,3)
25999 IF(I.EQ.5) WID2=WIDS(7,3)
26000 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
26001 IF(I.EQ.9) WID2=WIDS(17,3)
26003 IF(I.EQ.4) WID2=WIDS(6,2)
26004 IF(I.EQ.5) WID2=WIDS(7,2)
26005 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
26006 IF(I.EQ.9) WID2=WIDS(17,2)
26008 WDTP(I)=FUDGE*WDTP(I)
26009 WDTP(0)=WDTP(0)+WDTP(I)
26010 IF(MDME(IDC,1).GT.0) THEN
26011 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26012 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26013 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26014 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26018 ELSEIF(KFLA.EQ.42) THEN
26019 C...LQ (leptoquark).
26020 FAC=(AEM/4D0)*PARU(151)*SHR
26021 DO 330 I=1,MDCY(KC,3)
26023 IF(MDME(IDC,1).LT.0) GOTO 330
26024 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26025 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26026 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
26027 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26029 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
26030 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
26031 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
26032 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
26033 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
26034 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
26035 WDTP(I)=FUDGE*WDTP(I)
26036 WDTP(0)=WDTP(0)+WDTP(I)
26037 IF(MDME(IDC,1).GT.0) THEN
26038 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26039 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26040 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26041 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26045 C...UED: kk state width decays : flav: 451 476
26046 ELSEIF(IUED(1).EQ.1.AND.
26047 & PYCOMP(ABS(KFLA)).GE.KKFLMI.AND.
26048 & PYCOMP(ABS(KFLA)).LE.KKFLMA) THEN
26050 C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
26051 RMFLAS=PMAS(KCLA,1)
26052 FACSH=SH/PMAS(KCLA,1)**2
26053 ALPHEM=PYALEM(RMFLAS**2)
26054 ALPHS=PYALPS(RMFLAS**2)
26056 C...uedcor parameters (alpha_s is calculated at mkk scale)
26057 C...alpha_em is calculated at z pole !
26061 DO 1070 I=1,MDCY(KCLA,3)
26062 IDC=I+MDCY(KCLA,2)-1
26064 IF(MDME(IDC,1).LT.0) GOTO 1070
26065 KFC1=PYCOMP(ABS(KFDP(IDC,1)))
26066 KFC2=PYCOMP(ABS(KFDP(IDC,2)))
26067 RM1=PMAS(KFC1,1)**2/SH
26068 RM2=PMAS(KFC2,1)**2/SH
26069 IF(SQRT(RM1)+SQRT(RM2).GT.1D0)
26073 C...N.B. RINV=RUED(1)
26079 KKCLA=KCLA-KKFLMI+1
26080 IF(ABS(KFC1).GE.KKFLMI)KKPART=KFC1
26081 IF(ABS(KFC2).GE.KKFLMI)KKPART=KFC2
26082 IF(KKCLA.LE.6) THEN
26083 C...q*_S -> q + gamma* (in first time sw21=0)
26084 FAC=0.25*ALPHEM*RMFLAS*0.5*CW21/CW2*KCHG(KCLA,1)**2/9.
26085 C...Eventually change the following by enabling a choice of open or closed.
26086 C...Only the gamma_kk channel is open.
26088 + WDTP(I)=FAC*FKAC2(RMFLAS,RMKK)*FKAC1(RMKK,RMFLAS)**2
26089 WDTP(I)=FACSH*WDTP(I)
26091 ELSEIF(KKCLA.GT.6.AND.KKCLA.LE.12)THEN
26092 C...q*_D -> q + Z*/W*
26093 FAC=0.25*ALPHEM*RMFLAS/(4.*SW2)
26094 GAMMAW=FAC*FKAC2(RMFLAS,RMWKK)*FKAC1(RMWKK,RMFLAS)**2
26104 WDTP(I)=FACSH*WDTP(I)
26105 C...q*_D -> q + gamma* is closed
26106 ELSEIF(KKCLA.GT.12.AND.KKCLA.LE.21)THEN
26107 C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
26108 FAC=ALPHEM/4.*RMFLAS/CW2/8.
26110 WDTP(I)=FAC*FKAC2(RMFLAS,RMGAKK)*
26111 + FKAC1(RMGAKK,RMFLAS)**2
26112 WDTP(I)=FACSH*WDTP(I)
26114 ELSEIF(KKCLA.EQ.22)THEN
26115 RMQST=PMAS(KKPART,1)
26116 WID2=WIDS(KKPART,2)
26117 C...g* -> q*_S/q*_D + q
26118 FAC=10.*ALPHS/12.*RMFLAS
26119 WDTP(I)=FAC*FKAC1(RMQST,RMFLAS)**2*FKAC2(RMQST,RMFLAS)
26120 WDTP(I)=FACSH*WDTP(I)
26121 ELSEIF(KKCLA.EQ.23)THEN
26122 C...gamma* decays to graviton + gamma : initial value is used
26124 WDTP(I)=RMFLAS*(RMFLAS/RUED(2))**(IUED(4)+2)
26126 ELSEIF(KKCLA.EQ.24)THEN
26127 C...Z* -> l*_S + l is closed
26128 C... Z* -> l*_D + l
26129 IF(I.LE.3)GOTO 1070
26130 c... After closing the channels for a Z* decaying into positively charged
26131 C... KK lepton singlets, close the channels for a Z* decaying into negatively
26132 C... charged KK lepton singlets + positively charged SM particles
26133 IF(I.GE.10.AND.I.LE.12)GOTO 1070
26134 FAC=3./2.*ALPHEM/24./SW2*RMZKK
26135 RMLST=PMAS(KKPART,1)
26136 WDTP(I)=FAC*FKAC1(RMLST,RMZKK)**2*FKAC2(RMLST,RMZKK)
26137 WDTP(I)=FACSH*WDTP(I)
26138 WID2=WIDS(KKPART,2)
26139 ELSEIF(KKCLA.EQ.25)THEN
26140 C...W* -> l*_D lbar
26141 FAC=3.*ALPHEM/12./SW2*RMWKK
26142 RMLST=PMAS(KKPART,1)
26143 WDTP(I)=FAC*FKAC1(RMLST,RMWKK)**2*FKAC2(RMLST,RMWKK)
26144 WDTP(I)=FACSH*WDTP(I)
26145 WID2=WIDS(KKPART,2)
26147 WDTP(0)=WDTP(0)+WDTP(I)
26148 IF(MDME(IDC,1).GT.0) THEN
26149 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26150 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26151 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26152 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26157 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
26158 C...Techni-pi0 and techni-pi0':
26159 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26160 DO 340 I=1,MDCY(KC,3)
26162 IF(MDME(IDC,1).LT.0) GOTO 340
26163 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26164 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26167 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
26171 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
26172 & /(8D0*PARU(1))*SH*SHR
26173 IF(KFLA.EQ.KTECHN+111) THEN
26180 C...pi_tc -> f + fbar.
26182 IKA=IABS(KFDP(IDC,1))
26183 IF(IKA.LT.10) FCOF=3D0*RADC
26186 IF(IKA.GE.4.AND.IKA.LE.6) THEN
26187 FCOF=FCOF*RTCM(1+IKA)**2
26188 HM1=PYMRUN(KFDP(IDC,1),SH)
26189 HM2=PYMRUN(KFDP(IDC,2),SH)
26190 ELSEIF(IKA.EQ.15) THEN
26191 FCOF=FCOF*RTCM(8)**2
26193 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26194 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26196 WDTP(I)=FUDGE*WDTP(I)
26197 WDTP(0)=WDTP(0)+WDTP(I)
26198 IF(MDME(IDC,1).GT.0) THEN
26199 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26200 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26201 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26202 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26206 ELSEIF(KFLA.EQ.KTECHN+211) THEN
26208 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26209 DO 350 I=1,MDCY(KC,3)
26211 IF(MDME(IDC,1).LT.0) GOTO 350
26212 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26213 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26215 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26219 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
26221 C...pi_tc -> f + f'.
26223 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
26224 C...pi_tc+ -> W b b~
26225 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
26227 XMT2=PMAS(6,1)**2/SH
26228 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
26229 KFC3=PYCOMP(KFDP(IDC,3))
26230 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
26232 T0 = (1D0-CHECK**2)*
26233 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
26234 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
26235 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
26236 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
26237 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
26238 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
26247 IKA=IABS(KFDP(IDC,1))
26248 IF(IKA.LT.10) FCOF=3D0*RADC
26251 IF(I.GE.1.AND.I.LE.5) THEN
26253 FCOF=FCOF*RTCM(5)**2
26254 ELSEIF(I.LE.4) THEN
26255 FCOF=FCOF*RTCM(6)**2
26256 ELSEIF(I.EQ.5) THEN
26257 FCOF=FCOF*RTCM(7)**2
26259 HM1=PYMRUN(KFDP(IDC,1),SH)
26260 HM2=PYMRUN(KFDP(IDC,2),SH)
26261 ELSEIF(I.EQ.8) THEN
26262 FCOF=FCOF*RTCM(8)**2
26264 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26265 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26267 WDTP(I)=FUDGE*WDTP(I)
26268 WDTP(0)=WDTP(0)+WDTP(I)
26269 IF(MDME(IDC,1).GT.0) THEN
26270 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26271 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26272 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26273 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26277 ELSEIF(KFLA.EQ.KTECHN+331) THEN
26279 FAC=(SH/PARP(46)**2)*SHR
26280 DO 360 I=1,MDCY(KC,3)
26282 IF(MDME(IDC,1).LT.0) GOTO 360
26283 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26284 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26285 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
26288 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
26289 IF(I.EQ.2) WID2=WIDS(6,1)
26291 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
26293 WDTP(I)=FUDGE*WDTP(I)
26294 WDTP(0)=WDTP(0)+WDTP(I)
26295 IF(MDME(IDC,1).GT.0) THEN
26296 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26297 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26298 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26299 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26303 ELSEIF(KFLA.EQ.KTECHN+113) THEN
26305 ALPRHT=2.16D0*(3D0/ITCM(1))
26306 FAC=(ALPRHT/12D0)*SHR
26307 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26311 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26313 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26314 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26315 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26316 DO 370 I=1,MDCY(KC,3)
26318 IF(MDME(IDC,1).LT.0) GOTO 370
26319 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26320 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26321 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
26324 C...rho_tc0 -> W+ + W-.
26325 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26326 WDTP(I)=FAC*RTCM(3)**4*
26327 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26328 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26329 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26330 & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
26332 ELSEIF(I.EQ.2) THEN
26333 C...rho_tc0 -> W+ + pi_tc-.
26334 C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
26335 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26336 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26337 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26338 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
26339 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26340 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26341 ELSEIF(I.EQ.3) THEN
26342 C...rho_tc0 -> pi_tc+ + W-.
26343 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26344 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26345 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26346 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
26347 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26348 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
26349 ELSEIF(I.EQ.4) THEN
26350 C...rho_tc0 -> pi_tc+ + pi_tc-.
26351 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
26352 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26353 WID2=WIDS(PYCOMP(KTECHN+211),1)
26354 ELSEIF(I.EQ.5) THEN
26355 C...rho_tc0 -> gamma + pi_tc0
26356 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26357 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26359 WID2=WIDS(PYCOMP(KTECHN+111),2)
26360 ELSEIF(I.EQ.6) THEN
26361 C...rho_tc0 -> gamma + pi_tc0'
26362 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26363 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
26364 WID2=WIDS(PYCOMP(KTECHN+221),2)
26365 ELSEIF(I.EQ.7) THEN
26366 C...rho_tc0 -> Z0 + pi_tc0
26367 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26368 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26370 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
26371 ELSEIF(I.EQ.8) THEN
26372 C...rho_tc0 -> Z0 + pi_tc0'
26373 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26374 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
26376 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26377 ELSEIF(I.EQ.9) THEN
26378 C...rho_tc0 -> gamma + Z0
26379 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26380 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26382 ELSEIF(I.EQ.10) THEN
26383 C...rho_tc0 -> Z0 + Z0
26384 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26385 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
26389 C...rho_tc0 -> f + fbar.
26394 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26398 IF(IA.GE.17) WID2=WIDS(IA,1)
26401 AI=SIGN(1D0,EI+0.1D0)
26405 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26406 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26407 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26408 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
26410 WDTP(I)=FUDGE*WDTP(I)
26411 WDTP(0)=WDTP(0)+WDTP(I)
26412 IF(MDME(IDC,1).GT.0) THEN
26413 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26414 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26415 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26416 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26420 ELSEIF(KFLA.EQ.KTECHN+213) THEN
26422 ALPRHT=2.16D0*(3D0/ITCM(1))
26423 FAC=(ALPRHT/12D0)*SHR
26427 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
26429 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
26430 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26431 DO 380 I=1,MDCY(KC,3)
26433 IF(MDME(IDC,1).LT.0) GOTO 380
26434 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26435 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26436 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
26438 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26439 c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26442 C...rho_tc+ -> W+ + Z0.
26444 WDTP(I)=FAC*RTCM(3)**4*
26445 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26446 VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
26447 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
26449 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
26452 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
26454 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26457 WID2=WIDS(24,2)*WIDS(23,2)
26459 WID2=WIDS(24,3)*WIDS(23,2)
26461 ELSEIF(I.EQ.2) THEN
26462 C...rho_tc+ -> W+ + pi_tc0.
26463 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26464 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26465 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26466 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26467 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26469 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
26471 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
26473 ELSEIF(I.EQ.3) THEN
26474 C...rho_tc+ -> pi_tc+ + Z0.
26475 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26476 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26477 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26478 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
26479 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
26480 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26481 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26484 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
26486 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
26488 ELSEIF(I.EQ.4) THEN
26489 C...rho_tc+ -> pi_tc+ + pi_tc0.
26490 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
26491 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26493 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
26495 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
26497 ELSEIF(I.EQ.5) THEN
26498 C...rho_tc+ -> pi_tc+ + gamma
26499 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26500 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26503 WID2=WIDS(PYCOMP(KTECHN+211),2)
26505 WID2=WIDS(PYCOMP(KTECHN+211),3)
26507 ELSEIF(I.EQ.6) THEN
26508 C...rho_tc+ -> W+ + pi_tc0'
26509 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26510 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
26512 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
26514 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
26516 ELSEIF(I.EQ.7) THEN
26517 C...rho_tc+ -> W+ + gamma
26518 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26519 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26526 C...rho_tc+ -> f + fbar'.
26530 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
26532 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
26533 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
26534 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
26536 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
26537 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
26538 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
26543 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26545 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26548 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26549 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26551 WDTP(I)=FUDGE*WDTP(I)
26552 WDTP(0)=WDTP(0)+WDTP(I)
26553 IF(MDME(IDC,1).GT.0) THEN
26554 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26555 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26556 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26557 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26561 ELSEIF(KFLA.EQ.KTECHN+223) THEN
26563 ALPRHT=2.16D0*(3D0/ITCM(1))
26564 FAC=(ALPRHT/12D0)*SHR
26565 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
26568 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26570 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26571 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26572 DO 390 I=1,MDCY(KC,3)
26574 IF(MDME(IDC,1).LT.0) GOTO 390
26575 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26576 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26577 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
26580 C...omega_tc0 -> gamma + pi_tc0.
26581 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
26582 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
26583 WID2=WIDS(PYCOMP(KTECHN+111),2)
26584 ELSEIF(I.EQ.2) THEN
26585 C...omega_tc0 -> Z0 + pi_tc0
26586 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26587 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
26589 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
26590 ELSEIF(I.EQ.3) THEN
26591 C...omega_tc0 -> gamma + pi_tc0'
26592 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26593 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
26595 WID2=WIDS(PYCOMP(KTECHN+221),2)
26596 ELSEIF(I.EQ.4) THEN
26597 C...omega_tc0 -> Z0 + pi_tc0'
26598 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26599 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
26601 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26602 ELSEIF(I.EQ.5) THEN
26603 C...omega_tc0 -> W+ + pi_tc-
26604 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26605 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
26606 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
26607 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26608 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26609 ELSEIF(I.EQ.6) THEN
26610 C...omega_tc0 -> pi_tc+ + W-
26611 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26612 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
26613 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
26614 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26615 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
26616 ELSEIF(I.EQ.7) THEN
26617 C...omega_tc0 -> W+ + W-.
26618 C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26619 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
26620 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26621 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26622 & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
26624 ELSEIF(I.EQ.8) THEN
26625 C...omega_tc0 -> pi_tc+ + pi_tc-.
26626 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
26627 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26628 WID2=WIDS(PYCOMP(KTECHN+211),1)
26629 C...omega_tc0 -> gamma + Z0
26630 ELSEIF(I.EQ.9) THEN
26631 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26632 & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26634 C...omega_tc0 -> Z0 + Z0
26635 ELSEIF(I.EQ.10) THEN
26636 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26637 & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
26638 & /24D0/RTCM(12)**2*SHR**3
26641 C...omega_tc0 -> f + fbar.
26646 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26650 IF(IA.GE.17) WID2=WIDS(IA,1)
26653 AI=SIGN(1D0,EI+0.1D0)
26655 VALI=-0.5D0*(VI+AI)
26656 VARI=-0.5D0*(VI-AI)
26657 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26658 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26659 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26660 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
26662 WDTP(I)=FUDGE*WDTP(I)
26663 WDTP(0)=WDTP(0)+WDTP(I)
26664 IF(MDME(IDC,1).GT.0) THEN
26665 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26666 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26667 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26668 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26672 C.....V8 -> quark anti-quark
26673 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
26676 IF(ITCM(2).EQ.0) THEN
26678 ELSEIF(ITCM(2).EQ.1) THEN
26681 DO 400 I=1,MDCY(KC,3)
26683 IF(MDME(IDC,1).LT.0) GOTO 400
26684 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26686 IF(RM1.GT.0.25D0) GOTO 400
26688 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
26693 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
26694 IF(I.EQ.6) WID2=WIDS(6,1)
26695 WDTP(I)=FUDGE*WDTP(I)
26696 WDTP(0)=WDTP(0)+WDTP(I)
26697 IF(MDME(IDC,1).GT.0) THEN
26698 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26699 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26700 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26701 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26705 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
26706 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
26708 DO 410 I=1,MDCY(KC,3)
26710 IF(MDME(IDC,1).LT.0) GOTO 410
26711 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26712 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26713 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
26717 IF(KFLA.EQ.KTECHN+100111) THEN
26722 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
26723 & /(2D0*PARU(1))*SH*SHR*CLEBG
26726 C...pi_tc -> f + fbar.
26727 IF(I.EQ.6) WID2=WIDS(6,1)
26729 IKA=IABS(KFDP(IDC,1))
26730 IF(IKA.LT.10) FCOF=3D0*RADC
26731 HM1=PYMRUN(KFDP(IDC,1),SH)
26732 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
26733 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26735 WDTP(I)=FUDGE*WDTP(I)
26736 WDTP(0)=WDTP(0)+WDTP(I)
26737 IF(MDME(IDC,1).GT.0) THEN
26738 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26739 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26740 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26741 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26745 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
26747 ALPRHT=2.16D0*(3D0/ITCM(1))
26749 SIN2T=2D0*TANT3/(TANT3**2+1D0)
26750 SINT3=TANT3/SQRT(TANT3**2+1D0)
26753 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
26754 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
26755 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
26756 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
26757 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
26759 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
26761 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
26763 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
26765 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
26766 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
26767 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
26768 IF(ITCM(2).EQ.0) THEN
26773 DO 420 I=1,MDCY(KC,3)
26774 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
26775 & KFLA.EQ.KTECHN+300113)) GOTO 420
26777 IF(MDME(IDC,1).LT.0) GOTO 420
26778 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26779 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26780 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
26783 IF(I.EQ.6) WID2=WIDS(6,1)
26785 IF(KFLA.EQ.KTECHN+200113) THEN
26788 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
26791 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
26796 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
26797 FMIX=1D0/TANT3/SIN2T
26801 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
26802 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
26803 ELSEIF(I.EQ.7) THEN
26804 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
26805 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
26806 PSH=SHR*(1D0-RM1)/2D0
26807 WDTP(I)=AS/9D0*PSH**3/RM82
26809 WDTP(I)=2D0*WDTP(I)*CSXPP**2
26810 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
26812 WDTP(I)=5D0*WDTP(I)
26813 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
26816 WDTP(I)=FUDGE*WDTP(I)
26817 WDTP(0)=WDTP(0)+WDTP(I)
26818 IF(MDME(IDC,1).GT.0) THEN
26819 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26820 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26821 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26822 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26826 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
26827 C...d* excited quark.
26828 FAC=(SH/RTCM(41)**2)*SHR
26829 DO 430 I=1,MDCY(KC,3)
26831 IF(MDME(IDC,1).LT.0) GOTO 430
26832 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26833 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26834 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
26838 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26840 ELSEIF(I.EQ.2) THEN
26841 C...d* -> gamma + d.
26842 QF=-RTCM(43)/2D0+RTCM(44)/6D0
26843 WDTP(I)=FAC*AEM*QF**2/4D0
26845 ELSEIF(I.EQ.3) THEN
26847 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26848 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26849 & (1D0-RM1)**2*(2D0+RM1)
26851 ELSEIF(I.EQ.4) THEN
26853 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26854 & (1D0-RM1)**2*(2D0+RM1)
26855 IF(KFLR.GT.0) WID2=WIDS(24,3)
26856 IF(KFLR.LT.0) WID2=WIDS(24,2)
26858 WDTP(I)=FUDGE*WDTP(I)
26859 WDTP(0)=WDTP(0)+WDTP(I)
26860 IF(MDME(IDC,1).GT.0) THEN
26861 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26862 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26863 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26864 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26868 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
26869 C...u* excited quark.
26870 FAC=(SH/RTCM(41)**2)*SHR
26871 DO 440 I=1,MDCY(KC,3)
26873 IF(MDME(IDC,1).LT.0) GOTO 440
26874 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26875 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26876 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
26880 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26882 ELSEIF(I.EQ.2) THEN
26883 C...u* -> gamma + u.
26884 QF=RTCM(43)/2D0+RTCM(44)/6D0
26885 WDTP(I)=FAC*AEM*QF**2/4D0
26887 ELSEIF(I.EQ.3) THEN
26889 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26890 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26891 & (1D0-RM1)**2*(2D0+RM1)
26893 ELSEIF(I.EQ.4) THEN
26895 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26896 & (1D0-RM1)**2*(2D0+RM1)
26897 IF(KFLR.GT.0) WID2=WIDS(24,2)
26898 IF(KFLR.LT.0) WID2=WIDS(24,3)
26900 WDTP(I)=FUDGE*WDTP(I)
26901 WDTP(0)=WDTP(0)+WDTP(I)
26902 IF(MDME(IDC,1).GT.0) THEN
26903 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26904 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26905 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26906 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26910 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
26911 C...e* excited lepton.
26912 FAC=(SH/RTCM(41)**2)*SHR
26913 DO 450 I=1,MDCY(KC,3)
26915 IF(MDME(IDC,1).LT.0) GOTO 450
26916 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26917 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26918 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
26921 C...e* -> gamma + e.
26922 QF=-RTCM(43)/2D0-RTCM(44)/2D0
26923 WDTP(I)=FAC*AEM*QF**2/4D0
26925 ELSEIF(I.EQ.2) THEN
26927 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26928 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26929 & (1D0-RM1)**2*(2D0+RM1)
26931 ELSEIF(I.EQ.3) THEN
26933 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26934 & (1D0-RM1)**2*(2D0+RM1)
26935 IF(KFLR.GT.0) WID2=WIDS(24,3)
26936 IF(KFLR.LT.0) WID2=WIDS(24,2)
26938 WDTP(I)=FUDGE*WDTP(I)
26939 WDTP(0)=WDTP(0)+WDTP(I)
26940 IF(MDME(IDC,1).GT.0) THEN
26941 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26942 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26943 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26944 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26948 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
26949 C...nu*_e excited neutrino.
26950 FAC=(SH/RTCM(41)**2)*SHR
26951 DO 460 I=1,MDCY(KC,3)
26953 IF(MDME(IDC,1).LT.0) GOTO 460
26954 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26955 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26956 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
26959 C...nu*_e -> Z0 + nu*_e.
26960 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26961 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26962 & (1D0-RM1)**2*(2D0+RM1)
26964 ELSEIF(I.EQ.2) THEN
26965 C...nu*_e -> W+ + e.
26966 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26967 & (1D0-RM1)**2*(2D0+RM1)
26968 IF(KFLR.GT.0) WID2=WIDS(24,2)
26969 IF(KFLR.LT.0) WID2=WIDS(24,3)
26971 WDTP(I)=FUDGE*WDTP(I)
26972 WDTP(0)=WDTP(0)+WDTP(I)
26973 IF(MDME(IDC,1).GT.0) THEN
26974 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26975 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26976 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26977 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26981 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
26982 C...G* (graviton resonance):
26983 FAC=(PARP(50)**2/PARU(1))*SHR
26984 DO 470 I=1,MDCY(KC,3)
26986 IF(MDME(IDC,1).LT.0) GOTO 470
26987 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26988 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26989 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
26994 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
26995 & PYHFTH(SH,SH*RM1,1D0)
26996 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
26997 & (1D0+8D0*RM1/3D0)/320D0
26998 IF(I.EQ.6) WID2=WIDS(6,1)
26999 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
27000 ELSEIF(I.LE.16) THEN
27001 C...G* -> l+ + l-, nu + nubar
27003 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27004 & (1D0+8D0*RM1/3D0)/320D0
27005 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
27006 ELSEIF(I.EQ.17) THEN
27009 ELSEIF(I.EQ.18) THEN
27010 C...G* -> gamma + gamma.
27012 ELSEIF(I.EQ.19) THEN
27014 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27015 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
27017 ELSEIF(I.EQ.20) THEN
27019 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27020 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
27023 WDTP(I)=FUDGE*WDTP(I)
27024 WDTP(0)=WDTP(0)+WDTP(I)
27025 IF(MDME(IDC,1).GT.0) THEN
27026 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27027 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27028 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27029 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27033 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
27034 C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
27035 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
27036 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
27037 DO 480 I=1,MDCY(KC,3)
27039 IF(MDME(IDC,1).LT.0) GOTO 480
27040 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
27041 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
27042 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
27043 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
27046 C...nu_lR -> l- qbar q'
27047 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27048 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27049 ELSEIF(I.LE.18) THEN
27050 C...nu_lR -> l+ q qbar'
27051 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
27052 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
27054 C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
27056 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
27058 X=(PM1+PM2+PM3)/SHR
27059 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
27061 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
27062 WDTP(I)=FAC*FCOF*FX*FY
27063 WDTP(I)=FUDGE*WDTP(I)
27064 WDTP(0)=WDTP(0)+WDTP(I)
27065 IF(MDME(IDC,1).GT.0) THEN
27066 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27067 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27068 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27069 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27073 ELSEIF(KFLA.EQ.9900023) THEN
27075 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
27076 DO 490 I=1,MDCY(KC,3)
27078 IF(MDME(IDC,1).LT.0) GOTO 490
27079 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27080 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27081 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
27085 C...Z_R0 -> q + qbar
27087 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
27088 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
27090 IF(I.EQ.6) WID2=WIDS(6,1)
27091 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
27092 C...Z_R0 -> l+ + l-
27096 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
27097 C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
27102 ELSEIF(I.LE.15) THEN
27103 C...Z0 -> nu_R + nu_R, assumed Majorana.
27107 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
27110 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
27111 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
27112 WDTP(I)=FUDGE*WDTP(I)
27113 WDTP(0)=WDTP(0)+WDTP(I)
27114 IF(MDME(IDC,1).GT.0) THEN
27115 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27116 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27117 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27118 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27122 ELSEIF(KFLA.EQ.9900024) THEN
27124 FAC=(AEM/(24D0*XW))*SHR
27125 DO 500 I=1,MDCY(KC,3)
27127 IF(MDME(IDC,1).LT.0) GOTO 500
27128 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27129 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27130 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
27133 C...W_R+/- -> q + qbar'
27134 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27136 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27138 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
27140 ELSEIF(I.LE.12) THEN
27141 C...W_R+/- -> l+/- + nu_R
27144 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27145 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27146 WDTP(I)=FUDGE*WDTP(I)
27147 WDTP(0)=WDTP(0)+WDTP(I)
27148 IF(MDME(IDC,1).GT.0) THEN
27149 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27150 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27151 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27152 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27156 ELSEIF(KFLA.EQ.9900041) THEN
27158 FAC=(1D0/(8D0*PARU(1)))*SHR
27159 DO 510 I=1,MDCY(KC,3)
27161 IF(MDME(IDC,1).LT.0) GOTO 510
27162 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27163 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27164 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
27167 C...H_L++/-- -> l+/- + l'+/-
27168 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27169 & (IABS(KFDP(IDC,2))-9)/2)**2
27170 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27171 ELSEIF(I.EQ.7) THEN
27172 C...H_L++/-- -> W_L+/- + W_L+/-
27173 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
27174 & (3D0*RM1+0.25D0/RM1-1D0)
27175 WID2=WIDS(24,4+(1-KFLS)/2)
27178 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27179 WDTP(I)=FUDGE*WDTP(I)
27180 WDTP(0)=WDTP(0)+WDTP(I)
27181 IF(MDME(IDC,1).GT.0) THEN
27182 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27183 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27184 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27185 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27189 ELSEIF(KFLA.EQ.9900042) THEN
27191 FAC=(1D0/(8D0*PARU(1)))*SHR
27192 DO 520 I=1,MDCY(KC,3)
27194 IF(MDME(IDC,1).LT.0) GOTO 520
27195 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27196 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27197 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
27200 C...H_R++/-- -> l+/- + l'+/-
27201 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27202 & (IABS(KFDP(IDC,2))-9)/2)**2
27203 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27204 ELSEIF(I.EQ.7) THEN
27205 C...H_R++/-- -> W_R+/- + W_R+/-
27206 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
27207 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
27210 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27211 WDTP(I)=FUDGE*WDTP(I)
27212 WDTP(0)=WDTP(0)+WDTP(I)
27213 IF(MDME(IDC,1).GT.0) THEN
27214 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27215 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27216 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27217 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27221 ELSEIF(KFLA.EQ.KTECHN+115) THEN
27223 C...Need to update to alpha_rho
27224 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27225 FAC=(ALPRHT/12D0)*SHR
27226 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
27230 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
27232 XWRHT=1D0/(4D0*XW*(1D0-XW))
27233 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
27234 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
27235 DO 530 I=1,MDCY(KC,3)
27237 IF(MDME(IDC,1).LT.0) GOTO 530
27238 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27239 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27240 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
27242 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27245 FACPA=PCM**2+1.5D0*RM1
27248 C...a2_tc0 -> W+ + W-
27250 AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
27251 C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
27253 C...a2_tc0 -> W+ + pi_tc- + c.c.
27254 ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
27255 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27257 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27259 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
27261 ELSEIF(I.EQ.4) THEN
27262 C...a2_tc0 -> Z0 + pi_tc0'
27263 VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
27264 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27266 WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
27267 ELSEIF(I.GE.5.AND.I.LE.10) THEN
27268 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27269 FACPA=PCM**2*(1D0+RM1+RM2)
27273 C...a_T^0 -> gamma rho_T^0
27274 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27275 WID2=WIDS(PYCOMP(KTECHN+113),2)
27276 ELSEIF(I.EQ.6) THEN
27277 C...a_T^0 -> gamma omega_T
27278 VA2=1D0/RTCM(50)**4
27279 WID2=WIDS(PYCOMP(KTECHN+223),2)
27280 ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
27281 C...a_T^0 -> W^+- rho_T^-+
27282 AA2=.25D0/XW/RTCM(51)**4
27284 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
27286 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
27288 ELSEIF(I.EQ.9) THEN
27289 C...a_T^0 -> Z^0 rho_T^0
27290 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27291 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
27292 ELSEIF(I.EQ.10) THEN
27293 C...a_T^0 -> Z^0 omega_T
27294 VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
27295 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
27297 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27299 C...a2_tc0 -> f + fbar.
27304 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27308 IF(IA.GE.17) WID2=WIDS(IA,1)
27311 AI=SIGN(1D0,EI+0.1D0)
27315 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27316 & ((VALI*BWZR)**2+(VALI*BWZI)**2+
27317 & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27318 & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
27320 WDTP(I)=FUDGE*WDTP(I)
27321 WDTP(0)=WDTP(0)+WDTP(I)
27322 IF(MDME(IDC,1).GT.0) THEN
27323 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27324 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27325 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27326 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27330 ELSEIF(KFLA.EQ.KTECHN+215) THEN
27332 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27333 FAC=(ALPRHT/12D0)*SHR
27337 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
27339 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
27340 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
27341 DO 540 I=1,MDCY(KC,3)
27343 IF(MDME(IDC,1).LT.0) GOTO 540
27344 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27345 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27346 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
27348 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27357 C...a2_tc+ -> gamma + W+.
27359 AA2=RTCM(3)**2/RTCM(49)**2
27360 WID2=WIDS(24,ICHANN)
27361 C...a2_tc+ -> gamma + pi_tc+.
27362 ELSEIF(I.EQ.2) THEN
27363 AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
27364 WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
27365 C...a2_tc+ -> W+ + Z
27366 ELSEIF(I.EQ.3) THEN
27367 AA2=RTCM(3)**2*(1D0/4D0/XW1 +
27368 & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
27369 WID2=WIDS(24,ICHANN)*WIDS(23,2)
27370 C...a2_tc+ -> W+ + pi_tc0.
27371 ELSEIF(I.EQ.4) THEN
27372 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27373 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
27374 C...a2_tc+ -> W+ + pi_tc'0.
27375 ELSEIF(I.EQ.5) THEN
27376 VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
27377 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
27378 C...a2_tc+ -> Z0 + pi_tc+.
27379 ELSEIF(I.EQ.6) THEN
27380 AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
27382 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
27384 WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27386 ELSEIF(I.LE.10) THEN
27387 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27388 FACPA=PCM**2*(1D0+RM1+RM2)
27391 C...a2_tc+ -> gamma + rho_tc+
27393 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27394 WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
27395 C...a2_tc+ -> W+ + rho_T^0
27396 ELSEIF(I.EQ.8) THEN
27397 AA2=1D0/(4D0*XW)/RTCM(51)**4
27398 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
27399 C...a2_tc+ -> W+ + omega_T
27400 ELSEIF(I.EQ.9) THEN
27401 VA2=.25D0/XW/RTCM(50)**4
27402 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
27403 C...a2_tc+ -> Z^0 + rho_T^+
27404 ELSEIF(I.EQ.10) THEN
27405 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27406 AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
27407 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
27409 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27411 C...a2_tc+ -> f + fbar'.
27415 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
27417 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
27418 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
27419 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
27421 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
27422 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
27423 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
27428 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
27430 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
27433 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27434 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27436 WDTP(I)=FUDGE*WDTP(I)
27437 WDTP(0)=WDTP(0)+WDTP(I)
27438 IF(MDME(IDC,1).GT.0) THEN
27439 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27440 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27441 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27442 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27453 C***********************************************************************
27456 C...Calculates partial width and differential cross-section maxima
27457 C...of channels/processes not allowed on mass-shell, and selects
27458 C...masses in such channels/processes.
27460 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
27462 C...Double precision and integer declarations.
27463 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27464 IMPLICIT INTEGER(I-N)
27465 INTEGER PYK,PYCHGE,PYCOMP
27467 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27468 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27469 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
27470 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27471 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27472 COMMON/PYINT1/MINT(400),VINT(400)
27473 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27474 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
27475 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
27478 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
27479 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
27480 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
27483 C...Find if particles equal, maximum mass, matrix elements, etc.
27489 IF(KFD(1).EQ.KFD(2)) MEQL=1
27491 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
27492 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
27498 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
27501 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
27502 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
27503 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
27504 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
27505 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
27506 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
27509 C...Find where Breit-Wigners are required, else select discrete masses.
27511 KFCA=PYCOMP(KFD(I))
27513 PMD(I)=PMAS(KFCA,1)
27514 PGD(I)=PMAS(KFCA,2)
27519 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
27522 RMG(I)=(PMG(I)/PMMX)**2
27528 C...Find allowed mass range and Breit-Wigner parameters.
27530 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
27532 PMU(I)=PMMX-PARP(42)
27533 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
27534 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27535 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
27537 IF(MLM.EQ.2) ILM=3-I
27538 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
27539 IF(MBW(3-I).EQ.0) THEN
27540 PMU(I)=PMMX-PMD(3-I)
27542 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
27544 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
27545 & MIN(PMU(I),CKIN(NOFF+2*ILM))
27546 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
27547 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
27548 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27549 IF(MBW(I).EQ.1) THEN
27550 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27551 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27552 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
27555 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
27557 IF(MLM.EQ.2) ILM=3-I
27558 PML(I)=MAX(CKIN(48+I),PARP(42))
27559 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
27560 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
27561 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
27562 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
27563 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27564 IF(MBW(I).EQ.1) THEN
27565 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27566 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27567 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
27572 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
27574 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
27579 C...Calculation of partial width of resonance.
27580 IF(MOFSH.EQ.1) THEN
27582 C..If only one integration, pick that to be the inner.
27583 IF(MBW(1).EQ.0) THEN
27589 ELSEIF(MBW(2).EQ.0) THEN
27593 C...Start outer loop of integration.
27594 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27595 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
27596 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
27602 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27603 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
27604 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
27608 C...Start inner loop of integration.
27610 PMU1=MIN(PMU(1),PMMX-PM2)
27611 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
27612 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
27613 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
27614 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
27622 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
27623 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
27626 C...Evaluate function value - inner loop.
27627 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27628 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
27629 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
27630 & RM2**2+10D0*RM1*RM2)
27631 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
27634 C...Go to next position in inner loop.
27640 ELSEIF(NPT1.LE.8) THEN
27642 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
27644 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
27645 INX1(NPT1)=INX1(ISH1)
27648 ELSEIF(NPT1.LT.100) THEN
27651 IF(ISH1.GT.NPT1) ISH1=2
27652 IF(ISH1.EQ.ISN1) GOTO 160
27653 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
27654 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
27656 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
27657 INX1(NPT1)=INX1(ISH1)
27662 C...Calculate integral over inner loop.
27665 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
27666 & (XPT1(INX1(IPT1))-XPT1(IPT1))
27668 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
27669 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27670 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
27673 C...Go to next position in outer loop.
27679 ELSEIF(NPT2.LE.8) THEN
27681 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
27683 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
27684 INX2(NPT2)=INX2(ISH2)
27687 ELSEIF(NPT2.LT.100) THEN
27690 IF(ISH2.GT.NPT2) ISH2=2
27691 IF(ISH2.EQ.ISN2) GOTO 200
27692 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
27693 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
27695 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
27696 INX2(NPT2)=INX2(ISH2)
27701 C...Calculate integral over outer loop.
27704 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
27705 & (XPT2(INX2(IPT2))-XPT2(IPT2))
27707 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
27708 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
27713 C...Save result; second integration for user-selected mass range.
27714 IF(LOOP.EQ.1) WIDW=FSUM2
27716 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
27717 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
27724 C...Select two decay product masses of a resonance.
27725 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
27727 IF(MBW(I).EQ.0) GOTO 230
27728 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
27730 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
27731 RMG(I)=(PMG(I)/PMMX)**2
27733 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
27734 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
27736 C...Weight with matrix element (if none known, use beta factor).
27737 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
27739 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
27740 ELSEIF(MMED.EQ.2) THEN
27741 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
27742 & RMG(2)**2+10D0*RMG(1)*RMG(2))
27743 ELSEIF(MMED.EQ.3) THEN
27744 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
27748 IF(WTBE.LT.PYR(0)) GOTO 220
27752 C...Find suitable set of masses for initialization of 2 -> 2 processes.
27753 ELSEIF(MOFSH.EQ.3) THEN
27754 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
27755 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
27757 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
27759 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
27763 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
27764 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
27765 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
27770 C...Evaluate importance of excluded tails of Breit-Wigners.
27771 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
27772 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
27776 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
27780 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
27781 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
27783 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
27784 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
27785 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
27786 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27788 C...Pick one particle to be the lighter (if improves efficiency).
27789 ELSEIF(MOFSH.EQ.4) THEN
27790 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
27791 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
27792 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
27794 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
27796 IF(MBW(I).EQ.0) GOTO 270
27798 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
27800 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
27802 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27803 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
27804 IF(RBR.LT.0.8D0) THEN
27805 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
27806 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
27807 ELSEIF(RBR.LT.0.9D0) THEN
27808 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
27809 ELSEIF(RBR.LT.1.5D0) THEN
27810 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
27812 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
27813 & (PMV**2-PML(I)**2))))
27816 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
27817 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
27818 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
27819 NGEN(0,1)=NGEN(0,1)+1
27820 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
27830 C...Give weight for selected mass distribution.
27833 IF(MBW(I).EQ.0) GOTO 280
27835 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
27837 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
27838 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
27839 & (PMD(I)*PGD(I))**2)/PARU(1)
27843 FI0=(ATV-ATL(I))/PARU(1)
27844 FI1=PMV**2-PML(I)**2
27845 FI2=2D0*LOG(PMV/PML(I))
27846 FI3=1D0/PML(I)**2-1D0/PMV**2
27847 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27848 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
27849 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
27852 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
27854 VINT(80)=VINT(80)*FI0
27856 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27862 C***********************************************************************
27865 C...Handles the possibility of colour reconnection in W+W- events,
27866 C...Based on the main scenarios of the Sjostrand and Khoze study:
27867 C...I, II, II', intermediate and instantaneous; plus one model
27868 C...along the lines of the Gustafson and Hakkinen: GH.
27869 C...Note: also handles Z0 Z0 and W-W+ events, but notation below
27870 C...is as if first resonance is W+ and second W-.
27872 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
27874 C...Double precision and integer declarations.
27875 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27876 IMPLICIT INTEGER(I-N)
27877 INTEGER PYK,PYCHGE,PYCOMP
27878 C...Parameter value; number of points in MC integration.
27879 PARAMETER (NPT=100)
27881 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27882 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27883 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27884 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27885 COMMON/PYINT1/MINT(400),VINT(400)
27886 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27888 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
27889 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
27890 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
27891 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
27892 &TMC(20),IJOIN(100)
27894 C...Functions to give four-product and to do determinants.
27895 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)
27896 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
27897 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
27898 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
27900 C...Only allow fraction of recoupling for GH, intermediate and
27902 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27903 IF(PYR(0).GT.PARP(120)) RETURN
27907 C...Common part for scenarios I, II, II', and GH.
27908 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
27909 &MSTP(115).EQ.5) THEN
27911 C...Read out frequently-used parameters.
27915 IF(ISUB.EQ.22) PMW=PMAS(23,1)
27917 IF(ISUB.EQ.22) PGW=PMAS(23,2)
27924 C...Find range of decay products of the W's.
27925 C...Background: the W's are stored in IW1 and IW2.
27926 C...Their direct decay products in NSD1+1 through NSD1+4.
27927 C...Products after shower (if any) in NSD1+5 through NAFT1
27928 C...for first W and in NAFT1+1 through N for the second.
27929 IF(NAFT1.GT.NSD1+4) THEN
27936 IF(N.GT.NAFT1) THEN
27944 C...Rearrange parton shower products along strings.
27946 CALL PYPREP(NSD1+1)
27947 IF(MINT(51).NE.0) RETURN
27949 C...Find partons pointing back to W+ and W-; store them with quark
27950 C...end of string first.
27956 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
27957 IF(IABS(K(I,2)).GE.22) GOTO 120
27958 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
27959 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
27969 IF(K(I,1).EQ.1) ISGP=0
27970 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
27971 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
27981 IF(K(I,1).EQ.1) ISGM=0
27985 C...Boost to W+W- rest frame (not strictly needed).
27987 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
27989 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27990 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27991 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27993 C...Select decay vertices of W+ and W-.
27994 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
27995 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
27996 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
27997 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
28000 XP(J)=TP*P(IW1,J)/P(IW1,4)
28001 XM(J)=TM*P(IW2,J)/P(IW2,4)
28004 C...Begin scenario I specifics.
28005 IF(MSTP(115).EQ.1) THEN
28007 C...Reconstruct velocity and direction of W+ string pieces.
28009 IF(K(INP(IIP),2).LT.0) GOTO 170
28012 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28013 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28017 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
28018 DIRP(IIP,J)=V1(J)-V2(J)
28020 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
28022 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
28024 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
28028 C...Reconstruct velocity and direction of W- string pieces.
28030 IF(K(INM(IIM),2).LT.0) GOTO 200
28033 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28034 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28038 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
28039 DIRM(IIM,J)=V1(J)-V2(J)
28041 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
28043 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
28045 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
28049 C...Loop over number of space-time points.
28054 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
28055 R=SQRT(-LOG(PYR(0)))
28057 X=BLOWR*RHAD*R*COS(PHI)
28058 Y=BLOWR*RHAD*R*SIN(PHI)
28059 R=SQRT(-LOG(PYR(0)))
28061 Z=BLOWR*RHAD*R*COS(PHI)
28062 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
28064 C...Reject impossible points. Weight for sample distribution.
28065 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
28066 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
28067 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
28069 C...Loop over W+ string pieces and find one with largest weight.
28077 IF(K(INP(IIP),2).LT.0) GOTO 220
28078 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
28079 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
28081 XB(J)=XD(J)+BEDG*BETP(IIP,J)
28083 XB(4)=BETP(IIP,4)*(XD(4)-BED)
28084 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28085 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
28086 & DIRP(IIP,3)*XB(3))**2
28087 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28089 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
28090 IF(WTP.GT.WTMAXP) THEN
28096 C...Loop over W- string pieces and find one with largest weight.
28104 IF(K(INM(IIM),2).LT.0) GOTO 240
28105 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
28106 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
28108 XB(J)=XD(J)+BEDG*BETM(IIM,J)
28110 XB(4)=BETM(IIM,4)*(XD(4)-BED)
28111 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28112 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
28113 & DIRM(IIM,3)*XB(3))**2
28114 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28116 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
28117 IF(WTM.GT.WTMAXM) THEN
28123 C...Result of integration.
28125 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
28126 WT=WTMAXP*WTMAXM/WTSMP
28134 RES=BLOWR**3*BLOWT*SUM/NPT
28136 C...Decide whether to reconnect and, if so, where.
28138 PREC=1D0-EXP(-FACT*RES)
28139 IF(PREC.GT.PYR(0)) THEN
28144 IF(RSUM.LE.0D0) GOTO 270
28150 C...Begin scenario II and II' specifics.
28151 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
28153 C...Loop through all string pieces, one from W+ and one from W-.
28157 IF(K(INP(IIP),2).LT.0) GOTO 340
28161 IF(K(INM(IIM),2).LT.0) GOTO 330
28165 C...Find endpoint velocity vectors.
28167 V1P(J)=P(I1P,J)/P(I1P,4)
28168 V2P(J)=P(I2P,J)/P(I2P,4)
28169 V1M(J)=P(I1M,J)/P(I1M,4)
28170 V2M(J)=P(I2M,J)/P(I2M,4)
28173 C...Define q matrix and find t.
28175 Q(1,J)=V2P(J)-V1P(J)
28176 Q(2,J)=-(V2M(J)-V1M(J))
28177 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
28178 Q(4,J)=V1P(J)-V1M(J)
28180 T=-DETER(1,2,3)/DETER(1,2,4)
28182 C...Find alpha and beta; i.e. coordinates of crossing point.
28185 S13=Q(3,1)+Q(4,1)*T
28188 S23=Q(3,2)+Q(4,2)*T
28189 DEN=S11*S22-S12*S21
28190 ALP=(S12*S23-S22*S13)/DEN
28191 BET=(S21*S13-S11*S23)/DEN
28193 C...Check if solution acceptable.
28195 IF(T.LT.GTMAX) IANSW=0
28196 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
28197 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
28199 C...Find point of crossing and check that not inconsistent.
28201 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
28202 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
28204 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
28205 & (XPP(3)-XMM(3))**2
28206 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
28207 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
28208 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
28210 C...Find string eigentimes at crossing.
28211 IF(IANSW.EQ.1) THEN
28212 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
28213 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
28214 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
28215 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
28221 C...Order crossings by time. End loop over crossings.
28222 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
28224 DO 310 I1=NCROSS,1,-1
28225 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
28245 C...Loop over crossings; find first (if any) acceptable one.
28247 IF(NCROSS.GE.1) THEN
28249 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
28250 IF(PNFRAG.GT.PYR(0)) THEN
28251 C...Scenario II: only compare with fragmentation time.
28252 IF(MSTP(115).EQ.2) THEN
28257 C...Scenario II': also require that string length decreases.
28265 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28266 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28267 IF(ELNEW.LT.ELOLD) THEN
28279 C...Begin scenario GH specifics.
28280 ELSEIF(MSTP(115).EQ.5) THEN
28282 C...Loop through all string pieces, one from W+ and one from W-.
28286 IF(K(INP(IIP),2).LT.0) GOTO 380
28290 IF(K(INM(IIM),2).LT.0) GOTO 370
28294 C...Look for largest decrease of (exponent of) Lambda measure.
28295 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28296 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28297 ELDIF=ELNEW/MAX(1D-10,ELOLD)
28298 IF(ELDIF.LT.ELMIN) THEN
28310 C...Common for scenarios I, II, II' and GH: reconnect strings.
28314 DO 390 IS=1,NNP+NNM
28318 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
28320 ELSEIF(IS.LE.IIP+NNM) THEN
28321 I=INM(IS-IIP-NNM+IIM)
28326 IF(K(I,2).LT.0) THEN
28327 CALL PYJOIN(NJOIN,IJOIN)
28332 C...Restore original event record if no reconnection.
28334 DO 400 I=NSD1+1,NOLD
28335 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
28336 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28337 K(I,5)=MOD(K(I,5),MSTU(5)**2)
28346 C...Boost back system.
28347 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
28348 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
28349 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
28350 & BEWW(1),BEWW(2),BEWW(3))
28352 C...Common part for intermediate and instantaneous scenarios.
28353 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
28356 C...Remove old shower products and reset showering ones.
28358 DO 420 I=NSD1+1,NSD1+4
28360 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28361 K(I,5)=MOD(K(I,5),MSTU(5)**2)
28364 C...Identify quark-antiquark pairs.
28368 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
28371 C...Reconnect strings.
28374 CALL PYJOIN(2,IJOIN)
28377 CALL PYJOIN(2,IJOIN)
28379 C...Do new parton showers in intermediate scenario.
28380 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
28383 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
28384 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
28387 C...Do new parton showers in instantaneous scenario.
28388 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
28389 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
28390 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
28391 PPM=SQRT(MAX(0D0,PPM2))
28392 CALL PYSHOW(IQ1,IQ4,PPM)
28393 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
28394 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
28395 PPM=SQRT(MAX(0D0,PPM2))
28396 CALL PYSHOW(IQ3,IQ2,PPM)
28403 C***********************************************************************
28406 C...Checks generated variables against pre-set kinematical limits;
28407 C...also calculates limits on variables used in generation.
28409 SUBROUTINE PYKLIM(ILIM)
28411 C...Double precision and integer declarations.
28412 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28413 IMPLICIT INTEGER(I-N)
28414 INTEGER PYK,PYCHGE,PYCOMP
28416 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28417 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28418 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28419 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28420 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28421 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28422 COMMON/PYINT1/MINT(400),VINT(400)
28423 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28424 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
28427 C...Common kinematical expressions.
28431 IF(ISUB.EQ.96) GOTO 100
28435 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
28436 CKIN09=MAX(CKIN(9),CKIN(13))
28437 CKIN10=MIN(CKIN(10),CKIN(14))
28438 CKIN11=MAX(CKIN(11),CKIN(15))
28439 CKIN12=MIN(CKIN(12),CKIN(16))
28441 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
28442 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
28443 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
28444 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
28449 RM3=SQM3/(TAU*VINT(2))
28450 RM4=SQM4/(TAU*VINT(2))
28451 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
28454 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
28455 &PTHMIN=MAX(CKIN(3),CKIN(5))
28458 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
28459 C...pre-set kinematical limits.
28464 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
28465 X1=SQRT(TAUE)*EXP(YST)
28466 X2=SQRT(TAUE)*EXP(-YST)
28468 IF(MINT(47).NE.1) THEN
28469 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
28470 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
28471 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
28472 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
28474 IF(MINT(45).NE.1) THEN
28475 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
28477 IF(MINT(46).NE.1) THEN
28478 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
28480 IF(MINT(45).EQ.2) THEN
28481 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
28483 IF(MINT(46).EQ.2) THEN
28484 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
28486 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
28487 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
28488 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
28489 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
28490 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
28491 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
28492 Y3=YST+0.5D0*LOG(EXPY3)
28493 Y4=YST+0.5D0*LOG(EXPY4)
28498 STH=SQRT(MAX(0D0,1D0-CTH**2))
28499 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
28500 & CTH)**2-4D0*RM3))
28501 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
28502 & CTH)**2-4D0*RM4))
28503 IF(STH.GE.1D-10) THEN
28504 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
28506 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
28508 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
28509 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
28510 ETALAR=MAX(ETA3,ETA4)
28511 ETASMA=MIN(ETA3,ETA4)
28513 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
28514 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
28515 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
28516 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
28518 RPTS=4D0*VINT(71)**2/SH
28519 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
28520 RM34=MAX(1D-20,2D0*RM3*RM4)
28521 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28522 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28523 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
28524 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
28525 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
28526 IF(PTH.LT.PTHMIN) MINT(51)=1
28527 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
28528 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
28529 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
28530 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
28531 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
28532 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
28533 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
28534 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
28535 IF(THA.LT.CKIN(35)) MINT(51)=1
28536 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
28537 IF(UHA.LT.CKIN(37)) MINT(51)=1
28538 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
28540 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28541 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
28542 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
28545 C...Additional cuts on W2 (approximately) in DIS.
28546 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
28548 IF(IABS(MINT(12)).LT.20) XBJ=X1
28550 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
28551 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
28552 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
28555 ELSEIF(ILIM.EQ.1) THEN
28556 C...Calculate limits on tau
28557 C...0) due to definition
28560 C...1) due to limits on subsystem mass
28561 TAUMN1=CKIN(1)**2/VINT(2)
28563 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
28564 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
28565 TM3=SQRT(SQM3+PTHMIN**2)
28566 TM4=SQRT(SQM4+PTHMIN**2)
28568 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
28569 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
28571 C...3) due to limits on pT-hat and cos(theta-hat)
28572 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
28573 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
28575 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
28576 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
28577 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
28579 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
28580 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
28581 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
28582 C...4) due to limits on x1 and x2
28583 TAUMN4=CKIN(21)*CKIN(23)
28584 TAUMX4=CKIN(22)*CKIN(24)
28585 C...5) due to limits on xF
28587 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
28588 C...6) due to limits on that and uhat
28589 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
28591 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
28592 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
28594 C...Net effect of all separate limits.
28595 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
28596 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
28597 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28600 ELSEIF(MINT(47).EQ.5) THEN
28601 VINT(31)=MIN(VINT(31),1D0-2D-10)
28602 ELSEIF(MINT(47).GE.6) THEN
28603 VINT(31)=MIN(VINT(31),1D0-1D-10)
28605 IF(VINT(31).LE.VINT(11)) MINT(51)=1
28607 ELSEIF(ILIM.EQ.2) THEN
28608 C...Calculate limits on y*
28610 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28612 C...0) due to kinematics
28615 C...1) due to explicit limits
28618 C...2) due to limits on x1
28619 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
28620 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
28621 C...3) due to limits on x2
28622 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
28623 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
28624 C...4) due to limits on xF
28625 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
28626 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
28627 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
28628 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
28629 C...5) due to simultaneous limits on y-large and y-small
28630 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
28631 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
28632 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
28633 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
28634 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
28635 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
28636 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
28638 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
28639 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
28640 RZMX=BE34*MIN(CKIN(28),CTHLIM)
28641 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
28642 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
28643 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
28644 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
28645 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
28646 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
28648 C...Net effect of all separate limits.
28649 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
28650 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
28651 IF(MINT(47).EQ.1) THEN
28654 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28655 VINT(12)=(1D0-1D-9)*YSTMX0
28656 VINT(32)=(1D0+1D-9)*YSTMX0
28657 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28658 VINT(12)=-(1D0+1D-9)*YSTMX0
28659 VINT(32)=-(1D0-1D-9)*YSTMX0
28660 ELSEIF(MINT(47).EQ.5) THEN
28661 YSTEE=LOG((1D0-1D-10)/TAURT)
28662 VINT(12)=MAX(VINT(12),-YSTEE)
28663 VINT(32)=MIN(VINT(32),YSTEE)
28665 IF(VINT(32).LE.VINT(12)) MINT(51)=1
28667 ELSEIF(ILIM.EQ.3) THEN
28668 C...Calculate limits on cos(theta-hat)
28670 C...0) due to definition
28675 C...1) due to explicit limits
28676 CTNMN1=MIN(0D0,CKIN(27))
28677 CTNMX1=MIN(0D0,CKIN(28))
28678 CTPMN1=MAX(0D0,CKIN(27))
28679 CTPMX1=MAX(0D0,CKIN(28))
28680 C...2) due to limits on pT-hat
28681 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
28685 IF(CKIN(4).GE.0D0) THEN
28686 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
28687 & (BE34**2*TAU*VINT(2))))
28690 C...3) due to limits on y-large and y-small
28691 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
28692 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
28693 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
28694 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
28695 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
28696 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
28697 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
28698 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
28699 C...4) due to limits on that
28705 IF(CKIN(35).GT.0D0) THEN
28706 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
28707 IF(CTLIM.GT.0D0) THEN
28714 IF(CKIN(36).GT.0D0) THEN
28715 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
28716 IF(CTLIM.LT.0D0) THEN
28723 C...5) due to limits on uhat
28728 IF(CKIN(37).GT.0D0) THEN
28729 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
28730 IF(CTLIM.LT.0D0) THEN
28737 IF(CKIN(38).GT.0D0) THEN
28738 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
28739 IF(CTLIM.GT.0D0) THEN
28747 C...Net effect of all separate limits.
28748 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
28749 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
28750 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
28751 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
28752 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
28754 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
28755 IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
28757 ELSEIF(ILIM.EQ.4) THEN
28758 C...Calculate limits on tau'
28759 C...0) due to kinematics
28761 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
28762 PQRAT=(VINT(201)+VINT(206))/VINT(1)
28763 TAPMN0=(SQRT(TAU)+PQRAT)**2
28766 C...1) due to explicit limits
28767 TAPMN1=CKIN(31)**2/VINT(2)
28769 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
28771 C...Net effect of all separate limits.
28772 VINT(16)=MAX(TAPMN0,TAPMN1)
28773 VINT(36)=MIN(TAPMX0,TAPMX1)
28774 IF(MINT(47).EQ.1) THEN
28777 ELSEIF(MINT(47).EQ.5) THEN
28778 VINT(36)=MIN(VINT(36),1D0-2D-10)
28779 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
28780 VINT(36)=MIN(VINT(36),1D0-1D-10)
28782 IF(VINT(36).LE.VINT(16)) MINT(51)=1
28787 C...Special case for low-pT and multiple interactions:
28788 C...effective kinematical limits for tau, y*, cos(theta-hat).
28789 100 IF(ILIM.EQ.0) THEN
28790 ELSEIF(ILIM.EQ.1) THEN
28791 IF(MSTP(82).LE.1) THEN
28792 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
28795 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
28798 ELSEIF(ILIM.EQ.2) THEN
28799 VINT(12)=0.5D0*LOG(VINT(21))
28801 ELSEIF(ILIM.EQ.3) THEN
28802 IF(MSTP(82).LE.1) THEN
28803 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
28804 & (VINT(21)*VINT(2))
28806 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
28807 & (VINT(21)*VINT(2))
28809 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
28818 C*********************************************************************
28821 C...Maps a uniform distribution into a distribution of a kinematical
28822 C...variable according to one of the possibilities allowed. It is
28823 C...assumed that kinematical limits have been set by a PYKLIM call.
28825 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
28827 C...Double precision and integer declarations.
28828 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28829 IMPLICIT INTEGER(I-N)
28830 INTEGER PYK,PYCHGE,PYCOMP
28832 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28833 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28834 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28835 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28836 COMMON/PYINT1/MINT(400),VINT(400)
28837 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28838 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
28840 C...Convert VVAR to tau variable.
28846 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
28849 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
28852 ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
28856 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28858 ELSEIF(MVAR.EQ.1) THEN
28859 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
28860 ELSEIF(MVAR.EQ.2) THEN
28861 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
28862 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
28863 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
28864 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
28865 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
28866 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
28867 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
28868 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
28869 ELSEIF(MINT(47).EQ.5) THEN
28870 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
28871 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
28872 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28874 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
28875 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
28876 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28878 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
28880 C...Convert VVAR to y* variable.
28881 ELSEIF(IVAR.EQ.2) THEN
28885 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28886 IF(MINT(47).EQ.1) THEN
28888 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28889 YST=-0.5D0*LOG(TAUE)
28890 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28891 YST=0.5D0*LOG(TAUE)
28892 ELSEIF(MVAR.EQ.1) THEN
28893 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
28894 ELSEIF(MVAR.EQ.2) THEN
28895 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
28896 ELSEIF(MVAR.EQ.3) THEN
28897 AUPP=ATAN(EXP(YSTMAX))
28898 ALOW=ATAN(EXP(YSTMIN))
28899 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
28900 ELSEIF(MVAR.EQ.4) THEN
28901 YST0=-0.5D0*LOG(TAUE)
28902 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
28903 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28904 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
28906 YST0=-0.5D0*LOG(TAUE)
28907 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28908 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
28909 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
28911 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
28913 C...Convert VVAR to cos(theta-hat) variable.
28914 ELSEIF(IVAR.EQ.3) THEN
28915 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
28917 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28918 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28926 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28927 VCTN=VVAR*(ANEG+APOS)/ANEG
28928 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
28930 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28931 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
28933 ELSEIF(MVAR.EQ.2) THEN
28934 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28935 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28936 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28937 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28938 ANEG=LOG(RMNMIN/RMNMAX)
28939 APOS=LOG(RMPMIN/RMPMAX)
28940 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28941 VCTN=VVAR*(ANEG+APOS)/ANEG
28942 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
28944 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28945 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
28947 ELSEIF(MVAR.EQ.3) THEN
28948 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28949 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28950 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28951 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28952 ANEG=LOG(RMNMAX/RMNMIN)
28953 APOS=LOG(RMPMAX/RMPMIN)
28954 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28955 VCTN=VVAR*(ANEG+APOS)/ANEG
28956 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
28958 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28959 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
28961 ELSEIF(MVAR.EQ.4) THEN
28962 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28963 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28964 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28965 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28966 ANEG=1D0/RMNMAX-1D0/RMNMIN
28967 APOS=1D0/RMPMAX-1D0/RMPMIN
28968 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28969 VCTN=VVAR*(ANEG+APOS)/ANEG
28970 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
28972 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28973 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
28975 ELSEIF(MVAR.EQ.5) THEN
28976 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28977 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28978 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28979 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28980 ANEG=1D0/RMNMIN-1D0/RMNMAX
28981 APOS=1D0/RMPMIN-1D0/RMPMAX
28982 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28983 VCTN=VVAR*(ANEG+APOS)/ANEG
28984 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
28986 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28987 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
28990 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
28991 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
28994 C...Convert VVAR to tau' variable.
28995 ELSEIF(IVAR.EQ.4) THEN
28999 IF(MINT(47).EQ.1) THEN
29001 ELSEIF(MVAR.EQ.1) THEN
29002 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
29003 ELSEIF(MVAR.EQ.2) THEN
29004 AUPP=(1D0-TAU/TAUPMX)**4
29005 ALOW=(1D0-TAU/TAUPMN)**4
29006 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
29007 ELSEIF(MINT(47).EQ.5) THEN
29008 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
29009 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
29010 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29012 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
29013 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
29014 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29016 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
29018 C...Selection of extra variables needed in 2 -> 3 process:
29019 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
29020 C...Since no options are available, the functions of PYKLIM
29021 C...and PYKMAP are joint for these choices.
29022 ELSEIF(IVAR.EQ.5) THEN
29024 C...Read out total energy and particle masses.
29027 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
29028 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
29030 SHP=VINT(26)*VINT(2)
29034 PM3=SQRT(VINT(21))*VINT(1)
29035 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
29042 C...Specify coefficients of pT choice; upper and lower limits.
29043 IF(MPTPK.EQ.1) THEN
29051 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
29053 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
29055 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
29057 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
29060 C...Select transverse momenta according to
29061 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
29064 IF(HMX.LT.1.0001D0*HMN) THEN
29070 IF(RPT.LT.HWT1) THEN
29071 PTS1=PTSMN1+PYR(0)*HDE
29072 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29073 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
29075 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
29077 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
29078 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
29081 IF(HMX.LT.1.0001D0*HMN) THEN
29087 IF(RPT.LT.HWT1) THEN
29088 PTS2=PTSMN2+PYR(0)*HDE
29089 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29090 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
29092 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
29094 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
29095 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
29097 C...Select azimuthal angles and check pT choice.
29098 PHI1=PARU(2)*PYR(0)
29099 PHI2=PARU(2)*PYR(0)
29101 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
29102 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
29103 & CKIN(56)**2)) THEN
29108 C...Calculate transverse masses and check phase space not closed.
29115 PM12=(PMT1+PMT2)**2
29116 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
29121 C...Select rapidity for particle 3 and check phase space not closed.
29122 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
29123 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
29124 IF(Y3MAX.LT.1D-6) THEN
29128 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
29132 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
29135 PMS12=PE12**2-PZ12**2
29136 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
29137 IF(SQL12.LT.1D-6*SHP) THEN
29141 PMM1=PMS12+PMS1-PMS2
29142 PMM2=PMS12+PMS2-PMS1
29143 TFAC=-SHPR/(2D0*PMS12)
29144 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
29145 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
29146 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
29147 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
29149 C...Construct relative mirror weights and make choice.
29150 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
29154 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
29155 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
29157 WTP=WTPU/(WTPU+WTNU)
29158 WTN=WTNU/(WTPU+WTNU)
29160 IF(WTN.GT.PYR(0)) EPS=-1D0
29162 C...Store result of variable choice and associated weights.
29172 IF(EPS.GT.0D0) THEN
29181 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
29182 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
29183 VINT(219)=0.5D0*(PMS12-PTS3)
29190 C***********************************************************************
29193 C...Differential matrix elements for all included subprocesses
29194 C...Note that what is coded is (disregarding the COMFAC factor)
29195 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
29196 C...when d(sigma-hat) is given in the zero-width limit, the delta
29197 C...function in tau is replaced by a (modified) Breit-Wigner:
29198 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
29199 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
29200 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
29201 C...i.e., dimensionless quantities
29202 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
29203 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
29204 C...(2pi)^4 delta^4(P - sum p_i)
29205 C...COMFAC contains the factor pi/s (or equivalent) and
29206 C...the conversion factor from GeV^-2 to mb
29208 SUBROUTINE PYSIGH(NCHN,SIGS)
29210 C...Double precision and integer declarations
29211 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29212 IMPLICIT INTEGER(I-N)
29213 INTEGER PYK,PYCHGE,PYCOMP
29214 C...Parameter statement to help give large particle numbers.
29215 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29216 &KEXCIT=4000000,KDIMEN=5000000)
29218 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
29219 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29220 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29221 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29222 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29223 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29224 COMMON/PYINT1/MINT(400),VINT(400)
29225 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29226 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29227 COMMON/PYINT4/MWID(500),WIDS(500,5)
29228 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
29229 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29230 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29231 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29232 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
29233 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
29234 COMMON/PYPUED/IUED(0:99),RUED(0:99)
29235 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29236 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29237 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29238 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29239 COMMON/PYTCCO/COEFX(194:380,2)
29240 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
29241 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
29242 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/
29243 C...Local arrays and complex variables
29244 DIMENSION XPQ(-25:25)
29246 C...Map of processes onto which routine to call
29247 C...in order to evaluate cross section:
29248 C...0 = not implemented;
29249 C...1 = standard QCD (including photons);
29250 C...2 = heavy flavours;
29252 C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
29254 C...6 = Technicolor;
29255 C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29256 C...8 = Universal Extra Dimensions
29257 DIMENSION MAPPR(500)
29258 DATA (MAPPR(I),I=1,180)/
29259 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
29260 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
29261 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
29262 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
29263 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29264 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
29265 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
29266 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
29267 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29268 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
29269 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
29270 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
29271 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
29272 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29273 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
29274 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
29275 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
29276 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
29277 DATA (MAPPR(I),I=181,500)/
29278 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
29279 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
29281 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29282 & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
29284 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
29285 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
29286 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
29287 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
29288 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
29289 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
29291 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29292 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29294 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29295 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29298 C...Reset number of channels and cross-section
29302 C...Read process to consider.
29307 C...Read kinematical variables and limits
29325 C...Derive kinematical quantities
29327 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
29328 X(1)=SQRT(TAUE)*EXP(YST)
29329 X(2)=SQRT(TAUE)*EXP(-YST)
29330 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
29331 IF(X(1).GT.1D0-1D-7) RETURN
29332 ELSEIF(MINT(45).EQ.3) THEN
29333 X(1)=MIN(1D0-1.1D-10,X(1))
29335 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
29336 IF(X(2).GT.1D0-1D-7) RETURN
29337 ELSEIF(MINT(46).EQ.3) THEN
29338 X(2)=MIN(1D0-1.1D-10,X(2))
29340 SH=MAX(1D0,TAU*VINT(2))
29345 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
29346 RPTS=4D0*VINT(71)**2/SH
29347 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
29348 RM34=MAX(1D-20,2D0*RM3*RM4)
29350 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
29351 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
29352 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
29353 IF(ISTSB.EQ.0) THEN
29355 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
29356 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
29358 C...Kinematics with incoming masses tricky: now depends on how
29359 C...subprocess has been set up w.r.t. order of incoming partons.
29361 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
29363 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
29364 IF(ISUB.EQ.35) THEN
29368 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
29369 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
29370 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
29372 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
29374 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
29381 C...Choice of Q2 scale for hard process (e.g. alpha_s).
29382 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
29384 ELSEIF(ISTSB.EQ.8) THEN
29385 IF(MINT(107).EQ.4) Q2=VINT(307)
29386 IF(MINT(108).EQ.4) Q2=VINT(308)
29387 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
29389 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
29391 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
29392 IF(MSTP(32).EQ.1) THEN
29393 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
29394 ELSEIF(MSTP(32).EQ.2) THEN
29395 Q2=SQPTH+0.5D0*(SQM3+SQM4)
29396 ELSEIF(MSTP(32).EQ.3) THEN
29398 ELSEIF(MSTP(32).EQ.4) THEN
29400 ELSEIF(MSTP(32).EQ.5) THEN
29402 ELSEIF(MSTP(32).EQ.6) THEN
29404 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
29406 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
29407 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
29408 & (SQPTH+0.5D0*(SQM3+SQM4))
29409 ELSEIF(MSTP(32).EQ.7) THEN
29410 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
29411 ELSEIF(MSTP(32).EQ.8) THEN
29412 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
29413 ELSEIF(MSTP(32).EQ.9) THEN
29414 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
29415 ELSEIF(MSTP(32).EQ.10) THEN
29418 ELSEIF(MSTP(32).EQ.11) THEN
29419 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
29420 ELSEIF(MSTP(32).EQ.12) THEN
29423 ELSEIF(MSTP(32).EQ.13) THEN
29426 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
29427 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
29428 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
29431 C...Choice of Q2 scale for parton densities.
29434 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
29435 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
29438 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29440 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
29441 & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
29442 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
29443 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
29444 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
29445 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
29446 IF(MSTP(39).EQ.2) Q2SF=
29447 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
29448 IF(MSTP(39).EQ.3) Q2SF=SH
29449 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
29450 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
29452 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
29453 IF(MSTP(39).EQ.7) Q2SF=
29454 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
29455 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
29459 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
29463 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
29464 IF(MSTP(69).GE.2) Q2SF=VINT(2)
29466 C...Identify to which class(es) subprocess belongs
29470 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
29471 & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
29472 & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
29473 & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
29474 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
29475 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
29476 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
29477 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
29478 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
29479 IF (ISTSB.EQ.9) ISQCD=1
29480 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
29481 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
29482 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
29483 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
29484 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
29485 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
29486 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
29487 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
29488 C...WBF is special case of ISJETS
29489 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
29490 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
29491 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
29492 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
29493 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
29494 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
29495 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
29496 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
29497 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
29498 C...Some processes with photons also belong here.
29499 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
29500 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
29501 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
29502 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
29503 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
29504 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
29506 C...Choice of Q2 scale for parton-shower activity.
29507 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
29508 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
29510 IF(MINT(43).EQ.3) XBJ=X(1)
29511 IF(MSTP(22).EQ.1) THEN
29513 ELSEIF(MSTP(22).EQ.2) THEN
29514 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
29515 ELSEIF(MSTP(22).EQ.3) THEN
29516 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
29518 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
29521 C...For multiple interactions, start from scale defined above
29522 C...For all other QCD or "+jets"-type events, start shower from pThard.
29523 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
29524 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
29525 C...Max shower scale = s for ME corrected processes.
29526 C...(pT-ordering: max pT2 is s/4)
29528 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
29529 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
29530 C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
29531 C...(pT-ordering: max pT2 is s/4)
29533 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
29535 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
29537 C...Elastic and diffractive events not associated with scales so set 0.
29538 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
29543 C...Store derived kinematical quantities
29550 IF(ISTSB.NE.8) VINT(48)=SQPTH
29551 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
29552 VINT(50)=TAUP*VINT(2)
29553 VINT(49)=SQRT(MAX(0D0,VINT(50)))
29557 VINT(53)=SQRT(Q2SF)
29559 VINT(55)=SQRT(Q2PS)
29561 C...Set starting scale for multiple interactions
29562 IF (ISUBSV.EQ.95) THEN
29564 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
29565 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
29566 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
29567 & ISUBSV.NE.96)) THEN
29568 C...All accessible phase space allowed.
29569 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
29571 C...Scale of hard process sets limit.
29572 C...2 -> 1. Limit is tau = x1*x2.
29573 C...2 -> 2. Limit is XT2 for hard process + FS masses.
29574 C...2 -> n > 2. Limit is tau' = tau of outer process.
29576 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
29578 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
29579 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
29581 VINT(62)=0.25D0*XT2GMX*VINT(2)
29582 VINT(61)=SQRT(MAX(0D0,VINT(62)))
29584 C...Calculate parton distributions
29585 IF(ISTSB.LE.0) GOTO 160
29586 IF(MINT(47).GE.2) THEN
29587 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
29589 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
29590 IF(ISUB.EQ.99) THEN
29591 IF(MINT(140+I).EQ.0) THEN
29592 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
29594 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
29599 MINT(105)=MINT(102+I)
29600 MINT(109)=MINT(106+I)
29601 VINT(120)=VINT(2+I)
29603 C.... Store side in MINT(124)
29606 IF(MSTP(57).LE.1) THEN
29607 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
29609 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
29611 C...Safety margin against heavy flavour very close to threshold,
29612 C...e.g. caused by mismatch in c and b masses.
29613 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
29617 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
29622 XSFX(I,KFL)=XPQ(KFL)
29627 C...Calculate alpha_em, alpha_strong and K-factor
29630 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
29631 &1D0-(PMAS(24,1)/PMAS(23,1))**2
29633 XWC=1D0/(16D0*XW*XW1)
29635 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
29636 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
29639 IF(MSTP(33).EQ.1) THEN
29641 ELSEIF(MSTP(33).EQ.2) THEN
29643 FACA=PARP(32)/PARP(31)
29644 ELSEIF(MSTP(33).EQ.3) THEN
29646 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
29647 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
29654 C...Set flags for allowed reacting partons/leptons
29659 IF(MINT(44+I).EQ.1) THEN
29660 KFAC(I,MINT(10+I))=1
29661 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
29662 KFAC(I,MINT(10+I))=1
29668 KFAC(I,J)=KFIN(I,J)
29669 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
29670 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
29675 C...Lower and upper limit for fermion flavour loops
29681 IF(KFAC(1,-J).EQ.1) MMIN1=-J
29682 IF(KFAC(1,J).EQ.1) MMAX1=J
29683 IF(KFAC(2,-J).EQ.1) MMIN2=-J
29684 IF(KFAC(2,J).EQ.1) MMAX2=J
29686 MMINA=MIN(MMIN1,MMIN2)
29687 MMAXA=MAX(MMAX1,MMAX2)
29689 C...Common resonance mass and width combinations
29692 GMMZ=PMAS(23,1)*PMAS(23,2)
29693 GMMW=PMAS(24,1)*PMAS(24,2)
29695 C...Polarization factors...implemented so far for W+W-(25)
29696 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
29697 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
29698 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
29699 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
29701 C...Phase space integral in tau
29702 COMFAC=PARU(1)*PARU(5)/VINT(2)
29703 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
29704 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
29705 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
29706 ATAU1=LOG(TAUMAX/TAUMIN)
29707 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
29708 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
29709 IF(MINT(72).GE.1) THEN
29712 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
29714 IF(ATAUD.GT.1D-10) H1=H1+
29715 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
29716 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
29718 IF(ATAUD.GT.1D-10) H1=H1+
29719 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
29721 IF(MINT(72).GE.2) THEN
29724 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
29726 IF(ATAUD.GT.1D-10) H1=H1+
29727 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
29728 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
29730 IF(ATAUD.GT.1D-10) H1=H1+
29731 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
29733 IF(MINT(72).EQ.3) THEN
29736 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
29738 IF(ATAUD.GT.1D-10) H1=H1+
29739 & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
29740 ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
29742 IF(ATAUD.GT.1D-10) H1=H1+
29743 & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
29745 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
29746 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
29747 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
29748 & MAX(2D-10,1D0-TAU)
29749 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
29750 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
29751 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
29752 & MAX(1D-10,1D0-TAU)
29754 COMFAC=COMFAC*ATAU1/(TAU*H1)
29757 C...Phase space integral in y*
29758 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
29760 AYST0=YSTMAX-YSTMIN
29761 IF(AYST0.LT.1D-10) THEN
29764 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29766 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29767 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29768 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29769 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29770 IF(MINT(45).EQ.3) THEN
29771 YST0=-0.5D0*LOG(TAUE)
29772 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
29773 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
29774 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
29775 & MAX(1D-10,1D0-EXP(YST-YST0))
29777 IF(MINT(46).EQ.3) THEN
29778 YST0=-0.5D0*LOG(TAUE)
29779 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
29780 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
29781 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
29782 & MAX(1D-10,1D0-EXP(-YST-YST0))
29784 COMFAC=COMFAC*AYST0/H2
29788 C...2 -> 1 processes: reduction in angular part of phase space integral
29789 C...for case of decaying resonance
29790 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
29791 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
29792 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
29793 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
29794 & KFPR(ISUB,1).EQ.39) THEN
29795 COMFAC=COMFAC*0.5D0*ACTH0
29797 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
29798 & CTPMAX**3-CTPMIN**3)
29802 C...2 -> 2 processes: angular part of phase space integral
29803 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
29804 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
29805 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
29806 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
29807 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
29808 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
29809 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
29810 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
29811 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
29812 H3=COEF(ISUBSV,13)+
29813 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
29814 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
29815 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
29816 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
29817 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
29819 C...2 -> 2 processes: take into account final state Breit-Wigners
29820 COMFAC=COMFAC*VINT(80)
29823 C...2 -> 3, 4 processes: phace space integral in tau'
29824 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29825 ATAUP1=LOG(TAUPMX/TAUPMN)
29826 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
29827 H4=COEF(ISUBSV,18)+
29828 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
29829 IF(MINT(47).EQ.5) THEN
29830 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
29831 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
29832 ELSEIF(MINT(47).GE.6) THEN
29833 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
29834 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
29836 COMFAC=COMFAC*ATAUP1/H4
29839 C...2 -> 3, 4 processes: effective W/Z parton distributions
29840 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
29841 IF(1D0-TAU/TAUP.GT.1D-4) THEN
29842 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
29844 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
29849 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
29850 IF(ISTSB.EQ.5) THEN
29851 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
29852 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
29855 C...Phase space integral for low-pT and multiple interactions
29856 IF(ISTSB.EQ.9) THEN
29857 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
29858 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
29859 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
29860 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
29861 COMFAC=COMFAC*ATAU1/H1
29862 AYST0=YSTMAX-YSTMIN
29863 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29864 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29865 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29866 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29867 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29868 COMFAC=COMFAC*AYST0/H2
29869 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
29870 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
29871 C...introduced to make cross-section finite for xT2 -> 0
29872 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
29876 C...Real gamma + gamma: include factor 2 when different nature
29877 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
29878 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
29880 C...Extra factors to include the effects of
29881 C...longitudinal resolved photons (but not direct or DIS ones).
29883 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
29884 & MINT(106+ISDE).LE.3) THEN
29887 IF(MSTP(16).EQ.0) THEN
29888 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
29889 & XY=VINT(304+ISDE)
29891 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
29892 & XY=VINT(308+ISDE)
29894 Q2GA=VINT(306+ISDE)
29895 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
29896 & Q2GA.GT.0D0) THEN
29898 IF(MSTP(17).EQ.1) THEN
29899 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
29900 ELSEIF(MSTP(17).EQ.2) THEN
29901 REDUCE=4D0*Q2GA/(Q2+Q2GA)
29902 ELSEIF(MSTP(17).EQ.3) THEN
29903 PMVIRT=PMAS(PYCOMP(113),1)
29904 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29905 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
29906 PMVIRT=PMAS(PYCOMP(113),1)
29907 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29908 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
29909 PMVIRT=PMAS(PYCOMP(113),1)
29910 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29911 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
29912 PMVSMN=4D0*PARP(15)**2
29913 PMVSMX=4D0*VINT(154)**2
29914 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29915 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
29916 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
29917 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
29918 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
29919 PMVIRT=PMAS(PYCOMP(113),1)
29920 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29921 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
29922 PMVIRT=PMAS(PYCOMP(113),1)
29923 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29924 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
29925 PMVSMN=4D0*PARP(15)**2
29926 PMVSMX=4D0*VINT(154)**2
29927 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29928 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
29929 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
29932 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
29933 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
29934 & (1D0-2D0*BEAMAS**2/Q2GA))
29935 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
29940 COMFAC=COMFAC*VINT(314+ISDE)
29943 C...Evaluate cross sections - done in separate routines by kind
29944 C...of physics, to keep PYSIGH of sensible size.
29946 C...Standard QCD (including photons).
29947 CALL PYSGQC(NCHN,SIGS)
29948 ELSEIF(MAP.EQ.2) THEN
29949 C...Heavy flavours.
29950 CALL PYSGHF(NCHN,SIGS)
29951 ELSEIF(MAP.EQ.3) THEN
29953 CALL PYSGWZ(NCHN,SIGS)
29954 ELSEIF(MAP.EQ.4) THEN
29955 C...Higgs (2 doublets; including longitudinal W/Z scattering).
29956 CALL PYSGHG(NCHN,SIGS)
29957 ELSEIF(MAP.EQ.5) THEN
29959 CALL PYSGSU(NCHN,SIGS)
29960 ELSEIF(MAP.EQ.6) THEN
29962 CALL PYSGTC(NCHN,SIGS)
29963 ELSEIF(MAP.EQ.7) THEN
29964 C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29965 CALL PYSGEX(NCHN,SIGS)
29966 ELSEIF(MAP.EQ.8) THEN
29967 C... Universal Extra Dimensions
29968 CALL PYXUED(NCHN,SIGS)
29971 C...Multiply with parton distributions
29972 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
29974 IF(MINT(45).GE.2) THEN
29976 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
29978 IF(MINT(46).GE.2) THEN
29980 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
29982 SIGS=SIGS+SIGH(ICHN)
29989 C*********************************************************************
29992 C...Subprocess cross sections for QCD processes,
29993 C...including photons.
29994 C...Auxiliary to PYSIGH.
29996 SUBROUTINE PYSGQC(NCHN,SIGS)
29998 C...Double precision and integer declarations
29999 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30000 IMPLICIT INTEGER(I-N)
30001 INTEGER PYK,PYCHGE,PYCOMP
30002 C...Parameter statement to help give large particle numbers.
30003 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30004 &KEXCIT=4000000,KDIMEN=5000000)
30006 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30007 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30008 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
30009 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30010 COMMON/PYINT1/MINT(400),VINT(400)
30011 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30012 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30013 COMMON/PYINT4/MWID(500),WIDS(500,5)
30014 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
30015 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30016 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30017 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30018 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30019 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
30020 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
30022 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30024 C...Differential cross section expressions.
30026 IF(ISUB.LE.20) THEN
30027 IF(ISUB.EQ.10) THEN
30028 C...f + f' -> f + f' (gamma/Z/W exchange)
30029 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
30030 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
30031 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
30032 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
30033 DO 110 I=MMIN1,MMAX1
30034 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
30036 DO 100 J=MMIN2,MMAX2
30037 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
30039 C...Electroweak couplings
30040 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
30041 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
30043 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
30044 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
30047 C...gamma/Z exchange, only gamma exchange, or only Z exchange
30048 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
30049 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
30050 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
30051 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
30052 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
30053 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30054 ELSEIF(MSTP(21).EQ.2) THEN
30055 FACNCF=FACGGF*EI**2*EJ**2
30057 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
30058 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30060 C...Extrafactor 2 for only one incoming neutrino spin state.
30061 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
30062 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
30070 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
30071 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
30072 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
30073 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
30074 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
30084 ELSEIF(ISUB.EQ.11) THEN
30085 C...f + f' -> f + f' (g exchange)
30086 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30087 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30088 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30089 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
30090 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
30091 DO 130 I=MMIN1,MMAX1
30093 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
30094 DO 120 J=MMIN2,MMAX2
30096 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
30102 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30104 SIGH(NCHN)=0.5D0*SIGH(NCHN)
30109 SIGH(NCHN)=0.5D0*FACQQ2
30114 ELSEIF(ISUB.EQ.12) THEN
30115 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
30116 CALL PYWIDT(21,SH,WDTP,WDTE)
30117 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30118 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
30119 DO 140 I=MMINA,MMAXA
30120 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30121 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
30129 ELSEIF(ISUB.EQ.13) THEN
30130 C...f + fbar -> g + g (q + qbar -> g + g only)
30131 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30133 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30135 DO 150 I=MMINA,MMAXA
30136 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30137 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
30142 SIGH(NCHN)=0.5D0*FACGG1
30147 SIGH(NCHN)=0.5D0*FACGG2
30150 ELSEIF(ISUB.EQ.14) THEN
30151 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
30152 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
30153 DO 160 I=MMINA,MMAXA
30154 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30155 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
30156 EI=KCHG(IABS(I),1)/3D0
30161 SIGH(NCHN)=FACGG*EI**2
30164 ELSEIF(ISUB.EQ.18) THEN
30165 C...f + fbar -> gamma + gamma
30166 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
30167 DO 170 I=MMINA,MMAXA
30168 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
30169 EI=KCHG(IABS(I),1)/3D0
30171 IF(IABS(I).LE.10) FCOI=FACA/3D0
30176 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
30180 ELSEIF(ISUB.LE.40) THEN
30181 IF(ISUB.EQ.28) THEN
30182 C...f + g -> f + g (q + g -> q + g only)
30183 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30185 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30187 DO 190 I=MMINA,MMAXA
30188 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
30190 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
30191 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
30194 ISIG(NCHN,3-ISDE)=21
30199 ISIG(NCHN,3-ISDE)=21
30205 ELSEIF(ISUB.EQ.29) THEN
30206 C...f + g -> f + gamma (q + g -> q + gamma only)
30207 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
30208 DO 210 I=MMINA,MMAXA
30209 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
30210 EI=KCHG(IABS(I),1)/3D0
30213 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
30214 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
30217 ISIG(NCHN,3-ISDE)=21
30223 ELSEIF(ISUB.EQ.33) THEN
30224 C...f + gamma -> f + g (q + gamma -> q + g only)
30225 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
30226 DO 230 I=MMINA,MMAXA
30227 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
30228 EI=KCHG(IABS(I),1)/3D0
30231 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
30232 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
30235 ISIG(NCHN,3-ISDE)=22
30241 ELSEIF(ISUB.EQ.34) THEN
30242 C...f + gamma -> f + gamma
30243 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
30244 DO 250 I=MMINA,MMAXA
30245 IF(I.EQ.0) GOTO 250
30246 EI=KCHG(IABS(I),1)/3D0
30249 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
30250 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
30253 ISIG(NCHN,3-ISDE)=22
30260 ELSEIF(ISUB.LE.80) THEN
30261 IF(ISUB.EQ.53) THEN
30262 C...g + g -> f + fbar (g + g -> q + qbar only)
30263 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
30265 C...Begin by d, u, s flavours.
30267 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30268 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30269 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30270 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30271 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30272 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30273 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30274 & UH2/SH2)*FLAVWT*FACA
30275 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30276 & TH2/SH2)*FLAVWT*FACA
30287 C...Next c and b flavours: modified that and uhat for fixed
30288 C...cos(theta-hat).
30290 SQMAVG=PMAS(IFL,1)**2
30291 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30292 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30293 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30294 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30295 THUHQ=THQ*UHQ-SQMAVG*SH
30296 IF(MSTP(34).EQ.0) THEN
30297 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30298 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30300 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30301 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30302 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30303 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30305 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30306 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30310 ISIG(NCHN,3)=1+2*(IFL-3)
30315 ISIG(NCHN,3)=2+2*(IFL-3)
30321 ELSEIF(ISUB.EQ.54) THEN
30322 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
30323 CALL PYWIDT(21,SH,WDTP,WDTE)
30325 DO 280 I=1,MIN(8,MDCY(21,3))
30327 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30330 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
30331 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30338 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30346 ELSEIF(ISUB.EQ.58) THEN
30347 C...gamma + gamma -> f + fbar
30348 CALL PYWIDT(22,SH,WDTP,WDTE)
30350 DO 290 I=1,MIN(12,MDCY(22,3))
30351 IF(I.LE.8) EF= KCHG(I,1)/3D0
30352 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30353 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30356 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
30357 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30365 ELSEIF(ISUB.EQ.68) THEN
30367 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
30368 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
30370 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
30372 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
30378 SIGH(NCHN)=0.5D0*FACGG1
30383 SIGH(NCHN)=0.5D0*FACGG2
30388 SIGH(NCHN)=0.5D0*FACGG3
30391 ELSEIF(ISUB.EQ.80) THEN
30392 C...q + gamma -> q' + pi+/-
30393 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
30394 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
30395 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
30396 DELSH=UH*SQRT(ASSH*Q2FPSH)
30397 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
30398 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
30399 DELUH=SH*SQRT(ASUH*Q2FPUH)
30400 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
30401 IF(I.EQ.0) GOTO 320
30402 EI=KCHG(IABS(I),1)/3D0
30403 EJ=SIGN(1D0-ABS(EI),EI)
30405 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
30406 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
30409 ISIG(NCHN,3-ISDE)=22
30411 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
30416 ELSEIF(ISUB.LE.100) THEN
30417 IF(ISUB.EQ.91) THEN
30418 C...Elastic scattering
30419 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
30421 ELSEIF(ISUB.EQ.92) THEN
30422 C...Single diffractive scattering (first side, i.e. XB)
30423 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
30425 ELSEIF(ISUB.EQ.93) THEN
30426 C...Single diffractive scattering (second side, i.e. AX)
30427 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
30429 ELSEIF(ISUB.EQ.94) THEN
30430 C...Double diffractive scattering
30431 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
30433 ELSEIF(ISUB.EQ.95) THEN
30434 C...Low-pT scattering
30435 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
30437 ELSEIF(ISUB.EQ.96) THEN
30438 C...Multiple interactions: sum of QCD processes
30439 CALL PYWIDT(21,SH,WDTP,WDTE)
30441 C...q + q' -> q + q'
30442 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30443 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30444 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30445 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
30446 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
30447 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
30449 IF(I.EQ.0) GOTO 340
30451 IF(J.EQ.0) GOTO 330
30457 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30459 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
30464 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
30469 C...q + qbar -> q' + qbar' or g + g
30470 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30471 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
30472 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30474 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30477 IF(I.EQ.0) GOTO 350
30487 SIGH(NCHN)=0.5D0*FACGG1
30492 SIGH(NCHN)=0.5D0*FACGG2
30496 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30498 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30501 IF(I.EQ.0) GOTO 370
30505 ISIG(NCHN,3-ISDE)=21
30510 ISIG(NCHN,3-ISDE)=21
30516 C...g + g -> q + qbar (only d, u, s)
30519 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30520 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30521 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30522 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30523 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30524 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30525 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30526 & UH2/SH2)*FLAVWT*FACA
30527 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30528 & TH2/SH2)*FLAVWT*FACA
30540 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
30543 SQMAVG=PMAS(IFL,1)**2
30544 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30545 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30546 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30547 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30548 THUHQ=THQ*UHQ-SQMAVG*SH
30549 IF(MSTP(34).EQ.0) THEN
30550 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30551 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30553 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30554 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30555 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30556 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30558 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30559 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30563 ISIG(NCHN,3)=531+2*(IFL-3)
30568 ISIG(NCHN,3)=532+2*(IFL-3)
30574 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
30575 & 2D0*TH/SH+TH2/SH2)*FACA
30576 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
30577 & 2D0*SH/UH+SH2/UH2)*FACA
30578 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
30579 & 2D0*UH/TH+UH2/TH2)
30584 SIGH(NCHN)=0.5D0*FACGG1
30589 SIGH(NCHN)=0.5D0*FACGG2
30594 SIGH(NCHN)=0.5D0*FACGG3
30596 ELSEIF(ISUB.EQ.99) THEN
30597 C...f + gamma* -> f.
30598 IF(MINT(107).EQ.4) THEN
30607 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
30608 PM2RHO=PMAS(PYCOMP(113),1)**2
30609 IF(MSTP(19).EQ.0) THEN
30611 ELSEIF(MSTP(19).EQ.1) THEN
30612 COMFAC=COMFAC/(Q2GA+PM2RHO)
30613 ELSEIF(MSTP(19).EQ.2) THEN
30614 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
30616 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
30618 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
30619 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
30620 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
30621 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
30623 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
30625 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
30627 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
30628 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
30630 DO 390 I=MMINA,MMAXA
30631 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
30632 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
30633 EI=KCHG(IABS(I),1)/3D0
30636 ISIG(NCHN,3-ISDE)=22
30638 SIGH(NCHN)=COMFAC*EI**2
30643 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
30644 C...g + g -> gamma + gamma or g + g -> g + gamma
30659 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
30661 EI=KCHG(IABS(I),1)/3D0
30663 IF(ISUB.EQ.115) EIWT=EI
30668 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
30669 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
30672 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
30673 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
30674 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
30675 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
30681 CALL PYWAUX(1,EPSS,W1SR,W1SI)
30682 CALL PYWAUX(1,EPST,W1TR,W1TI)
30683 CALL PYWAUX(1,EPSU,W1UR,W1UI)
30684 CALL PYWAUX(2,EPSS,W2SR,W2SI)
30685 CALL PYWAUX(2,EPST,W2TR,W2TI)
30686 CALL PYWAUX(2,EPSU,W2UR,W2UI)
30687 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
30688 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
30689 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
30690 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
30691 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
30692 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
30693 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
30694 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
30695 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
30696 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
30697 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
30698 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
30699 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
30700 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
30701 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
30702 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
30703 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
30704 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
30705 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
30706 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
30707 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
30708 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
30709 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
30710 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
30711 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
30712 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
30713 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
30714 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
30715 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
30716 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
30717 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
30718 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
30719 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
30720 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
30721 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
30722 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
30723 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
30724 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
30725 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
30726 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
30727 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
30728 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
30729 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
30730 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
30731 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
30732 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
30733 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
30734 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
30735 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
30736 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
30737 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
30738 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
30739 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
30740 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
30741 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
30742 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
30744 A0STUR=A0STUR+EIWT*B0STUR
30745 A0STUI=A0STUI+EIWT*B0STUI
30746 A0TSUR=A0TSUR+EIWT*B0TSUR
30747 A0TSUI=A0TSUI+EIWT*B0TSUI
30748 A0UTSR=A0UTSR+EIWT*B0UTSR
30749 A0UTSI=A0UTSI+EIWT*B0UTSI
30750 A1STUR=A1STUR+EIWT*B1STUR
30751 A1STUI=A1STUI+EIWT*B1STUI
30752 A2STUR=A2STUR+EIWT*B2STUR
30753 A2STUI=A2STUI+EIWT*B2STUI
30755 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
30756 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
30757 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
30758 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
30759 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
30764 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
30765 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
30768 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
30769 C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
30771 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30773 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30775 IF(ISUB.EQ.131) THEN
30776 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
30777 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
30779 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
30781 DO 430 I=MMINA,MMAXA
30782 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
30783 EI=KCHG(IABS(I),1)/3D0
30786 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
30787 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
30790 ISIG(NCHN,3-ISDE)=22
30796 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
30797 C...f + gamma*_(T,L) -> f + gamma
30799 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30801 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30803 IF(ISUB.EQ.133) THEN
30804 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
30805 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
30807 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
30809 DO 450 I=MMINA,MMAXA
30810 IF(I.EQ.0) GOTO 450
30811 EI=KCHG(IABS(I),1)/3D0
30814 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
30815 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
30818 ISIG(NCHN,3-ISDE)=22
30824 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
30825 C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
30827 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30829 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30831 CALL PYWIDT(21,SH,WDTP,WDTE)
30833 DO 460 I=1,MIN(8,MDCY(21,3))
30835 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30838 IF(ISUB.EQ.135) THEN
30839 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
30840 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
30842 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
30844 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30851 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30859 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
30860 C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
30862 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
30864 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
30865 CALL PYWIDT(22,SH,WDTP,WDTE)
30867 DO 470 I=1,MIN(12,MDCY(22,3))
30868 IF(I.LE.8) EF= KCHG(I,1)/3D0
30869 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30870 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30873 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
30874 IF(ISUB.EQ.137) THEN
30875 FPARAM=-SH*(TH+UH)/DLAMB2
30876 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
30877 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
30878 & 2D0*PH1*PH2*FPARAM**2)
30879 ELSEIF(ISUB.EQ.138) THEN
30880 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30881 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
30882 & 2D0*PH1**2*(TH-UH)**2)
30883 ELSEIF(ISUB.EQ.139) THEN
30884 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30885 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
30886 & 2D0*PH2**2*(TH-UH)**2)
30888 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
30889 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
30891 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30905 C*********************************************************************
30908 C...Subprocess cross sections for heavy flavour production,
30909 C...open and closed.
30910 C...Auxiliary to PYSIGH.
30912 SUBROUTINE PYSGHF(NCHN,SIGS)
30914 C...Double precision and integer declarations
30915 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30916 IMPLICIT INTEGER(I-N)
30917 INTEGER PYK,PYCHGE,PYCOMP
30918 C...Parameter statement to help give large particle numbers.
30919 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30920 &KEXCIT=4000000,KDIMEN=5000000)
30922 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30923 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30924 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30925 COMMON/PYINT1/MINT(400),VINT(400)
30926 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30927 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30928 COMMON/PYINT4/MWID(500),WIDS(500,5)
30929 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30930 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30931 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30932 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30933 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
30936 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30938 C...Determine where are charmonium/bottomonium wave function parameters.
30940 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
30942 C...Convert bottomonium process into equivalent charmonium ones.
30943 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
30945 C...Differential cross section expressions.
30947 IF(ISUB.LE.100) THEN
30948 IF(ISUB.EQ.81) THEN
30949 C...q + qbar -> Q + Qbar
30950 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30951 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30952 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30953 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
30955 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
30957 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30958 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30960 DO 100 I=MMINA,MMAXA
30961 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30962 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
30970 ELSEIF(ISUB.EQ.82) THEN
30971 C...g + g -> Q + Qbar
30972 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30973 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30974 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30975 THUHQ=THQ*UHQ-SQMAVG*SH
30976 IF(MSTP(34).EQ.0) THEN
30977 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30978 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30980 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30981 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30982 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30983 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30985 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
30986 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
30987 IF(MSTP(35).GE.1) THEN
30988 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
30989 FACQQ1=FACQQ1*FATRE
30990 FACQQ2=FACQQ2*FATRE
30993 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30994 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30997 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
31010 ELSEIF(ISUB.EQ.83) THEN
31011 C...f + q -> f' + Q
31012 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
31013 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
31014 DO 130 I=MMIN1,MMAX1
31015 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
31016 DO 120 J=MMIN2,MMAX2
31017 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
31018 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
31019 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
31020 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
31026 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31027 & (IABS(I)+1)/2)*VINT(180+J)
31028 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
31029 & (MINT(55)+1)/2)*VINT(180+J)
31032 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31033 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31036 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31037 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31040 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31041 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31043 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
31049 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31050 & (IABS(J)+1)/2)*VINT(180+I)
31051 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
31052 & (MINT(55)+1)/2)*VINT(180+I)
31055 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31056 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31059 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31060 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31063 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31064 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31069 ELSEIF(ISUB.EQ.84) THEN
31070 C...g + gamma -> Q + Qbar
31071 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31072 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31073 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31074 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
31075 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
31077 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
31079 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31080 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31082 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31089 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31097 ELSEIF(ISUB.EQ.85) THEN
31098 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
31099 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31100 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31101 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31102 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
31103 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
31104 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
31105 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
31106 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
31107 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
31108 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
31110 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
31111 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
31112 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
31114 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31122 ELSEIF(ISUB.EQ.86) THEN
31123 C...g + g -> J/Psi + g
31124 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
31125 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31126 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31127 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31135 ELSEIF(ISUB.EQ.87) THEN
31136 C...g + g -> chi_0c + g
31137 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31138 QGTW=(SH*TH*UH)/SH**3
31140 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31141 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31142 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
31143 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
31144 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
31145 & (QGTW*(QGTW-RGTW*PGTW)**4)
31146 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31154 ELSEIF(ISUB.EQ.88) THEN
31155 C...g + g -> chi_1c + g
31156 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31157 QGTW=(SH*TH*UH)/SH**3
31159 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31160 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
31161 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
31162 & (QGTW-RGTW*PGTW)**4
31163 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31171 ELSEIF(ISUB.EQ.89) THEN
31172 C...g + g -> chi_2c + g
31173 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31174 QGTW=(SH*TH*UH)/SH**3
31176 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31177 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31178 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
31179 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
31180 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
31181 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31182 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31191 ELSEIF(ISUB.LE.200) THEN
31192 IF(ISUB.EQ.104) THEN
31193 C...g + g -> chi_c0.
31195 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
31196 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31197 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31198 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31206 ELSEIF(ISUB.EQ.105) THEN
31207 C...g + g -> chi_c2.
31209 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
31210 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31211 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31212 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31220 ELSEIF(ISUB.EQ.106) THEN
31221 C...g + g -> J/Psi + gamma.
31222 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31223 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
31224 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31225 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31226 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31234 ELSEIF(ISUB.EQ.107) THEN
31235 C...g + gamma -> J/Psi + g.
31236 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31237 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
31238 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31239 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31240 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31247 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31255 ELSEIF(ISUB.EQ.108) THEN
31256 C...gamma + gamma -> J/Psi + gamma.
31257 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31258 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
31259 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31260 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31261 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31271 C...Additional code by Stefan Wolf
31274 C...Common code for quarkonium production.
31281 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
31282 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
31284 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
31285 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
31289 IF(MSTP(145).EQ.1) THEN
31290 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
31291 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
31292 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
31293 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
31294 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31295 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31296 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31297 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31298 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
31299 & ISUB.GE.437) THEN
31300 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
31301 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
31302 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31303 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31304 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31305 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31309 SMQQ2=SQMQQ*VINT(2)
31310 C...Polarisation frames
31311 IF(MSTP(146).EQ.1) THEN
31313 POLH1=SQRT(AQ2-SMQQ2)
31314 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31317 AX=AQ*BQ/(POLH1*POLH2)
31319 ELSEIF(MSTP(146).EQ.2) THEN
31320 C...Gottfried Jackson frame
31322 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31325 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
31326 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
31327 ELSEIF(MSTP(146).EQ.3) THEN
31330 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31333 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
31334 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
31335 ELSEIF(MSTP(146).EQ.4) THEN
31336 C...Collins Soper frame
31338 POLH2=SQRT(VINT(2)*POLH1)
31341 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
31342 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
31344 C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
31345 EL1K10=AZ*ATILK1+BZ*BTILK1
31346 EL1K20=AZ*ATILK2+BZ*BTILK2
31349 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
31350 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
31355 IF(ISUB.EQ.421) THEN
31356 C...g + g -> QQ~[3S11] + g
31357 IF(MSTP(145).EQ.0) THEN
31358 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31359 * & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
31360 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31361 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
31362 * FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31363 * & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
31365 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
31366 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
31370 IF(MSTP(147).EQ.0) THEN
31371 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31372 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31373 ELSEIF(MSTP(147).EQ.1) THEN
31374 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31375 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31376 ELSEIF(MSTP(147).EQ.3) THEN
31377 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31378 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31379 ELSEIF(MSTP(147).EQ.4) THEN
31380 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31381 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31382 ELSEIF(MSTP(147).EQ.5) THEN
31383 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31384 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31385 ELSEIF(MSTP(147).EQ.6) THEN
31386 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31387 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31389 FACQQG=COMFAC*FF*FACQQG
31391 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31396 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
31399 ELSEIF(ISUB.EQ.422) THEN
31400 C...g + g -> QQ~[3S18] + g
31401 IF(MSTP(145).EQ.0) THEN
31402 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
31403 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
31405 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
31407 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
31408 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
31409 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
31413 IF(MSTP(147).EQ.0) THEN
31414 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31415 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31416 ELSEIF(MSTP(147).EQ.1) THEN
31417 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31418 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31419 ELSEIF(MSTP(147).EQ.3) THEN
31420 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31421 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31422 ELSEIF(MSTP(147).EQ.4) THEN
31423 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31424 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31425 ELSEIF(MSTP(147).EQ.5) THEN
31426 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31427 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31428 ELSEIF(MSTP(147).EQ.6) THEN
31429 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31430 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31432 FACQQG=COMFAC*FF*FACQQG
31434 C...Split total contribution into different colour flows just like
31435 C...in g g -> g g (recalculate kinematics for massless partons).
31436 THP=-0.5D0*SH*(1D0-CTH)
31437 UHP=-0.5D0*SH*(1D0+CTH)
31438 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31439 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31440 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31441 FACGGS=FACGG1+FACGG2+FACGG3
31442 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31447 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31452 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31457 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
31460 ELSEIF(ISUB.EQ.423) THEN
31461 C...g + g -> QQ~[1S08] + g
31462 IF(MSTP(145).EQ.0) THEN
31463 * FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
31464 * & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
31465 * & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
31466 * & (SHTH2*THUH2*UHSH2)
31467 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
31468 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
31469 & TH2/(SHTH2*THUH2))*
31470 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
31472 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
31473 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
31474 & TH2/(SHTH2*THUH2))*
31475 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
31476 IF(MSTP(147).EQ.0) THEN
31478 ELSEIF(MSTP(147).EQ.1) THEN
31479 FACQQG=COMFAC*2D0*FA
31480 ELSEIF(MSTP(147).EQ.3) THEN
31482 ELSEIF(MSTP(147).EQ.4) THEN
31484 ELSEIF(MSTP(147).EQ.5) THEN
31486 ELSEIF(MSTP(147).EQ.6) THEN
31490 C...Split total contribution into different colour flows just like
31491 C...in g g -> g g (recalculate kinematics for massless partons).
31492 THP=-0.5D0*SH*(1D0-CTH)
31493 UHP=-0.5D0*SH*(1D0+CTH)
31494 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31495 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31496 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31497 FACGGS=FACGG1+FACGG2+FACGG3
31498 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31503 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31508 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31513 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
31516 ELSEIF(ISUB.EQ.424) THEN
31517 C...g + g -> QQ~[3PJ8] + g
31519 IF(MSTP(145).EQ.0) THEN
31520 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
31521 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
31522 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
31524 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
31525 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
31526 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
31528 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
31529 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
31530 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
31532 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
31533 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
31534 & +451D0*SH*TH**5+126D0*TH**6)
31535 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
31536 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
31537 & +171D0*SH*TH**5+42D0*TH**6)
31538 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
31539 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
31540 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
31541 & +99D0*SH*TH**3+35D0*TH**4)
31542 & +7D0*SQMQQ**8*SHTH*POLY)/
31543 & (SH*TH*UH*SQMQQR*SQMQQ*
31544 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
31546 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
31547 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
31548 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
31549 & -SQMQQ*SHTH2*POLY**2*
31550 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
31551 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
31552 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
31553 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
31554 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
31555 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
31556 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
31557 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
31558 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
31559 & +145D0*SH*TH**5+34D0*TH**6)
31560 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
31561 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
31563 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
31564 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
31565 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
31566 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
31567 & +3D0*SQMQQ**8*SHTH*POLY)
31568 BB=4D0*SHTH2*POLY**3
31569 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
31570 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
31571 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
31572 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
31573 & +84D0*SH*TH**9+20D0*TH**10)
31574 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
31575 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
31576 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
31578 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
31579 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
31580 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
31582 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
31583 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
31584 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
31585 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
31586 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
31588 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
31589 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
31590 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
31592 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
31593 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
31594 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
31595 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
31597 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
31598 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
31599 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
31600 & +394D0*SH*TH**9+84D0*TH**10)
31601 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
31602 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
31603 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
31604 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
31605 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
31606 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
31607 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
31608 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
31609 & +266D0*SH*TH**6+84D0*TH**7)
31610 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
31611 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
31613 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
31614 & +7D0*SH*TH**3+4*TH**4)
31615 & +SQMQQ**8*SH*(SH-TH)**2*TH
31616 DD=2D0*TH2*SHTH2*POLY**3
31617 & *(-SH2+2*SH*TH+2*TH2)
31618 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
31619 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
31620 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
31621 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
31622 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
31623 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
31624 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
31625 & -210D0*SH*TH**8-60D0*TH**9)
31626 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
31627 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
31628 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
31630 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
31631 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
31632 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
31633 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
31634 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
31635 & -30D0*SH*TH**6-24D0*TH**7)
31636 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
31637 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
31639 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
31640 IF(MSTP(147).EQ.0) THEN
31641 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31642 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31643 ELSEIF(MSTP(147).EQ.1) THEN
31644 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31645 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31646 ELSEIF(MSTP(147).EQ.3) THEN
31647 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31648 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31649 ELSEIF(MSTP(147).EQ.4) THEN
31650 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31651 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31652 ELSEIF(MSTP(147).EQ.5) THEN
31653 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31654 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31655 ELSEIF(MSTP(147).EQ.6) THEN
31656 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31657 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31659 FACQQG=COMFAC*FF*FACQQG
31661 C...Split total contribution into different colour flows just like
31662 C...in g g -> g g (recalculate kinematics for massless partons).
31663 THP=-0.5D0*SH*(1D0-CTH)
31664 UHP=-0.5D0*SH*(1D0+CTH)
31665 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31666 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31667 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31668 FACGGS=FACGG1+FACGG2+FACGG3
31669 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31674 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
31679 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
31684 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
31687 ELSEIF(ISUB.EQ.425) THEN
31688 C...q + g -> q + QQ~[3S18]
31689 IF(MSTP(145).EQ.0) THEN
31690 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
31691 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
31692 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
31694 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
31695 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
31700 IF(MSTP(147).EQ.0) THEN
31701 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31702 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31703 ELSEIF(MSTP(147).EQ.1) THEN
31704 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31705 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31706 ELSEIF(MSTP(147).EQ.3) THEN
31707 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31708 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31709 ELSEIF(MSTP(147).EQ.4) THEN
31710 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31711 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31712 ELSEIF(MSTP(147).EQ.5) THEN
31713 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31714 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31715 ELSEIF(MSTP(147).EQ.6) THEN
31716 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31717 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31719 FACQQG=COMFAC*FF*FACQQG
31721 C...Split total contribution into different colour flows just like
31722 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31723 C...(recalculate kinematics for massless partons).
31724 THP=-0.5D0*SH*(1D0-CTH)
31725 UHP=-0.5D0*SH*(1D0+CTH)
31726 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31727 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31728 FACQGS=FACQG1+FACQG2
31729 DO 2442 I=MMINA,MMAXA
31730 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
31732 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
31733 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
31736 ISIG(NCHN,3-ISDE)=21
31738 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
31741 ISIG(NCHN,3-ISDE)=21
31743 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
31747 ELSEIF(ISUB.EQ.426) THEN
31748 C...q + g -> q + QQ~[1S08]
31749 IF(MSTP(145).EQ.0) THEN
31750 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
31751 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
31753 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
31754 IF(MSTP(147).EQ.0) THEN
31756 ELSEIF(MSTP(147).EQ.1) THEN
31757 FACQQG=COMFAC*2D0*FA
31758 ELSEIF(MSTP(147).EQ.3) THEN
31760 ELSEIF(MSTP(147).EQ.4) THEN
31762 ELSEIF(MSTP(147).EQ.5) THEN
31764 ELSEIF(MSTP(147).EQ.6) THEN
31768 C...Split total contribution into different colour flows just like
31769 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31770 C...(recalculate kinematics for massless partons).
31771 THP=-0.5D0*SH*(1D0-CTH)
31772 UHP=-0.5D0*SH*(1D0+CTH)
31773 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31774 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31775 FACQGS=FACQG1+FACQG2
31776 DO 2444 I=MMINA,MMAXA
31777 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
31779 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
31780 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
31783 ISIG(NCHN,3-ISDE)=21
31785 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
31788 ISIG(NCHN,3-ISDE)=21
31790 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
31794 ELSEIF(ISUB.EQ.427) THEN
31795 C...q + g -> q + QQ~[3PJ8]
31796 IF(MSTP(145).EQ.0) THEN
31797 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
31798 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
31799 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
31800 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
31802 FF=10D0*PARU(1)*AS**3/
31803 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
31804 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
31805 BB=8D0*(SHTH2+TH*UH)
31806 CC=8D0*UHSH*(SHTH+THUH)
31807 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
31808 IF(MSTP(147).EQ.0) THEN
31809 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31810 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31811 ELSEIF(MSTP(147).EQ.1) THEN
31812 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31813 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31814 ELSEIF(MSTP(147).EQ.3) THEN
31815 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31816 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31817 ELSEIF(MSTP(147).EQ.4) THEN
31818 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31819 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31820 ELSEIF(MSTP(147).EQ.5) THEN
31821 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31822 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31823 ELSEIF(MSTP(147).EQ.6) THEN
31824 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31825 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31827 FACQQG=COMFAC*FF*FACQQG
31829 C...Split total contribution into different colour flows just like
31830 C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31831 C...(recalculate kinematics for massless partons).
31832 THP=-0.5D0*SH*(1D0-CTH)
31833 UHP=-0.5D0*SH*(1D0+CTH)
31834 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31835 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31836 FACQGS=FACQG1+FACQG2
31837 DO 2446 I=MMINA,MMAXA
31838 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
31840 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
31841 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
31844 ISIG(NCHN,3-ISDE)=21
31846 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
31849 ISIG(NCHN,3-ISDE)=21
31851 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
31855 ELSEIF(ISUB.EQ.428) THEN
31856 C...q + q~ -> g + QQ~[3S18]
31857 IF(MSTP(145).EQ.0) THEN
31858 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
31859 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
31860 & (SQMQQ*SQMQQR*TH*UH*THUH2)
31862 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
31863 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
31868 IF(MSTP(147).EQ.0) THEN
31869 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31870 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31871 ELSEIF(MSTP(147).EQ.1) THEN
31872 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31873 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31874 ELSEIF(MSTP(147).EQ.3) THEN
31875 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31876 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31877 ELSEIF(MSTP(147).EQ.4) THEN
31878 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31879 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31880 ELSEIF(MSTP(147).EQ.5) THEN
31881 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31882 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31883 ELSEIF(MSTP(147).EQ.6) THEN
31884 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31885 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31887 FACQQG=COMFAC*FF*FACQQG
31889 C...Split total contribution into different colour flows just like
31890 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31891 C...(recalculate kinematics for massless partons).
31892 THP=-0.5D0*SH*(1D0-CTH)
31893 UHP=-0.5D0*SH*(1D0+CTH)
31894 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31895 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31896 FACGGS=FACGG1+FACGG2
31897 DO 2447 I=MMINA,MMAXA
31898 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31899 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
31904 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31909 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31912 ELSEIF(ISUB.EQ.429) THEN
31913 C...q + q~ -> g + QQ~[1S08]
31914 IF(MSTP(145).EQ.0) THEN
31915 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
31916 & (TH2+UH2)/(SQMQQR*SH*THUH2)
31918 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
31919 IF(MSTP(147).EQ.0) THEN
31921 ELSEIF(MSTP(147).EQ.1) THEN
31922 FACQQG=COMFAC*2D0*FA
31923 ELSEIF(MSTP(147).EQ.3) THEN
31925 ELSEIF(MSTP(147).EQ.4) THEN
31927 ELSEIF(MSTP(147).EQ.5) THEN
31929 ELSEIF(MSTP(147).EQ.6) THEN
31933 C...Split total contribution into different colour flows just like
31934 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31935 C...(recalculate kinematics for massless partons).
31936 THP=-0.5D0*SH*(1D0-CTH)
31937 UHP=-0.5D0*SH*(1D0+CTH)
31938 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31939 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31940 FACGGS=FACGG1+FACGG2
31941 DO 2448 I=MMINA,MMAXA
31942 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31943 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
31948 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31953 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31956 ELSEIF(ISUB.EQ.430) THEN
31957 C...q + q~ -> g + QQ~[3PJ8]
31958 IF(MSTP(145).EQ.0) THEN
31959 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
31960 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
31961 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
31962 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
31964 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
31965 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
31966 BB=8D0*(UHSH2+SH*TH)
31967 CC=8D0*(SHTH2+SH*UH)
31968 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
31969 IF(MSTP(147).EQ.0) THEN
31970 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31971 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31972 ELSEIF(MSTP(147).EQ.1) THEN
31973 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31974 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31975 ELSEIF(MSTP(147).EQ.3) THEN
31976 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31977 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31978 ELSEIF(MSTP(147).EQ.4) THEN
31979 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31980 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31981 ELSEIF(MSTP(147).EQ.5) THEN
31982 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31983 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31984 ELSEIF(MSTP(147).EQ.6) THEN
31985 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31986 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31988 FACQQG=COMFAC*FF*FACQQG
31990 C...Split total contribution into different colour flows just like
31991 C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31992 C...(recalculate kinematics for massless partons).
31993 THP=-0.5D0*SH*(1D0-CTH)
31994 UHP=-0.5D0*SH*(1D0+CTH)
31995 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31996 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31997 FACGGS=FACGG1+FACGG2
31998 DO 2449 I=MMINA,MMAXA
31999 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32000 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
32005 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
32010 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
32013 ELSEIF(ISUB.EQ.431) THEN
32014 C...g + g -> QQ~[3P01] + g
32015 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32016 QGTW=(SH*TH*UH)/SH**3
32018 IF(MSTP(145).EQ.0) THEN
32019 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32020 & (9D0*RGTW**2*PGTW**4*
32021 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32022 & -6D0*RGTW*PGTW**3*QGTW*
32023 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32024 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32025 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32026 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32028 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
32029 & (9D0*RGTW**2*PGTW**4*
32030 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32031 & -6D0*RGTW*PGTW**3*QGTW*
32032 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32033 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32034 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32035 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32036 IF(MSTP(147).EQ.0) THEN
32038 ELSEIF(MSTP(147).EQ.1) THEN
32039 FACQQG=COMFAC*2D0*FC1
32040 ELSEIF(MSTP(147).EQ.3) THEN
32042 ELSEIF(MSTP(147).EQ.4) THEN
32044 ELSEIF(MSTP(147).EQ.5) THEN
32046 ELSEIF(MSTP(147).EQ.6) THEN
32050 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32055 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32058 ELSEIF(ISUB.EQ.432) THEN
32059 C...g + g -> QQ~[3P11] + g
32060 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32061 QGTW=(SH*TH*UH)/SH**3
32063 IF(MSTP(145).EQ.0) THEN
32064 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
32065 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
32066 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
32067 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
32069 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
32070 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
32071 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
32072 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
32073 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
32074 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32075 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32076 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
32077 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32078 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32079 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
32080 C4=-4D0*THUH*(TH-UH)**2*
32081 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
32082 & -SH2*TH*UH*(TH2+UH2))
32083 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
32084 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
32085 & +SH2*(5D0*THUH2-17D0*TH*UH)))
32086 IF(MSTP(147).EQ.0) THEN
32087 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32088 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32089 ELSEIF(MSTP(147).EQ.1) THEN
32090 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32091 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32092 ELSEIF(MSTP(147).EQ.3) THEN
32093 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32094 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32095 ELSEIF(MSTP(147).EQ.4) THEN
32096 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32097 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32098 ELSEIF(MSTP(147).EQ.5) THEN
32099 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32100 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32101 ELSEIF(MSTP(147).EQ.6) THEN
32102 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32103 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32105 FACQQG=COMFAC*FF*FACQQG
32107 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32112 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32115 ELSEIF(ISUB.EQ.433) THEN
32116 C...g + g -> QQ~[3P21] + g
32117 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32118 QGTW=(SH*TH*UH)/SH**3
32120 IF(MSTP(145).EQ.0) THEN
32121 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32122 & (12D0*RGTW**2*PGTW**4*
32123 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32124 & -3D0*RGTW*PGTW**3*QGTW*
32125 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
32126 & +2D0*PGTW**2*QGTW**2*
32127 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
32128 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
32129 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32131 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
32132 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
32133 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
32135 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
32136 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
32137 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
32138 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
32139 & +10D0*(SH2**2+TH2**2))
32140 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
32141 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
32142 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
32143 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
32144 & +4D0*SH*TH*UH2**4*SHTH2)
32145 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
32146 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
32147 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
32148 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
32149 & +10D0*(SH2**2+UH2**2))
32150 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
32151 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
32152 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
32153 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
32154 & +4D0*SH*UH*TH2**4*UHSH2)
32155 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
32156 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
32157 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
32158 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
32159 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
32160 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
32161 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
32162 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
32163 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
32164 & +3D0*(TH2**3+UH2**3)))
32165 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
32166 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
32167 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
32168 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
32169 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
32170 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
32171 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
32173 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
32175 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
32177 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
32178 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
32179 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
32180 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
32181 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
32182 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
32184 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
32186 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
32188 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
32189 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
32190 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
32191 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
32192 & +4D0*SH*TH2**2*UH2**2*THUH2
32193 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
32194 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
32195 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
32196 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
32197 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32198 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
32199 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
32200 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
32201 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
32202 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
32203 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
32204 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
32205 & +2D0*(TH2**3+UH2**3))
32206 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
32207 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
32208 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
32209 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32210 IF(MSTP(147).EQ.0) THEN
32211 FACQQG=1D0/3D0*(C1*3D0
32212 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32213 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32214 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32215 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32216 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32217 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32218 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32219 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32220 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32221 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32222 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32223 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32224 ELSEIF(MSTP(147).EQ.1) THEN
32226 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32227 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32228 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32229 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32230 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32231 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32232 & +EL1K10*EL2K20*EL1K11*EL2K11)
32233 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32234 & +EL1K10*EL2K20*EL1K21*EL2K21)
32235 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32236 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32237 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32238 & +EL1K20*EL2K20*EL1K11*EL2K11)
32239 ELSEIF(MSTP(147).EQ.2) THEN
32241 & -C2*EL1K11*EL2K11
32242 & -C3*EL1K21*EL2K21
32243 & -C4*EL1K11*EL2K21
32244 & +C5*(EL1K11*EL2K11)**2
32245 & +C6*(EL1K21*EL2K21)**2
32246 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32247 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32248 & +(C9+C0)*(EL1K11*EL2K21)**2)
32250 FACQQG=COMFAC*FF*FACQQG
32252 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32257 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32260 ELSEIF(ISUB.EQ.434) THEN
32261 C...q + g -> q + QQ~[3P01]
32262 IF(MSTP(145).EQ.0) THEN
32263 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
32264 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32266 FA=-PARU(1)*AS**3*(16D0/243D0)*
32267 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32268 IF(MSTP(147).EQ.0) THEN
32270 ELSEIF(MSTP(147).EQ.1) THEN
32271 FACQQG=COMFAC*2D0*FA
32272 ELSEIF(MSTP(147).EQ.3) THEN
32274 ELSEIF(MSTP(147).EQ.4) THEN
32276 ELSEIF(MSTP(147).EQ.5) THEN
32278 ELSEIF(MSTP(147).EQ.6) THEN
32282 DO 2452 I=MMINA,MMAXA
32283 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
32285 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
32286 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
32289 ISIG(NCHN,3-ISDE)=21
32291 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32295 ELSEIF(ISUB.EQ.435) THEN
32296 C...q + g -> q + QQ~[3P11]
32297 IF(MSTP(145).EQ.0) THEN
32298 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
32299 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
32301 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
32306 IF(MSTP(147).EQ.0) THEN
32307 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32308 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32309 ELSEIF(MSTP(147).EQ.1) THEN
32310 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32311 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32312 ELSEIF(MSTP(147).EQ.3) THEN
32313 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32314 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32315 ELSEIF(MSTP(147).EQ.4) THEN
32316 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32317 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32318 ELSEIF(MSTP(147).EQ.5) THEN
32319 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32320 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32321 ELSEIF(MSTP(147).EQ.6) THEN
32322 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32323 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32325 FACQQG=COMFAC*FF*FACQQG
32327 DO 2454 I=MMINA,MMAXA
32328 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
32330 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
32331 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
32334 ISIG(NCHN,3-ISDE)=21
32336 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32340 ELSEIF(ISUB.EQ.436) THEN
32341 C...q + g -> q + QQ~[3P21]
32342 IF(MSTP(145).EQ.0) THEN
32343 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
32344 & ((6D0*SQMQQ**2+TH2)*UHSH2
32345 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
32346 & (SQMQQR*TH*UHSH2**2)
32348 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
32350 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
32359 IF(MSTP(147).EQ.0) THEN
32360 FACQQG=1D0/3D0*(C1*3D0
32361 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32362 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32363 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32364 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32365 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32366 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32367 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32368 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32369 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32370 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32371 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32372 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32373 ELSEIF(MSTP(147).EQ.1) THEN
32375 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32376 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32377 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32378 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32379 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32380 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32381 & +EL1K10*EL2K20*EL1K11*EL2K11)
32382 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32383 & +EL1K10*EL2K20*EL1K21*EL2K21)
32384 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32385 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32386 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32387 & +EL1K20*EL2K20*EL1K11*EL2K11)
32388 ELSEIF(MSTP(147).EQ.2) THEN
32390 & -C2*EL1K11*EL2K11
32391 & -C3*EL1K21*EL2K21
32392 & -C4*EL1K11*EL2K21
32393 & +C5*(EL1K11*EL2K11)**2
32394 & +C6*(EL1K21*EL2K21)**2
32395 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32396 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32397 & +(C9+C0)*(EL1K11*EL2K21)**2)
32399 FACQQG=COMFAC*FF*FACQQG
32401 DO 2456 I=MMINA,MMAXA
32402 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
32404 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
32405 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
32408 ISIG(NCHN,3-ISDE)=21
32410 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32414 ELSEIF(ISUB.EQ.437) THEN
32415 C...q + q~ -> g + QQ~[3P01]
32416 IF(MSTP(145).EQ.0) THEN
32417 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
32418 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
32420 FA=PARU(1)*AS**3*(128D0/729D0)*
32421 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
32422 IF(MSTP(147).EQ.0) THEN
32424 ELSEIF(MSTP(147).EQ.1) THEN
32425 FACQQG=COMFAC*2D0*FA
32426 ELSEIF(MSTP(147).EQ.3) THEN
32428 ELSEIF(MSTP(147).EQ.4) THEN
32430 ELSEIF(MSTP(147).EQ.5) THEN
32432 ELSEIF(MSTP(147).EQ.6) THEN
32436 DO 2457 I=MMINA,MMAXA
32437 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32438 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
32443 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32446 ELSEIF(ISUB.EQ.438) THEN
32447 C...q + q~ -> g + QQ~[3P11]
32448 IF(MSTP(145).EQ.0) THEN
32449 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
32450 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
32452 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
32457 IF(MSTP(147).EQ.0) THEN
32458 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32459 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32460 ELSEIF(MSTP(147).EQ.1) THEN
32461 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32462 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32463 ELSEIF(MSTP(147).EQ.3) THEN
32464 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32465 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32466 ELSEIF(MSTP(147).EQ.4) THEN
32467 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32468 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32469 ELSEIF(MSTP(147).EQ.5) THEN
32470 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32471 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32472 ELSEIF(MSTP(147).EQ.6) THEN
32473 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32474 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32476 FACQQG=COMFAC*FF*FACQQG
32478 DO 2458 I=MMINA,MMAXA
32479 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32480 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
32485 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32488 ELSEIF(ISUB.EQ.439) THEN
32489 C...q + q~ -> g + QQ~[3P21]
32490 IF(MSTP(145).EQ.0) THEN
32491 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
32492 & ((6D0*SQMQQ**2+SH2)*THUH2
32493 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
32494 & (SQMQQR*SH*THUH2**2)
32496 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
32498 C2=4D0*(SH2+UH2+2D0*SH*THUH)
32499 C3=4D0*(SH2+TH2+2D0*SH*THUH)
32500 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
32507 IF(MSTP(147).EQ.0) THEN
32508 FACQQG=1D0/3D0*(C1*3D0
32509 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32510 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32511 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32512 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32513 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32514 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32515 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32516 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32517 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32518 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32519 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32520 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32521 ELSEIF(MSTP(147).EQ.1) THEN
32523 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32524 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32525 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32526 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32527 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32528 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32529 & +EL1K10*EL2K20*EL1K11*EL2K11)
32530 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32531 & +EL1K10*EL2K20*EL1K21*EL2K21)
32532 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32533 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32534 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32535 & +EL1K20*EL2K20*EL1K11*EL2K11)
32536 ELSEIF(MSTP(147).EQ.2) THEN
32538 & -C2*EL1K11*EL2K11
32539 & -C3*EL1K21*EL2K21
32540 & -C4*EL1K11*EL2K21
32541 & +C5*(EL1K11*EL2K11)**2
32542 & +C6*(EL1K21*EL2K21)**2
32543 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32544 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32545 & +(C9+C0)*(EL1K11*EL2K21)**2)
32547 FACQQG=COMFAC*FF*FACQQG
32549 DO 2459 I=MMINA,MMAXA
32550 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32551 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
32556 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32566 C*********************************************************************
32569 C...Subprocess cross sections for W/Z processes,
32570 C...except that longitudinal WW scattering is in Higgs sector.
32571 C...Auxiliary to PYSIGH.
32573 SUBROUTINE PYSGWZ(NCHN,SIGS)
32575 C...Double precision and integer declarations
32576 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32577 IMPLICIT INTEGER(I-N)
32578 INTEGER PYK,PYCHGE,PYCOMP
32579 C...Parameter statement to help give large particle numbers.
32580 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32581 &KEXCIT=4000000,KDIMEN=5000000)
32583 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32584 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32585 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32586 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
32587 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32588 COMMON/PYINT1/MINT(400),VINT(400)
32589 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
32590 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
32591 COMMON/PYINT4/MWID(500),WIDS(500,5)
32592 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
32593 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
32594 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
32595 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
32596 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
32597 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
32598 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
32599 C...Local arrays and complex numbers
32600 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
32602 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
32604 C...Differential cross section expressions.
32606 IF(ISUB.LE.20) THEN
32608 C...f + fbar -> gamma*/Z0
32610 CALL PYWIDT(23,SH,WDTP,WDTE)
32612 FACZ=4D0*COMFAC*3D0
32615 DO 100 I=MMINA,MMAXA
32616 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
32617 EI=KCHG(IABS(I),1)/3D0
32621 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
32623 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
32628 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
32629 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
32630 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
32631 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
32634 ELSEIF(ISUB.EQ.2) THEN
32635 C...f + fbar' -> W+/-
32636 CALL PYWIDT(24,SH,WDTP,WDTE)
32638 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
32639 HP=AEM/(24D0*XW)*SH
32640 DO 120 I=MMIN1,MMAX1
32641 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
32643 DO 110 J=MMIN2,MMAX2
32644 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
32646 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
32647 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32649 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32651 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
32656 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
32657 SIGH(NCHN)=HI*FACBW*HF
32661 ELSEIF(ISUB.EQ.15) THEN
32662 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
32663 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32664 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32668 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32669 DO 130 I=1,MIN(16,MDCY(23,3))
32671 IF(MDME(IDC,1).LT.0) GOTO 130
32673 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32677 AF=SIGN(1D0,EF+0.1D0)
32679 ELSEIF(I.LE.16) THEN
32681 AF=SIGN(1D0,EF+0.1D0)
32684 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32685 IF(4D0*RM1.LT.1D0) THEN
32687 IF(I.LE.8) FCOF=3D0*RADC4
32688 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32690 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32691 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32692 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32693 & AF**2*(1D0-4D0*RM1))*BE34
32697 C...Propagators: as simulated in PYOFSH and as desired
32698 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32702 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32704 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32705 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32706 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32707 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32708 C...Loop over flavours; consider full gamma/Z structure
32709 DO 140 I=MMINA,MMAXA
32710 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32711 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
32712 EI=KCHG(IABS(I),1)/3D0
32719 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
32720 & (VI**2+AI**2)*HFZZ)/HBW4
32723 ELSEIF(ISUB.EQ.16) THEN
32724 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
32725 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32726 C...Propagators: as simulated in PYOFSH and as desired
32727 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32728 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32729 GMMWC=SQRT(SQM4)*WDTP(0)
32730 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32731 FACWG=FACWG*HBW4C/HBW4
32732 DO 160 I=MMIN1,MMAX1
32734 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
32735 DO 150 J=MMIN2,MMAX2
32737 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
32738 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
32739 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32740 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32741 FCKM=VCKM((IA+1)/2,(JA+1)/2)
32746 SIGH(NCHN)=FACWG*FCKM*WIDSC
32750 ELSEIF(ISUB.EQ.19) THEN
32751 C...f + fbar -> gamma + (gamma*/Z0)
32752 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32753 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32757 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32758 DO 170 I=1,MIN(16,MDCY(23,3))
32760 IF(MDME(IDC,1).LT.0) GOTO 170
32762 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32766 AF=SIGN(1D0,EF+0.1D0)
32768 ELSEIF(I.LE.16) THEN
32770 AF=SIGN(1D0,EF+0.1D0)
32773 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32774 IF(4D0*RM1.LT.1D0) THEN
32776 IF(I.LE.8) FCOF=3D0*RADC4
32777 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32779 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32780 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32781 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32782 & AF**2*(1D0-4D0*RM1))*BE34
32786 C...Propagators: as simulated in PYOFSH and as desired
32787 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32791 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32793 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32794 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32795 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32796 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32797 C...Loop over flavours; consider full gamma/Z structure
32798 DO 180 I=MMINA,MMAXA
32799 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
32800 EI=KCHG(IABS(I),1)/3D0
32804 IF(IABS(I).LE.10) FCOI=FACA/3D0
32809 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
32810 & (VI**2+AI**2)*HFZZ)/HBW4
32813 ELSEIF(ISUB.EQ.20) THEN
32814 C...f + fbar' -> gamma + W+/-
32815 FACGW=COMFAC*0.5D0*AEM**2/XW
32816 C...Propagators: as simulated in PYOFSH and as desired
32817 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32818 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32819 GMMWC=SQRT(SQM4)*WDTP(0)
32820 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32821 FACGW=FACGW*HBW4C/HBW4
32822 C...Anomalous couplings
32823 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32826 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
32827 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
32828 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
32829 & (4D0*SQMW))/(TH+UH)**2
32831 DO 200 I=MMIN1,MMAX1
32833 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
32834 DO 190 J=MMIN2,MMAX2
32836 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
32837 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
32838 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32840 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32841 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32843 FACWR=UH/(TH+UH)-1D0/3D0
32844 FCKM=VCKM((IA+1)/2,(JA+1)/2)
32851 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
32856 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
32861 ELSEIF(ISUB.LE.40) THEN
32862 IF(ISUB.EQ.22) THEN
32863 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
32864 C...Kinematics dependence
32865 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
32866 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
32867 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32873 RADC3=1D0+PYALPS(SQM3)/PARU(1)
32874 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32875 DO 230 I=1,MIN(16,MDCY(23,3))
32877 IF(MDME(IDC,1).LT.0) GOTO 230
32879 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
32880 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
32883 AF=SIGN(1D0,EF+0.1D0)
32885 ELSEIF(I.LE.16) THEN
32887 AF=SIGN(1D0,EF+0.1D0)
32890 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
32891 IF(4D0*RM1.LT.1D0) THEN
32893 IF(I.LE.8) FCOF=3D0*RADC3
32894 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32896 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32897 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32898 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32899 & AF**2*(1D0-4D0*RM1))*BE34
32902 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32903 IF(4D0*RM1.LT.1D0) THEN
32905 IF(I.LE.8) FCOF=3D0*RADC4
32906 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32908 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32909 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32910 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32911 & AF**2*(1D0-4D0*RM1))*BE34
32915 C...Propagators: as simulated in PYOFSH and as desired
32916 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32917 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32921 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32923 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32925 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
32926 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
32927 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
32932 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32934 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32936 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
32937 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
32938 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
32940 C...Loop over flavours; separate left- and right-handed couplings
32941 DO 270 I=MMINA,MMAXA
32942 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
32943 EI=KCHG(IABS(I),1)/3D0
32949 IF(IABS(I).LE.10) FCOI=FACA/3D0
32951 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
32952 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
32953 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
32954 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
32956 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
32957 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
32958 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
32959 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
32964 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
32967 ELSEIF(ISUB.EQ.23) THEN
32968 C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
32969 FACZW=COMFAC*0.5D0*(AEM/XW)**2
32970 FACZW=FACZW*WIDS(23,2)
32971 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32972 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
32973 DO 290 I=MMIN1,MMAX1
32975 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
32976 DO 280 J=MMIN2,MMAX2
32978 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
32979 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
32980 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32982 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32984 AI=SIGN(1D0,EI+0.1D0)
32987 AJ=SIGN(1D0,EJ+0.1D0)
32989 IF(VI+AI.GT.0) THEN
32998 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33000 IF(IA.LE.10) FCOI=FACA/3D0
33005 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
33006 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
33007 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
33008 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
33009 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
33010 & WIDS(24,(5-KCHW)/2)
33011 C***Protect against slightly negative cross sections. (Reason yet to be
33012 C***sorted out. One possibility: addition of width to the W propagator.)
33013 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
33017 ELSEIF(ISUB.EQ.25) THEN
33018 C...f + fbar -> W+ + W-
33019 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
33021 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
33022 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33023 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33024 GMMW3=SQRT(SQM3)*WDTP(0)
33025 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33026 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33027 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33028 GMMW4=SQRT(SQM4)*WDTP(0)
33029 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
33030 C...Kinematical functions
33031 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33032 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
33033 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
33034 GT=THUH34+4D0*THUH/TH2
33035 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
33036 GU=THUH34+4D0*THUH/UH2
33037 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
33038 C...Common factors and couplings
33039 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
33040 FACWW=FACWW*WIDS(24,1)
33042 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
33043 CZZ=AEM**2/(32D0*XW**2)*HBWZC
33044 CNG=AEM**2/(4D0*XW)
33045 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
33046 CNN=AEM**2/(16D0*XW**2)
33047 C...Coulomb factor for W+W- pair
33048 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
33049 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
33050 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
33051 IF(COULE.LT.100D0*PMAS(24,2)) THEN
33052 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33053 & PMAS(24,2)**2)-COULE))
33055 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
33057 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
33058 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33059 & PMAS(24,2)**2)+COULE))
33061 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
33064 IF(MSTP(40).EQ.1) THEN
33065 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
33066 & MAX(1D-10,2D0*COULP*COULP1))
33067 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33068 ELSEIF(MSTP(40).EQ.2) THEN
33069 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
33070 COULCP=DCMPLX(0D0,DBLE(COULP))
33071 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
33072 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
33073 & (4D0*COULCP)*LOG(COULCD)
33074 COULCS=DCMPLX(0D0,0D0)
33077 COULXX=(ISTP-0.5)/NSTP
33078 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
33079 & (1D0+COULXX/COULCD))
33081 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
33083 FACCOU=ABS(COULCR)**2
33084 ELSEIF(MSTP(40).EQ.3) THEN
33085 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
33086 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
33087 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33089 ELSEIF(MSTP(40).EQ.4) THEN
33090 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
33096 C...Loop over allowed flavours
33097 DO 310 I=MMINA,MMAXA
33098 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
33099 EI=KCHG(IABS(I),1)/3D0
33100 AI=SIGN(1D0,EI+0.1D0)
33103 IF(IABS(I).LE.10) FCOI=FACA/3D0
33104 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
33106 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
33107 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
33109 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
33110 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
33113 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
33114 BET=SQRT(1D0-4D0*XMW02/SH)
33115 GAT=1D0/SQRT(1D0-BET**2)
33117 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
33118 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
33119 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
33120 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
33121 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
33122 & (1D0-2D0*BET*CTH+BET**2))
33123 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
33124 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
33125 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
33126 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
33127 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
33128 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
33129 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
33136 SIGH(NCHN)=FACWW*FCOI*DSIGWW
33139 ELSEIF(ISUB.EQ.30) THEN
33140 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
33141 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
33143 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33147 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33148 DO 320 I=1,MIN(16,MDCY(23,3))
33150 IF(MDME(IDC,1).LT.0) GOTO 320
33152 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33156 AF=SIGN(1D0,EF+0.1D0)
33158 ELSEIF(I.LE.16) THEN
33160 AF=SIGN(1D0,EF+0.1D0)
33163 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33164 IF(4D0*RM1.LT.1D0) THEN
33166 IF(I.LE.8) FCOF=3D0*RADC4
33167 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33169 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33170 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33171 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33172 & AF**2*(1D0-4D0*RM1))*BE34
33176 C...Propagators: as simulated in PYOFSH and as desired
33177 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33181 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33183 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33184 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33185 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33186 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33187 C...Loop over flavours; consider full gamma/Z structure
33188 DO 340 I=MMINA,MMAXA
33189 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
33190 EI=KCHG(IABS(I),1)/3D0
33193 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
33194 & (VI**2+AI**2)*HFZZ)/HBW4
33196 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
33197 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
33200 ISIG(NCHN,3-ISDE)=21
33206 ELSEIF(ISUB.EQ.31) THEN
33207 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
33208 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
33209 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
33210 C...Propagators: as simulated in PYOFSH and as desired
33211 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33212 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33213 GMMWC=SQRT(SQM4)*WDTP(0)
33214 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33215 FACWQ=FACWQ*HBW4C/HBW4
33216 DO 360 I=MMINA,MMAXA
33217 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
33219 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33220 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33222 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
33223 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
33226 ISIG(NCHN,3-ISDE)=21
33228 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33232 ELSEIF(ISUB.EQ.35) THEN
33233 C...f + gamma -> f + (gamma*/Z0)
33234 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
33235 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
33236 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
33237 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
33238 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
33239 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
33241 FZQN=SH2+UH2+2D0*SQM4*TH
33244 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
33245 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33249 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33250 DO 370 I=1,MIN(16,MDCY(23,3))
33252 IF(MDME(IDC,1).LT.0) GOTO 370
33254 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33258 AF=SIGN(1D0,EF+0.1D0)
33260 ELSEIF(I.LE.16) THEN
33262 AF=SIGN(1D0,EF+0.1D0)
33265 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33266 IF(4D0*RM1.LT.1D0) THEN
33268 IF(I.LE.8) FCOF=3D0*RADC4
33269 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33271 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33272 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33273 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33274 & AF**2*(1D0-4D0*RM1))*BE34
33278 C...Propagators: as simulated in PYOFSH and as desired
33279 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33283 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33285 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33286 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33287 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33288 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33289 C...Loop over flavours; consider full gamma/Z structure
33290 DO 390 I=MMINA,MMAXA
33291 IF(I.EQ.0) GOTO 390
33292 EI=KCHG(IABS(I),1)/3D0
33295 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
33296 & (VI**2+AI**2)*HFZZ)/HBW4
33297 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
33299 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
33300 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
33303 ISIG(NCHN,3-ISDE)=22
33305 SIGH(NCHN)=FACZQ*FZQN/FZQD
33309 ELSEIF(ISUB.EQ.36) THEN
33310 C...f + gamma -> f' + W+/-
33311 FWQ=COMFAC*AEM**2/(2D0*XW)*
33312 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
33313 C...Propagators: as simulated in PYOFSH and as desired
33314 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33315 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33316 GMMWC=SQRT(SQM4)*WDTP(0)
33317 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33319 DO 410 I=MMINA,MMAXA
33320 IF(I.EQ.0) GOTO 410
33322 EIA=ABS(KCHG(IABS(I),1)/3D0)
33323 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
33324 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33325 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33327 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
33328 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
33331 ISIG(NCHN,3-ISDE)=22
33333 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33338 ELSEIF(ISUB.LE.100) THEN
33339 IF(ISUB.EQ.69) THEN
33340 C...gamma + gamma -> W+ + W-
33341 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
33342 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
33343 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
33344 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
33345 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
33353 ELSEIF(ISUB.EQ.70) THEN
33354 C...gamma + W+/- -> Z0 + W+/-
33355 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
33356 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
33357 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
33358 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
33359 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
33360 DO 440 KCHW=1,-1,-2
33362 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
33365 ISIG(NCHN,3-ISDE)=24*KCHW
33367 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
33376 C*********************************************************************
33379 C...Subprocess cross sections for Higgs processes,
33380 C...except Higgs pairs in PYSGSU, but including WW scattering.
33381 C...Auxiliary to PYSIGH.
33383 SUBROUTINE PYSGHG(NCHN,SIGS)
33385 C...Double precision and integer declarations
33386 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33387 IMPLICIT INTEGER(I-N)
33388 INTEGER PYK,PYCHGE,PYCOMP
33389 C...Parameter statement to help give large particle numbers.
33390 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33391 &KEXCIT=4000000,KDIMEN=5000000)
33393 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33394 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33395 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
33396 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33397 COMMON/PYINT1/MINT(400),VINT(400)
33398 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33399 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33400 COMMON/PYINT4/MWID(500),WIDS(500,5)
33401 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
33402 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33403 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33404 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33405 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33406 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33407 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
33408 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
33409 C...Local arrays and complex variables
33410 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
33411 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
33412 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
33414 C...Convert H or A process into equivalent h one
33417 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
33418 KFHIGG=KFPR(ISUB,1)
33420 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
33421 &ISUB.LE.190)) THEN
33423 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
33425 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
33426 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
33427 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
33428 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
33429 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
33430 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
33431 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
33432 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
33433 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
33434 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
33435 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
33436 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
33438 SQMH=PMAS(KFHIGG,1)**2
33439 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
33441 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33442 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
33443 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
33444 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
33445 IF(MSTP(46).LE.4) THEN
33446 HDTLH=LOG(PMAS(25,1)/PARP(44))
33447 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
33448 HDTNR=-1D0/18D0+HDTLH/6D0
33450 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
33451 HDTLQ=LOG(PARP(45)/PARP(44))
33452 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
33453 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
33456 C...Calculate lowest and next-to-lowest order partial wave amplitudes
33457 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
33461 HDTLS=LOG(SH/PARP(44)**2)
33462 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
33463 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
33464 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
33465 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
33466 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
33467 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
33468 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
33469 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
33471 C...Unitarize partial wave amplitudes with Pade or K-matrix method
33472 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
33473 A00U=A00L/(1D0-A004/A00L)
33474 A20U=A20L/(1D0-A204/A20L)
33475 A11U=A11L/(1D0-A114/A11L)
33477 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
33478 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
33479 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
33483 C...Differential cross section expressions.
33485 IF(ISUB.LE.60) THEN
33487 C...f + fbar -> h0 (or H0, or A0)
33488 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33490 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33491 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33493 HP=AEM/(8D0*XW)*SH/SQMW*SH
33494 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33495 DO 100 I=MMINA,MMAXA
33496 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
33498 RMQ=PYMRUN(IA,SH)**2/SH
33500 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
33501 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33503 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33504 IF(IA.GT.10) IKFI=3
33505 HI=HI*PARU(150+10*IHIGG+IKFI)**2
33506 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33507 HI=HI/(1D0+RMSS(41))**2
33508 IF(IHIGG.NE.3) THEN
33509 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33510 & PARU(151+10*IHIGG))**2
33518 SIGH(NCHN)=HI*FACBW*HF
33521 ELSEIF(ISUB.EQ.5) THEN
33523 CALL PYWIDT(25,SH,WDTP,WDTE)
33525 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33526 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
33527 HP=AEM/(8D0*XW)*SH/SQMW*SH
33528 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33530 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
33531 DO 120 I=MMIN1,MMAX1
33532 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
33533 DO 110 J=MMIN2,MMAX2
33534 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
33535 EI=KCHG(IABS(I),1)/3D0
33538 EJ=KCHG(IABS(J),1)/3D0
33545 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
33549 ELSEIF(ISUB.EQ.8) THEN
33551 CALL PYWIDT(25,SH,WDTP,WDTE)
33553 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33554 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
33555 HP=AEM/(8D0*XW)*SH/SQMW*SH
33556 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33558 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
33559 DO 140 I=MMIN1,MMAX1
33560 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
33561 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33562 DO 130 J=MMIN2,MMAX2
33563 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
33564 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33565 IF(EI*EJ.GT.0D0) GOTO 130
33570 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
33574 ELSEIF(ISUB.EQ.24) THEN
33575 C...f + fbar -> Z0 + h0 (or H0, or A0)
33576 C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
33577 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
33578 CALL PYWIDT(23,SQM3,WDTP,WDTE)
33579 GMMZ3=SQRT(SQM3)*WDTP(0)
33580 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
33581 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33582 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33583 GMMH4=SQRT(SQM4)*WDTP(0)
33584 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
33585 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33586 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
33587 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
33588 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
33589 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
33590 & PARU(154+10*IHIGG)**2
33591 DO 150 I=MMINA,MMAXA
33592 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
33593 EI=KCHG(IABS(I),1)/3D0
33597 IF(IABS(I).LE.10) FCOI=FACA/3D0
33602 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
33605 ELSEIF(ISUB.EQ.26) THEN
33606 C...f + fbar' -> W+/- + h0 (or H0, or A0)
33607 C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
33608 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33609 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33610 GMMW3=SQRT(SQM3)*WDTP(0)
33611 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33612 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33613 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33614 GMMH4=SQRT(SQM4)*WDTP(0)
33615 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
33616 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33617 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
33618 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
33619 FACHW=FACHW*WIDS(KFHIGG,2)
33620 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
33621 & PARU(155+10*IHIGG)**2
33622 DO 170 I=MMIN1,MMAX1
33624 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
33625 DO 160 J=MMIN2,MMAX2
33627 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
33628 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
33629 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33631 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33633 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33635 IF(IA.LE.10) FCOI=FACA/3D0
33640 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
33644 ELSEIF(ISUB.EQ.32) THEN
33645 C...f + g -> f + h0 (q + g -> q + h0 only)
33646 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
33647 C...H propagator: as simulated in PYOFSH and as desired
33648 SQMHC=PMAS(25,1)**2
33649 GMMHC=PMAS(25,1)*PMAS(25,2)
33650 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
33651 CALL PYWIDT(25,SQM4,WDTP,WDTE)
33652 GMMHCC=SQRT(SQM4)*WDTP(0)
33653 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
33654 FHCQ=FHCQ*HBW4C/HBW4
33655 DO 190 I=MMINA,MMAXA
33657 IF(IA.NE.5) GOTO 190
33658 SQML=PYMRUN(IA,SH)**2
33660 FACHCQ=FHCQ*SQML/SQMW*
33661 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
33662 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
33663 & (SQM4-SQMQ-SH)/SH)
33665 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
33666 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
33669 ISIG(NCHN,3-ISDE)=21
33671 SIGH(NCHN)=FACHCQ*WIDS(25,2)
33676 ELSEIF(ISUB.LE.80) THEN
33677 IF(ISUB.EQ.71) THEN
33678 C...Z0 + Z0 -> Z0 + Z0
33679 IF(SH.LE.4.01D0*SQMZ) GOTO 220
33681 IF(MSTP(46).LE.2) THEN
33682 C...Exact scattering ME:s for on-mass-shell gauge bosons
33683 BE2=1D0-4D0*SQMZ/SH
33684 TH=-0.5D0*SH*BE2*(1D0-CTH)
33685 UH=-0.5D0*SH*BE2*(1D0+CTH)
33686 IF(MAX(TH,UH).GT.-1D0) GOTO 220
33687 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
33688 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33689 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33690 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
33691 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33692 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33693 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
33694 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33695 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33696 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
33697 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
33698 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33699 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
33700 & (ASHIM+ATHIM+AUHIM)**2)
33701 IF(MSTP(46).EQ.2) FACZZ=0D0
33704 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33705 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
33706 & ABS(A00U+2D0*A20U)**2
33708 FACZZ=FACZZ*WIDS(23,1)
33710 DO 210 I=MMIN1,MMAX1
33711 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
33712 EI=KCHG(IABS(I),1)/3D0
33716 DO 200 J=MMIN2,MMAX2
33717 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
33718 EJ=KCHG(IABS(J),1)/3D0
33726 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
33731 ELSEIF(ISUB.EQ.72) THEN
33732 C...Z0 + Z0 -> W+ + W-
33733 IF(SH.LE.4.01D0*SQMZ) GOTO 250
33735 IF(MSTP(46).LE.2) THEN
33736 C...Exact scattering ME:s for on-mass-shell gauge bosons
33737 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33739 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33740 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33741 IF(MAX(TH,UH).GT.-1D0) GOTO 250
33742 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33743 & (1D0-2D0*SQMZ/SH)
33744 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33745 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33746 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33747 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33748 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33749 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33750 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33752 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33753 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33754 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33755 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33756 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33758 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33760 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
33761 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
33762 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
33763 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33764 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33765 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
33766 & (ATWIM+AUWIM+A4IM)**2)
33769 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33770 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
33771 & ABS(A00U-A20U)**2
33773 FACWW=FACWW*WIDS(24,1)
33775 DO 240 I=MMIN1,MMAX1
33776 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
33777 EI=KCHG(IABS(I),1)/3D0
33781 DO 230 J=MMIN2,MMAX2
33782 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
33783 EJ=KCHG(IABS(J),1)/3D0
33791 SIGH(NCHN)=FACWW*AVI*AVJ
33796 ELSEIF(ISUB.EQ.73) THEN
33797 C...Z0 + W+/- -> Z0 + W+/-
33798 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
33800 IF(MSTP(46).LE.2) THEN
33801 C...Exact scattering ME:s for on-mass-shell gauge bosons
33802 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
33803 EP1=1D0-(SQMZ-SQMW)/SH
33804 EP2=1D0+(SQMZ-SQMW)/SH
33805 TH=-0.5D0*SH*BE2*(1D0-CTH)
33806 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
33807 IF(MAX(TH,UH).GT.-1D0) GOTO 280
33808 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
33809 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33810 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33811 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
33812 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
33813 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
33814 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
33816 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
33817 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
33818 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
33819 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
33820 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
33821 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
33822 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
33823 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
33824 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
33825 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
33826 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
33827 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
33829 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
33830 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
33832 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
33833 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
33834 IF(MSTP(46).LE.0) FACZW=0D0
33835 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
33836 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
33837 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
33838 & (ASWIM+AUWIM+A4IM)**2)
33841 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33842 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
33843 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
33845 FACZW=FACZW*WIDS(23,2)
33847 DO 270 I=MMIN1,MMAX1
33848 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
33849 EI=KCHG(IABS(I),1)/3D0
33853 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
33854 DO 260 J=MMIN2,MMAX2
33855 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
33856 EJ=KCHG(IABS(J),1)/3D0
33860 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
33865 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
33870 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
33875 ELSEIF(ISUB.EQ.75) THEN
33876 C...W+ + W- -> gamma + gamma
33878 ELSEIF(ISUB.EQ.76) THEN
33879 C...W+ + W- -> Z0 + Z0
33880 IF(SH.LE.4.01D0*SQMZ) GOTO 310
33882 IF(MSTP(46).LE.2) THEN
33883 C...Exact scattering ME:s for on-mass-shell gauge bosons
33884 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33886 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33887 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33888 IF(MAX(TH,UH).GT.-1D0) GOTO 310
33889 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33890 & (1D0-2D0*SQMZ/SH)
33891 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33892 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33893 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33894 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33895 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33896 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33897 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33899 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33900 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33901 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33902 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33903 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33905 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33907 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33909 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33910 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33911 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33912 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
33913 & (ATWIM+AUWIM+A4IM)**2)
33916 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33917 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33918 & ABS(A00U-A20U)**2
33920 FACZZ=FACZZ*WIDS(23,1)
33922 DO 300 I=MMIN1,MMAX1
33923 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
33924 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33925 DO 290 J=MMIN2,MMAX2
33926 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
33927 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33928 IF(EI*EJ.GT.0D0) GOTO 290
33933 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
33938 ELSEIF(ISUB.EQ.77) THEN
33939 C...W+/- + W+/- -> W+/- + W+/-
33940 IF(SH.LE.4.01D0*SQMW) GOTO 340
33942 IF(MSTP(46).LE.2) THEN
33943 C...Exact scattering ME:s for on-mass-shell gauge bosons
33944 BE2=1D0-4D0*SQMW/SH
33948 TH=-0.5D0*SH*BE2*(1D0-CTH)
33949 UH=-0.5D0*SH*BE2*(1D0+CTH)
33950 IF(MAX(TH,UH).GT.-1D0) GOTO 340
33952 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33953 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33955 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33956 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33958 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33959 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33960 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
33963 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
33965 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
33966 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
33967 ATGRE=0.5D0*XW*SH/TH*TGZANG
33969 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
33971 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
33972 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
33973 AUGRE=0.5D0*XW*SH/UH*UGZANG
33975 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
33977 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
33979 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
33981 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33983 IF(MSTP(46).LE.0) THEN
33988 ELSEIF(MSTP(46).EQ.1) THEN
33989 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33990 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33991 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33992 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33994 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33995 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33996 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33997 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33999 AWWA2=AWWARE**2+AWWAIM**2
34000 AWWS2=AWWSRE**2+AWWSIM**2
34003 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34004 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
34005 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
34006 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
34009 DO 330 I=MMIN1,MMAX1
34010 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
34011 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34012 DO 320 J=MMIN2,MMAX2
34013 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
34014 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34015 IF(EI*EJ.LT.0D0) THEN
34017 IF(MSTP(45).EQ.1) GOTO 320
34018 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
34019 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
34022 IF(MSTP(45).EQ.2) GOTO 320
34023 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
34024 IF(MSTP(46).GE.3) FACWW=FWWS
34025 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
34026 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
34032 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
34033 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
34039 ELSEIF(ISUB.LE.120) THEN
34040 IF(ISUB.EQ.102) THEN
34041 C...g + g -> h0 (or H0, or A0)
34042 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34044 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34045 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34046 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34048 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34049 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34051 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34052 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34053 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34055 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34056 & '(PYSGHG:) did not find Higgs -> g g channel')
34059 HI=SHR*WDTP(13)/32D0
34061 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
34066 SIGH(NCHN)=HI*FACBW*HF
34069 ELSEIF(ISUB.EQ.103) THEN
34070 C...gamma + gamma -> h0 (or H0, or A0)
34071 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34073 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34074 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34075 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34077 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34078 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34080 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34081 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
34082 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
34084 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
34085 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
34088 HI=SHR*WDTP(14)*2D0
34090 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
34095 SIGH(NCHN)=HI*FACBW*HF
34098 ELSEIF(ISUB.EQ.110) THEN
34099 C...f + fbar -> gamma + h0
34100 THUH=MAX(TH*UH,SH*CKIN(3)**2)
34101 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
34102 FACHG=FACHG*WIDS(KFHIGG,2)
34103 C...Calculate loop contributions for intermediate gamma* and Z0
34104 CIGTOT=DCMPLX(0D0,0D0)
34105 CIZTOT=DCMPLX(0D0,0D0)
34108 IF(J.LE.2*MSTP(1)) THEN
34111 AJ=SIGN(1D0,EJ+0.1D0)
34113 BALP=SQM4/(2D0*PMAS(J,1))**2
34114 BBET=SH/(2D0*PMAS(J,1))**2
34115 ELSEIF(J.LE.3*MSTP(1)) THEN
34117 JL=2*(J-2*MSTP(1))-1
34118 EJ=KCHG(10+JL,1)/3D0
34119 AJ=SIGN(1D0,EJ+0.1D0)
34121 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
34122 BBET=SH/(2D0*PMAS(10+JL,1))**2
34124 BALP=SQM4/(2D0*PMAS(24,1))**2
34125 BBET=SH/(2D0*PMAS(24,1))**2
34127 BABI=1D0/(BALP-BBET)
34128 IF(BALP.LT.1D0) THEN
34129 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
34132 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
34133 & -DBLE(0.5D0*PARU(1)))
34136 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
34137 IF(BBET.LT.1D0) THEN
34138 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
34141 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
34142 & -DBLE(0.5D0*PARU(1)))
34145 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
34146 IF(J.LE.3*MSTP(1)) THEN
34147 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
34148 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
34149 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
34150 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
34153 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
34154 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
34155 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
34156 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
34157 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
34158 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
34162 CIGTOT=CIGTOT/DBLE(SH)
34163 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
34164 C...Loop over initial flavours
34165 DO 380 I=MMINA,MMAXA
34166 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
34167 EI=KCHG(IABS(I),1)/3D0
34171 IF(IABS(I).LE.10) FCOI=FACA/3D0
34176 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
34177 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
34180 ELSEIF(ISUB.EQ.111) THEN
34181 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
34182 IF(MSTP(38).NE.0) THEN
34183 C...Simple case: only do gg <-> h exactly.
34184 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34185 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34186 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34188 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34189 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34190 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34192 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34193 & '(PYSGHG:) did not find Higgs -> g g channel')
34194 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
34195 & (TH**2+UH**2)/(SH*SQM4)
34197 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
34198 & (TH**2+UH**2)/(SH*SQM4)
34200 C...Propagators: as simulated in PYOFSH and as desired
34201 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34202 GMMHC=SQRT(SQM4)*WDTP(0)
34203 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34204 & ((SQM4-SQMH)**2+GMMHC**2)
34205 FACGH=FACGH*HBW4C/HBW4
34207 C...Messy case: do full loop integrals
34210 DO 390 I=1,2*MSTP(1)
34214 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34215 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34216 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34217 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34218 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
34219 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
34220 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
34221 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
34223 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34224 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
34225 FACGH=FACGH*WIDS(25,2)
34227 DO 400 I=MMINA,MMAXA
34228 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34229 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34237 ELSEIF(ISUB.EQ.112) THEN
34238 C...f + g -> f + h0 (q + g -> q + h0 only)
34239 IF(MSTP(38).NE.0) THEN
34240 C...Simple case: only do gg <-> h exactly.
34241 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34242 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34243 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34245 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34246 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34247 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34249 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34250 & '(PYSGHG:) did not find Higgs -> g g channel')
34251 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
34252 & (SH**2+UH**2)/(-TH*SQM4)
34254 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
34255 & (SH**2+UH**2)/(-TH*SQM4)
34257 C...Propagators: as simulated in PYOFSH and as desired
34258 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34259 GMMHC=SQRT(SQM4)*WDTP(0)
34260 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34261 & ((SQM4-SQMH)**2+GMMHC**2)
34262 FACQH=FACQH*HBW4C/HBW4
34264 C...Messy case: do full loop integrals
34267 DO 410 I=1,2*MSTP(1)
34271 CALL PYWAUX(1,EPST,W1TR,W1TI)
34272 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34273 CALL PYWAUX(2,EPST,W2TR,W2TI)
34274 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34275 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
34276 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
34277 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
34278 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
34280 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34281 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
34282 FACQH=FACQH*WIDS(25,2)
34284 DO 430 I=MMINA,MMAXA
34285 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
34287 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
34288 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
34291 ISIG(NCHN,3-ISDE)=21
34297 ELSEIF(ISUB.EQ.113) THEN
34298 C...g + g -> g + h0
34299 IF(MSTP(38).NE.0) THEN
34300 C...Simple case: only do gg <-> h exactly.
34301 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34302 C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34303 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34305 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34306 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34307 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34309 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34310 & '(PYSGHG:) did not find Higgs -> g g channel')
34311 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
34312 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34314 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
34315 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34317 C...Propagators: as simulated in PYOFSH and as desired
34318 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34319 GMMHC=SQRT(SQM4)*WDTP(0)
34320 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34321 & ((SQM4-SQMH)**2+GMMHC**2)
34322 FACGH=FACGH*HBW4C/HBW4
34324 C...Messy case: do full loop integrals
34333 DO 440 I=1,2*MSTP(1)
34339 IF(EPSH.LT.1D-6) GOTO 440
34340 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34341 CALL PYWAUX(1,EPST,W1TR,W1TI)
34342 CALL PYWAUX(1,EPSU,W1UR,W1UI)
34343 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34344 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34345 CALL PYWAUX(2,EPST,W2TR,W2TI)
34346 CALL PYWAUX(2,EPSU,W2UR,W2UI)
34347 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34348 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
34349 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
34350 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
34351 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
34352 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
34353 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
34354 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
34355 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
34356 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
34357 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
34358 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
34359 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
34360 W3STUR=YHSTUR-Y3STUR-Y3UTSR
34361 W3STUI=YHSTUI-Y3STUI-Y3UTSI
34362 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
34363 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
34364 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
34365 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
34366 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
34367 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
34368 W3USTR=YHUSTR-Y3USTR-Y3TSUR
34369 W3USTI=YHUSTI-Y3USTI-Y3TSUI
34370 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
34371 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
34372 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
34373 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
34374 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
34375 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
34376 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
34377 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
34378 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
34379 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
34380 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
34381 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
34382 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
34383 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
34384 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
34385 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
34386 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
34387 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
34388 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
34389 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
34390 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
34391 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
34392 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
34393 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
34394 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
34395 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
34396 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
34397 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
34398 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
34399 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
34400 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
34401 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
34402 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
34403 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
34404 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
34405 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
34406 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
34407 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
34408 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
34409 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
34410 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
34411 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
34412 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
34413 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
34414 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
34415 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
34416 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
34417 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
34418 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
34419 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
34420 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
34421 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
34422 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
34423 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
34424 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
34425 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
34426 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
34427 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
34428 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
34429 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
34430 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
34431 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
34432 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34433 & (W2SR-W2HR+W3STUR))
34434 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
34435 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34436 & (W2TR-W2HR+W3TUSR))
34437 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
34438 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34439 & (W2UR-W2HR+W3USTR))
34440 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
34441 A2STUR=A2STUR+B2STUR+B2SUTR
34442 A2STUI=A2STUI+B2STUI+B2SUTI
34443 A2USTR=A2USTR+B2USTR+B2UTSR
34444 A2USTI=A2USTI+B2USTI+B2UTSI
34445 A2TUSR=A2TUSR+B2TUSR+B2TSUR
34446 A2TUSI=A2TUSI+B2TUSI+B2TSUI
34447 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
34448 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
34450 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
34451 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
34452 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
34453 FACGH=FACGH*WIDS(25,2)
34455 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
34464 ELSEIF(ISUB.LE.170) THEN
34465 IF(ISUB.EQ.121) THEN
34466 C...g + g -> Q + Qbar + h0
34467 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
34470 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
34471 & (0.5D0*PMF/PMAS(24,1))**2
34473 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
34475 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34477 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34478 IF(IA.GT.10) IKFI=3
34479 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
34480 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34481 FACQQH=FACQQH/(1D0+RMSS(41))**2
34482 IF(IHIGG.NE.3) THEN
34483 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34484 & PARU(151+10*IHIGG))**2
34488 CALL PYQQBH(WTQQBH)
34489 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34491 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34492 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34493 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34499 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
34502 ELSEIF(ISUB.EQ.122) THEN
34503 C...q + qbar -> Q + Qbar + h0
34506 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
34507 & (0.5D0*PMF/PMAS(24,1))**2
34509 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
34511 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34513 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34514 IF(IA.GT.10) IKFI=3
34515 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
34516 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34517 FACQQH=FACQQH/(1D0+RMSS(41))**2
34518 IF(IHIGG.NE.3) THEN
34519 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34520 & PARU(151+10*IHIGG))**2
34524 CALL PYQQBH(WTQQBH)
34525 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34527 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34528 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34529 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34531 DO 470 I=MMINA,MMAXA
34532 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34533 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
34538 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
34541 ELSEIF(ISUB.EQ.123) THEN
34542 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
34544 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
34545 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
34546 & PARU(154+10*IHIGG)**2
34547 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
34548 & (VINT(216)-VINT(209)**2))**2
34549 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
34550 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
34551 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34553 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34554 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34555 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34557 DO 490 I=MMIN1,MMAX1
34558 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
34560 DO 480 J=MMIN2,MMAX2
34561 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
34563 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
34564 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
34566 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
34567 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
34569 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
34570 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
34575 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
34579 ELSEIF(ISUB.EQ.124) THEN
34580 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
34582 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
34583 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
34584 & PARU(155+10*IHIGG)**2
34585 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
34586 & (VINT(216)-VINT(209)**2))**2
34587 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
34588 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34590 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34591 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34592 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34594 DO 510 I=MMIN1,MMAX1
34595 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
34596 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34597 DO 500 J=MMIN2,MMAX2
34598 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
34599 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34600 IF(EI*EJ.GT.0D0) GOTO 500
34601 FACLR=VINT(180+I)*VINT(180+J)
34606 SIGH(NCHN)=FACLR*FACWW*FACBW
34610 ELSEIF(ISUB.EQ.143) THEN
34611 C...f + fbar' -> H+/-
34612 SQMHC=PMAS(37,1)**2
34613 CALL PYWIDT(37,SH,WDTP,WDTE)
34615 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
34616 HP=AEM/(8D0*XW)*SH/SQMW*SH
34617 DO 530 I=MMIN1,MMAX1
34618 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
34620 IM=(MOD(IA,10)+1)/2
34621 DO 520 J=MMIN2,MMAX2
34622 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
34624 JM=(MOD(JA,10)+1)/2
34625 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
34626 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34628 IF(MOD(IA,2).EQ.0) THEN
34635 RML=PYMRUN(IL,SH)**2/SH
34636 RMU=PYMRUN(IU,SH)**2/SH
34637 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
34638 IF(IA.LE.10) HI=HI*FACA/3D0
34639 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
34640 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
34645 SIGH(NCHN)=HI*FACBW*HF
34649 ELSEIF(ISUB.EQ.161) THEN
34650 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
34651 C...(choice of only b and t to avoid kinematics problems)
34652 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
34653 C...H propagator: as simulated in PYOFSH and as desired
34654 SQMHC=PMAS(37,1)**2
34655 GMMHC=PMAS(37,1)*PMAS(37,2)
34656 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
34657 CALL PYWIDT(37,SQM4,WDTP,WDTE)
34658 GMMHCC=SQRT(SQM4)*WDTP(0)
34659 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
34660 FHCQ=FHCQ*HBW4C/HBW4
34662 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
34663 DO 550 I=MMINA,MMAXA
34665 IF(IA.NE.5) GOTO 550
34666 SQML=PYMRUN(IA,Q2RM)**2
34668 SQMQ=PYMRUN(IUA,Q2RM)**2
34669 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
34670 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
34671 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
34672 & (SQMHC-SQMQ-SH)/SH)
34673 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
34675 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
34676 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
34679 ISIG(NCHN,3-ISDE)=21
34681 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
34682 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
34687 ELSEIF(ISUB.LE.402) THEN
34688 IF(ISUB.EQ.401) THEN
34689 C... g + g -> t + bbar + H-
34690 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
34693 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34695 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
34696 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34702 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
34703 c Since we don't know yet if H+ or H-, assume H+
34704 c when calculating suppression due to closed channels.
34705 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
34706 IF(ABS(WIDS(37,2)-WIDS(37,3))
34707 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
34708 & ABS(WIDS(6,2)-WIDS(6,3))
34709 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
34710 WRITE(*,*)'Error: Process 401 cannot handle different'
34711 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34712 WRITE(*,*)'Execution stopped.'
34717 ELSEIF(ISUB.EQ.402) THEN
34718 C... q + qbar -> t + bbar + H-
34721 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34723 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
34724 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34726 DO 570 I=MMINA,MMAXA
34727 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34728 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
34733 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
34734 c Since we don't know yet if H+ or H-, assume H+
34735 c when calculating suppression due to closed channels.
34736 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
34737 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
34739 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
34741 WRITE(*,*)'Error: Process 402 cannot handle different'
34742 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34743 WRITE(*,*)'Execution stopped.'
34753 C*********************************************************************
34756 C...Subprocess cross sections for SUSY processes,
34757 C...including Higgs pair production.
34758 C...Auxiliary to PYSIGH.
34760 SUBROUTINE PYSGSU(NCHN,SIGS)
34762 C...Double precision and integer declarations
34763 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34764 IMPLICIT INTEGER(I-N)
34765 INTEGER PYK,PYCHGE,PYCOMP
34766 C...Parameter statement to help give large particle numbers.
34767 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34768 &KEXCIT=4000000,KDIMEN=5000000)
34770 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34771 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34772 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34773 COMMON/PYINT1/MINT(400),VINT(400)
34774 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
34775 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
34776 COMMON/PYINT4/MWID(500),WIDS(500,5)
34777 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34778 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34779 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
34780 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
34781 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
34782 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
34783 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
34784 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
34785 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
34786 C...Local arrays and complex variables
34787 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
34788 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
34789 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
34790 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
34793 C...Z and W width, combinations of weak mixing angle
34797 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
34799 C...Convert almost equivalent SUSY processes into each other
34800 C...Extract differences in flavours and couplings
34802 C...Sleptons and sneutrinos
34803 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
34804 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34807 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
34808 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34811 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
34812 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34814 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
34815 IF(ISUB.EQ.210) THEN
34817 ELSEIF(ISUB.EQ.211) THEN
34819 ELSEIF(ISUB.EQ.212) THEN
34823 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
34824 IF(ISUB.EQ.213) THEN
34825 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34827 ELSEIF(ISUB.EQ.214) THEN
34834 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
34835 IF(ISUB.EQ.216) THEN
34838 ELSEIF(ISUB.EQ.217) THEN
34841 ELSEIF(ISUB.EQ.218) THEN
34844 ELSEIF(ISUB.EQ.219) THEN
34847 ELSEIF(ISUB.EQ.220) THEN
34850 ELSEIF(ISUB.EQ.221) THEN
34853 ELSEIF(ISUB.EQ.222) THEN
34856 ELSEIF(ISUB.EQ.223) THEN
34859 ELSEIF(ISUB.EQ.224) THEN
34862 ELSEIF(ISUB.EQ.225) THEN
34869 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
34870 IF(ISUB.EQ.226) THEN
34873 ELSEIF(ISUB.EQ.227) THEN
34876 ELSEIF(ISUB.EQ.228) THEN
34882 C...Neutralino + chargino
34883 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
34884 IF(ISUB.EQ.229) THEN
34887 ELSEIF(ISUB.EQ.230) THEN
34890 ELSEIF(ISUB.EQ.231) THEN
34893 ELSEIF(ISUB.EQ.232) THEN
34896 ELSEIF(ISUB.EQ.233) THEN
34899 ELSEIF(ISUB.EQ.234) THEN
34902 ELSEIF(ISUB.EQ.235) THEN
34905 ELSEIF(ISUB.EQ.236) THEN
34911 C...Gluino + neutralino
34912 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
34913 IF(ISUB.EQ.237) THEN
34915 ELSEIF(ISUB.EQ.238) THEN
34917 ELSEIF(ISUB.EQ.239) THEN
34919 ELSEIF(ISUB.EQ.240) THEN
34924 C...Gluino + chargino
34925 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
34926 IF(ISUB.EQ.241) THEN
34928 ELSEIF(ISUB.EQ.242) THEN
34933 C...Squark + neutralino
34934 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
34936 IF(MOD(ISUB,2).NE.0) ILR=1
34937 IF(ISUB.LE.247) THEN
34939 ELSEIF(ISUB.LE.249) THEN
34941 ELSEIF(ISUB.LE.251) THEN
34943 ELSEIF(ISUB.LE.253) THEN
34949 C...Squark + chargino
34950 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
34951 IF(ISUB.LE.255) THEN
34953 ELSEIF(ISUB.LE.257) THEN
34956 IF(MOD(ISUB,2).EQ.0) THEN
34964 C...Squark + gluino
34965 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
34970 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
34972 IF(ISUB.EQ.262) ILR=1
34974 ELSEIF(ISUB.EQ.265) THEN
34978 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
34980 IF(ISUB.LE.273) THEN
34981 IF(ISUB.EQ.273) ILR=1
34984 ELSEIF(ISUB.LE.276) THEN
34985 IF(ISUB.EQ.276) ILR=1
34988 ELSEIF(ISUB.LE.278) THEN
34989 IF(ISUB.EQ.278) ILR=1
34993 IF(ISUB.EQ.280) ILR=1
34998 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
35000 IF(ISUB.LE.283) THEN
35001 IF(ISUB.EQ.283) ILR=1
35004 ELSEIF(ISUB.LE.286) THEN
35005 IF(ISUB.EQ.286) ILR=1
35008 ELSEIF(ISUB.LE.288) THEN
35009 IF(ISUB.EQ.288) ILR=1
35012 ELSEIF(ISUB.LE.290) THEN
35013 IF(ISUB.EQ.290) ILR=1
35016 ELSEIF(ISUB.LE.293) THEN
35017 IF(ISUB.EQ.293) ILR=1
35020 ELSEIF(ISUB.EQ.296) THEN
35024 C...Squark + gluino
35025 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
35030 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
35031 IF(ISUB.EQ.297) THEN
35032 RKF=.5D0*PARU(195)**2
35033 ELSEIF(ISUB.EQ.298) THEN
35034 RKF=.5D0*(1D0-PARU(195)**2)
35038 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
35039 IF(ISUB.EQ.299) THEN
35042 ELSEIF(ISUB.EQ.300) THEN
35048 ELSEIF(ISUB.EQ.301) THEN
35054 C...Supersymmetric processes - all of type 2 -> 2 :
35055 C...correct final-state Breit-Wigners from fixed to running width.
35056 IF(MSTP(42).GT.0) THEN
35058 KFLW=KFPR(ISUBSV,I)
35060 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
35061 IF(I.EQ.1) SQMI=SQM3
35062 IF(I.EQ.2) SQMI=SQM4
35063 SQMS=PMAS(KCW,1)**2
35064 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
35065 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
35066 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
35067 GMMI=SQRT(SQMI)*WDTP(0)
35068 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
35069 COMFAC=COMFAC*(HBWI/HBWS)
35073 C...Differential cross section expressions.
35075 IF(ISUB.LE.210) THEN
35076 IF(ISUB.EQ.201) THEN
35077 C...f + fbar -> e_L + e_Lbar
35078 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35079 DO 130 I=MMIN1,MMAX1
35081 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
35083 TT3I=SIGN(1D0,EI+1D-6)/2D0
35087 C...Color factor for e+ e-
35088 IF(IA.GE.11) FCOL=3D0
35089 IF(ISUBSV.EQ.301) THEN
35092 ELSEIF(ILR.EQ.1) THEN
35093 A1=SFMIX(KFID,3)**2
35094 A2=SFMIX(KFID,4)**2
35095 ELSEIF(ILR.EQ.0) THEN
35096 A1=SFMIX(KFID,1)**2
35097 A2=SFMIX(KFID,2)**2
35099 XLQ=(TT3J-EJ*XW)*A1
35103 TAA=(EI*EJ)**2*(POLL+POLR)
35104 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
35105 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
35106 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
35107 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35111 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35117 DK=1D0/(TH-SMZ(II)**2)
35118 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35120 FREK=FAC2*TANW*EI*ZMIX(II,1)
35121 TNN1=TNN1+FLEK**2*DK
35122 TNN2=TNN2+FREK**2*DK
35124 DL=1D0/(TH-SMZ(JJ)**2)
35125 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35127 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35128 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35131 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
35132 & A2**2*TNN2**2*POLR)
35133 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
35134 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
35135 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
35136 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
35137 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35140 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
35143 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
35144 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
35145 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
35150 SIGH(NCHN)=FACQQ1+FACQQ2
35153 ELSEIF(ISUB.EQ.203) THEN
35154 C...f + fbar -> e_L + e_Rbar
35155 DO 160 I=MMIN1,MMAX1
35157 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
35158 EI=KCHG(IABS(I),1)/3D0
35159 TT3I=SIGN(1D0,EI)/2D0
35163 C...Color factor for e+ e-
35164 IF(IA.GE.11) FCOL=3D0
35165 A1=SFMIX(KFID,1)**2
35166 A2=SFMIX(KFID,2)**2
35171 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
35172 & /XW**2/XW1**2*A1*A2
35173 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35178 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35184 DK=1D0/(TH-SMZ(II)**2)
35185 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35187 FREK=FAC2*TANW*EI*ZMIX(II,1)
35188 TNN1=TNN1+FLEK**2*DK
35189 TNN2=TNN2+FREK**2*DK
35191 DL=1D0/(TH-SMZ(JJ)**2)
35192 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35194 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35195 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35198 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
35199 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
35200 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
35201 TZN=(UH*TH-SQM3*SQM4)*A1*A2
35202 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
35203 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35206 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
35207 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
35208 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
35214 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35215 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35220 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35221 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35224 ELSEIF(ISUB.EQ.210) THEN
35225 C...q + qbar' -> W*- > ~l_L + ~nu_L
35226 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
35227 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
35228 DO 180 I=MMIN1,MMAX1
35230 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
35231 DO 170 J=MMIN2,MMAX2
35233 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
35234 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
35236 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35237 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35239 IF(KCHSUM.LT.0) KCHW=3
35244 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
35245 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35246 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35248 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35249 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35251 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
35256 ELSEIF(ISUB.LE.220) THEN
35257 IF(ISUB.EQ.213) THEN
35258 C...f + fbar -> ~nu_L + ~nu_Lbar
35259 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
35260 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35261 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35263 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35266 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
35269 DO 190 I=MMIN1,MMAX1
35271 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
35274 C...Color factor for e+ e-
35275 IF(IA.GE.11) FCOL=3D0
35276 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
35280 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
35281 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
35284 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
35286 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
35292 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
35293 & *AEM**2*FCOL/3D0/XW**2
35296 ELSEIF(ISUB.EQ.216) THEN
35297 C...q + qbar -> ~chi0_1 + ~chi0_1
35298 IF(IZID1.EQ.IZID2) THEN
35299 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35301 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35302 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35304 FACXX=COMFAC*AEM**2/3D0/XW**2
35305 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
35308 WU2 = (UH-ZM12)*(UH-ZM22)
35309 WT2 = (TH-ZM12)*(TH-ZM22)
35310 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
35311 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35312 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35314 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
35315 IF(IZID2.NE.IZID1) THEN
35316 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35319 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
35320 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
35322 DO 210 I=MMINA,MMAXA
35323 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
35324 EI=KCHG(IABS(I),1)/3D0
35325 T3I=SIGN(1D0,EI+1D-6)/2D0
35326 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
35327 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
35328 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
35329 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
35330 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
35331 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
35332 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
35334 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
35335 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
35336 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
35338 IF(IABS(I).GE.11) FCOL=3D0
35339 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
35340 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
35341 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
35342 & QRL*DCONJG(QRR)*POLR)*WS2
35347 SIGH(NCHN)=FACXX*FACGG1*FCOL
35351 ELSEIF(ISUB.LE.230) THEN
35352 IF(ISUB.EQ.226) THEN
35353 C...f + fbar -> ~chi+_1 + ~chi-_1
35354 FACXX=COMFAC*AEM**2/3D0
35357 WU2 = (UH-ZM12)*(UH-ZM22)
35358 WT2 = (TH-ZM12)*(TH-ZM22)
35359 WS2 = SMW(IZID1)*SMW(IZID2)*SH
35360 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35361 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35363 IF(IZID1.EQ.IZID2) DIFF=1D0
35365 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
35366 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
35367 IF(IZID2.NE.IZID1) THEN
35368 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
35369 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
35372 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
35373 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
35374 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
35375 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
35376 DO 230 I=MMINA,MMAXA
35377 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
35378 EI=KCHG(IABS(I),1)/3D0
35379 T3I=SIGN(1D0,EI+1D-6)/2D0
35380 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
35381 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
35382 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
35383 IF(MOD(I,2).EQ.0) THEN
35384 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
35385 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
35386 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
35387 & DCMPLX(T3I/XW/(TH-XML2))
35389 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
35390 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
35391 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
35392 & DCMPLX(T3I/XW/(TH-XML2))
35395 IF(IABS(I).GE.11) FCOL=3D0
35396 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
35397 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
35398 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
35399 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
35404 IF(IZID1.EQ.IZID2) THEN
35405 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35407 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35408 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35413 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35414 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35418 ELSEIF(ISUB.EQ.229) THEN
35419 C...q + qbar' -> ~chi0_1 + ~chi+-_1
35420 FACXX=COMFAC*AEM**2/6D0/XW**2
35423 WU2 = (UH-ZM12)*(UH-ZM22)
35424 WT2 = (TH-ZM12)*(TH-ZM22)
35425 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
35426 RT2I = 1D0/SQRT(2D0)
35427 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
35428 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
35430 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
35431 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
35434 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35436 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
35437 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
35438 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
35439 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
35441 DO 270 I=MMIN1,MMAX1
35443 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
35445 T3I=SIGN(1D0,EI+1D-6)/2D0
35446 DO 260 J=MMIN2,MMAX2
35448 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
35449 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
35451 T3J=SIGN(1D0,EJ+1D-6)/2D0
35453 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35454 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35456 IF(KCHSUM.LT.0) KCHW=3
35457 IF(MOD(IA,2).EQ.0) THEN
35458 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
35459 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
35460 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
35461 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
35462 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
35463 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
35466 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
35467 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
35468 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
35469 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
35470 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
35471 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
35474 ZINTR=DBLE(QLR*DCONJG(QLL))
35475 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
35481 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35482 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35487 ELSEIF(ISUB.LE.240) THEN
35488 IF(ISUB.EQ.237) THEN
35489 C...q + qbar -> gluino + ~chi0_1
35490 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35491 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35493 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
35496 DO 280 I=MMINA,MMAXA
35497 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
35498 EI=KCHG(IABS(I),1)/3D0
35500 XLQC = -TANW*EI*ZMIX(IZID,1)
35501 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
35502 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
35505 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
35506 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
35507 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
35508 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
35509 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
35510 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
35511 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
35512 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
35513 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
35514 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
35519 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
35523 ELSEIF(ISUB.LE.250) THEN
35524 IF(ISUB.EQ.241) THEN
35525 C...q + qbar' -> ~chi+-_1 + gluino
35526 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
35529 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
35530 FAC0=UMIX(IZID,1)**2
35531 FAC1=VMIX(IZID,1)**2
35532 DO 300 I=MMIN1,MMAX1
35534 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
35535 DO 290 J=MMIN2,MMAX2
35537 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
35538 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
35540 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35541 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35543 IF(KCHSUM.LT.0) KCHW=3
35544 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
35545 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
35546 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
35547 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
35548 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
35549 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
35550 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
35551 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
35552 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
35553 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
35554 & SH/(TH-XMU2)/(UH-XMD2))/2D0
35559 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
35560 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35561 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35565 ELSEIF(ISUB.EQ.243) THEN
35566 C...q + qbar -> gluino + gluino
35567 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35570 DO 310 I=MMINA,MMAXA
35571 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35572 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
35574 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
35575 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
35576 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
35577 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
35578 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
35579 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
35580 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
35581 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
35582 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
35583 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
35584 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
35585 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
35589 C...1/2 for identical particles
35590 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
35593 ELSEIF(ISUB.EQ.244) THEN
35594 C...g + g -> gluino + gluino
35595 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35598 FACQQ1=COMFAC*AS**2*9D0/4D0*(
35599 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
35600 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
35601 FACQQ2=COMFAC*AS**2*9D0/4D0*(
35602 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
35603 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
35604 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
35605 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
35606 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
35611 SIGH(NCHN)=FACQQ1/2D0
35616 SIGH(NCHN)=FACQQ2/2D0
35621 SIGH(NCHN)=FACQQ3/2D0
35624 ELSEIF(ISUB.EQ.246) THEN
35625 C...g + q_j -> ~chi0_1 + ~q_j
35626 FAC0=COMFAC*AS*AEM/6D0/XW
35629 FACZQ0=FAC0*( (ZM2-TH)/SH +
35630 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
35631 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
35632 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35633 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
35634 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
35635 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
35636 EI=KCHG(IABS(I),1)/3D0
35638 XRQZ = -TANW*EI*ZMIX(IZID,1)
35639 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
35640 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
35642 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
35644 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
35650 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
35651 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
35654 ISIG(NCHN,3-ISDE)=21
35656 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35657 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35662 ELSEIF(ISUB.LE.260) THEN
35663 IF(ISUB.EQ.254) THEN
35664 C...g + q_j -> ~chi1_1 + ~q_i
35665 FAC0=COMFAC*AS*AEM/12D0/XW
35670 FACZQ0=FAC0*( (ZM2-TH)/SH +
35671 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
35672 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
35673 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
35674 IF(MOD(KFNSQ1,2).EQ.0) THEN
35681 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
35682 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
35683 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
35685 IF(MOD(IA,2).EQ.0) THEN
35690 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
35694 IF(I.LT.0) KCHWQ=5-KCHW
35696 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
35697 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
35700 ISIG(NCHN,3-ISDE)=21
35702 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35703 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
35707 ELSEIF(ISUB.EQ.258) THEN
35708 C...g + q_j -> gluino + ~q_i
35715 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
35716 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
35717 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
35718 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
35719 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
35721 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
35722 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
35723 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
35725 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
35726 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
35727 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35728 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
35729 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
35730 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
35733 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35734 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35736 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
35737 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
35740 ISIG(NCHN,3-ISDE)=21
35742 SIGH(NCHN)=FACQG1*FACSEL
35745 ISIG(NCHN,3-ISDE)=21
35747 SIGH(NCHN)=FACQG2*FACSEL
35752 ELSEIF(ISUB.LE.270) THEN
35753 IF(ISUB.EQ.261) THEN
35754 C...q_i + q_ibar -> ~t_1 + ~t_1bar
35755 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
35756 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35757 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35759 DO 390 I=MMIN1,MMAX1
35761 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
35762 IF(IA.GE.11.AND.IA.LE.18) THEN
35764 EJ=KCHG(KFNSQ,1)/3D0
35765 T3I=SIGN(1D0,EI)/2D0
35766 T3J=SIGN(1D0,EJ)/2D0
35767 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
35768 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
35769 XLF=2D0*(T3I-EI*XW)
35771 TAA=0.5D0*(EI*EJ)**2
35772 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35773 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35774 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35775 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35776 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35782 SIGH(NCHN)=FACQQ1*FAC0
35785 ELSEIF(ISUB.EQ.263) THEN
35786 C...f + fbar -> ~t1 + ~t2bar
35787 DO 400 I=MMIN1,MMAX1
35789 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
35790 EI=KCHG(IABS(I),1)/3D0
35791 TT3I=SIGN(1D0,EI)/2D0
35795 C...Color factor for e+ e-
35796 IF(IA.GE.11) FCOL=3D0
35797 XLQ=2D0*(TT3J-EJ*XW)
35799 XLF=2D0*(TT3I-EI*XW)
35801 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
35802 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
35803 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35804 C...Factor of 2 for t1 t2bar + t2 t1bar
35805 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
35806 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
35811 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35812 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35817 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35818 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35821 ELSEIF(ISUB.EQ.264) THEN
35822 C...g + g -> ~t_1 + ~t_1bar
35825 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
35826 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35827 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
35828 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
35829 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
35843 ELSEIF(ISUB.LE.280) THEN
35844 IF(ISUB.EQ.271) THEN
35845 C...q + q' -> ~q + ~q' (~g exchange)
35846 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35855 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
35856 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
35859 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
35860 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
35861 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
35864 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35865 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35866 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
35867 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
35869 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
35872 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35873 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
35875 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
35876 IF(I*J.LT.0) GOTO 420
35881 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35882 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35885 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
35886 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35888 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
35889 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35890 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35897 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
35898 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35900 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
35901 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35902 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35908 ELSEIF(ISUB.EQ.274) THEN
35909 C...q + qbar' -> ~q + ~qbar'
35910 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35914 C...Mrenna...Normalization.and.1/XMT
35915 FACQQ1=COMFAC*AS**2*2D0/9D0*(
35916 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
35917 FACQQB=COMFAC*AS**2*4D0/9D0*(
35918 & (UH*TH-SQM3*SQM4)/SH2 )
35919 FACQQI=-COMFAC*AS**2*4D0/27D0*(
35920 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
35921 FACQQB=FACQQB+FACQQ1+FACQQI
35923 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
35926 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35927 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35928 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
35929 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
35931 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
35934 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35935 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
35937 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
35938 IF(I*J.GT.0) GOTO 440
35943 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35944 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
35945 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
35946 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35950 ELSEIF(ISUB.EQ.277) THEN
35951 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
35952 C...if i .eq. j covered in 274
35953 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
35954 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35956 DO 460 I=MMIN1,MMAX1
35958 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
35959 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
35960 IF(IA.EQ.KFNSQ) GOTO 460
35961 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
35963 EJ=KCHG(KFNSQ,1)/3D0
35965 T3I=SIGN(1D0,EI)/2D0
35967 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
35968 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
35970 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
35971 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
35973 XLF=2D0*(T3I-EI*XW)
35980 TAA=0.5D0*(EI*EJ)**2
35981 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35982 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35983 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35984 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35985 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35986 ELSEIF(IA.LE.6) THEN
35987 FAC0=AS**2*8D0/9D0/2D0
35993 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35996 ELSEIF(ISUB.EQ.279) THEN
35997 C...g + g -> ~q_j + ~q_jbar
36000 C...5=RKF because ~t ~tbar treated separately
36001 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
36002 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
36003 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
36004 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
36009 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36014 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36024 C*********************************************************************
36027 C...Subprocess cross sections for Technicolor processes.
36028 C...Auxiliary to PYSIGH.
36030 SUBROUTINE PYSGTC(NCHN,SIGS)
36032 C...Double precision and integer declarations
36033 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36034 IMPLICIT INTEGER(I-N)
36035 INTEGER PYK,PYCHGE,PYCOMP
36036 C...Parameter statement to help give large particle numbers.
36037 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36038 &KEXCIT=4000000,KDIMEN=5000000)
36040 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36041 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36042 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36043 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36044 COMMON/PYINT1/MINT(400),VINT(400)
36045 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36046 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36047 COMMON/PYINT4/MWID(500),WIDS(500,5)
36048 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36049 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36050 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36051 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36052 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36053 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36054 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36055 C...Local arrays and complex variables
36056 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36057 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
36058 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
36059 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
36060 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
36061 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
36062 COMPLEX*16 DVVS,DVVT,DVVU
36065 C...Combinations of weak mixing angle.
36067 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
36069 C...Convert almost equivalent technicolor processes into
36070 C...a few basic processes, and set distinguishing parameters.
36071 IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
36074 SN2W=2D0*SQRT(XW*XW1)
36077 CSXI=COS(ASIN(RTCM(3)))
36078 CSXIP=COS(ASIN(RTCM(4)))
36079 QUPD=2D0*RTCM(2)-1D0
36080 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
36091 C... rho_tc0, etc. -> W_L W_L, W_L W_T
36092 IF(ISUB.EQ.361) THEN
36096 AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36097 ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36098 VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
36099 C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
36100 AXGP = SQRT(2D0)*AXGP
36101 ARGP = SQRT(2D0)*ARGP
36102 VOGP = SQRT(2D0)*VOGP
36103 C... rho_tc0 -> W_L pi_tc-
36104 ELSEIF(ISUB.EQ.362) THEN
36108 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36110 ELSEIF(ISUB.EQ.363) THEN
36114 CAB2=(1D0-RTCM(3)**2)**2
36115 C... rho_tc0/omega_tc -> gamma pi_tc
36116 ELSEIF(ISUB.EQ.364) THEN
36123 VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36125 ELSEIF(ISUB.EQ.365) THEN
36129 VRGP=CSXIP/RTCM(12)
36131 VAGP=2D0*Q2UD*CSXIP
36132 VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
36134 ELSEIF(ISUB.EQ.366) THEN
36138 VOGP=CSXI*CT2W/RTCM(12)
36139 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36140 VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36141 VZGP=-QUPD*CSXI*CS2W/XW1
36143 ELSEIF(ISUB.EQ.367) THEN
36147 C...RTCM(48) is the M_V for the techni-a
36148 VXGP=-CSXIP/SN2W/RTCM(48)
36149 VRGP=CSXIP*CT2W/RTCM(12)
36150 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
36151 VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
36152 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
36154 ELSEIF(ISUB.EQ.368) THEN
36158 C...RTCM(49) is the M_A for the techni-a
36159 AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
36160 VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
36161 ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
36162 VAGP=QUPD*CSXI/(2D0*SQRT(XW))
36163 VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36164 C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
36165 ELSEIF(ISUB.EQ.370) THEN
36169 ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36170 AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36172 ELSEIF(ISUB.EQ.371) THEN
36176 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36178 ELSEIF(ISUB.EQ.372) THEN
36182 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36184 ELSEIF(ISUB.EQ.373) THEN
36188 CAB2=(1D0-RTCM(3)**2)**2
36190 ELSEIF(ISUB.EQ.374) THEN
36194 VRGP=QUPD*CSXI/RTCM(12)
36195 VWGP=QUPD*CSXI/(2D0*SQRT(XW))
36196 AXGP=-CSXI/RTCM(49)
36198 ELSEIF(ISUB.EQ.375) THEN
36202 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36203 ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
36204 VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36205 AXGP=-CSXI*CT2W/RTCM(49)
36207 ELSEIF(ISUB.EQ.376) THEN
36212 ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
36213 AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
36215 ELSEIF(ISUB.EQ.377) THEN
36219 VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
36220 VWGP=CSXIP/(2D0*XW)
36221 VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
36223 ELSEIF(ISUB.EQ.378) THEN
36227 VRGP=QUPD*RTCM(3)/RTCM(12)
36228 AXGP=-RTCM(3)/RTCM(49)
36230 ELSEIF(ISUB.EQ.379) THEN
36234 VOGP=RTCM(3)/RTCM(12)
36235 VRGP=QUPD*RTCM(3)/RTCM(12)
36236 ELSEIF(ISUB.EQ.380) THEN
36240 VOGP=RTCM(3)*CT2W/RTCM(12)
36241 VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
36245 C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
36246 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
36247 IF(ITCM(5).LE.4) THEN
36265 ELSEIF(ITCM(5).EQ.5) THEN
36267 IF(ITCM(2).EQ.0) THEN
36272 ALPRHT=2.16D0*(3D0/ITCM(1))
36273 SIN2T=2D0*TANT3/(TANT3**2+1D0)
36274 SINT3=TANT3/SQRT(TANT3**2+1D0)
36275 XIG=SQRT(PYALPS(SH)/ALPRHT)
36276 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
36277 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
36278 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
36279 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
36280 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
36281 & SINT3**2)*2D0/SIN2T
36282 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
36283 & SINT3**2)*2D0/SIN2T
36285 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
36286 SM1112=X12*RTCM(28)**2*SIN2T
36287 SM1121=-X21*RTCM(28)**2*SIN2T
36290 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
36291 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
36294 ZTC(1,1)=DCMPLX(SH,0D0)
36295 CALL PYWIDT(3100021,SH,WDTP,WDTE)
36296 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
36297 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
36298 CALL PYWIDT(3100113,SH,WDTP,WDTE)
36299 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
36300 CALL PYWIDT(3400113,SH,WDTP,WDTE)
36301 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
36302 CALL PYWIDT(3200113,SH,WDTP,WDTE)
36303 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
36304 CALL PYWIDT(3300113,SH,WDTP,WDTE)
36305 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
36307 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
36311 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
36312 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
36313 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
36314 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
36327 CALL PYLDCM(ZTC,6,6,INDX,D)
36331 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36336 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36342 XIG=SQRT(PYALPS(-TH)/ALPRHT)
36344 ZTC(1,1)=DCMPLX(TH)
36345 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
36346 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
36347 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
36348 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
36349 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
36351 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
36355 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
36356 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
36357 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
36358 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
36370 CALL PYLDCM(ZTC,6,6,INDX,D)
36374 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36378 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36384 XIG=SQRT(PYALPS(-UH)/ALPRHT)
36386 ZTC(1,1)=DCMPLX(UH,0D0)
36387 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
36388 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
36389 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
36390 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
36391 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
36393 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
36397 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
36398 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
36399 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
36400 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
36412 CALL PYLDCM(ZTC,6,6,INDX,D)
36416 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36420 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36427 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
36428 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
36429 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
36430 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
36431 DQGS=DGGS-DGVS*DCMPLX(TANT3)
36432 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36434 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
36435 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
36436 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
36437 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
36438 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36439 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36442 SQDQTS=ABS(DQTS)**2
36443 SQDQQS=ABS(DQQS)**2
36444 SQDQQT=ABS(DQQT)**2
36445 SQDQQU=ABS(DQQU)**2
36446 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
36448 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
36450 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
36452 SQDGGS=ABS(DGGS)**2
36453 SQDGGT=ABS(DGGT)**2
36454 SQDGGU=ABS(DGGU)**2
36458 REDGTU=DBLE(DGGU*DCONJG(DGGT))
36459 REDGSU=DBLE(DGGU*DCONJG(DGGS))
36460 REDGST=DBLE(DGGS*DCONJG(DGGT))
36461 REDQST=DBLE(DQQS*DCONJG(DQQT))
36462 REDQTU=DBLE(DQQT*DCONJG(DQQU))
36467 C...Differential cross section expressions.
36469 IF(ISUB.LE.190) THEN
36470 IF(ISUB.EQ.149) THEN
36471 C...g + g -> eta_tc
36472 KCTC=PYCOMP(KTECHN+331)
36473 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
36475 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
36476 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36478 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
36480 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36485 SIGH(NCHN)=HI*FACBW*HF
36488 ELSEIF(ISUB.EQ.165) THEN
36489 C...q + qbar -> l+ + l- (including contact term for compositeness)
36490 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36491 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36492 KFF=IABS(KFPR(ISUB,1))
36494 AF=SIGN(1D0,EF+0.1D0)
36499 IF(KFF.LE.10) FCOF=3D0
36501 IF(KFF.EQ.6) WID2=WIDS(6,1)
36502 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
36503 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
36504 DO 260 I=MMINA,MMAXA
36505 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
36506 EI=KCHG(IABS(I),1)/3D0
36507 AI=SIGN(1D0,EI+0.1D0)
36512 IF(IABS(I).LE.10) FCOI=FACA/3D0
36513 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
36514 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
36515 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
36516 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
36518 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
36519 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
36521 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
36522 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
36523 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
36524 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
36525 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
36530 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
36533 ELSEIF(ISUB.EQ.166) THEN
36534 C...q + q'bar -> l + nu_l (including contact term for compositeness)
36535 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
36536 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
36537 KFF=IABS(KFPR(ISUB,1))
36539 IF(KFF.LE.10) FCOF=3D0
36540 DO 280 I=MMIN1,MMAX1
36541 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
36543 DO 270 J=MMIN2,MMAX2
36544 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
36546 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
36547 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36550 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36552 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
36553 & MOD(J,2).EQ.0)) THEN
36554 IF(KFF.EQ.5) WID2=WIDS(6,2)
36555 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
36556 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
36558 IF(KFF.EQ.5) WID2=WIDS(6,3)
36559 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
36560 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
36566 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
36567 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
36568 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
36573 ELSEIF(ISUB.LE.200) THEN
36574 IF(ISUB.EQ.191) THEN
36575 C...q + qbar -> rho_tc0.
36576 KCTC=PYCOMP(KTECHN+113)
36577 SQMRHT=PMAS(KCTC,1)**2
36578 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36580 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
36581 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36582 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36583 ALPRHT=2.16D0*(3D0/ITCM(1))
36584 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
36585 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
36586 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36587 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36588 DO 290 I=MMINA,MMAXA
36589 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
36591 EI=KCHG(IABS(I),1)/3D0
36592 AI=SIGN(1D0,EI+0.1D0)
36596 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
36597 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
36598 IF(IA.LE.10) HI=HI*FACA/3D0
36603 SIGH(NCHN)=HI*FACBW*HF
36606 ELSEIF(ISUB.EQ.192) THEN
36607 C...q + qbar' -> rho_tc+/-.
36608 KCTC=PYCOMP(KTECHN+213)
36609 SQMRHT=PMAS(KCTC,1)**2
36610 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36612 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
36613 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36614 ALPRHT=2.16D0*(3D0/ITCM(1))
36615 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
36616 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
36617 DO 310 I=MMIN1,MMAX1
36618 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
36620 DO 300 J=MMIN2,MMAX2
36621 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
36623 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
36624 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36626 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36627 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
36629 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36634 SIGH(NCHN)=HI*FACBW*HF
36638 ELSEIF(ISUB.EQ.193) THEN
36639 C...q + qbar -> omega_tc0.
36640 KCTC=PYCOMP(KTECHN+223)
36641 SQMOMT=PMAS(KCTC,1)**2
36642 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36644 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
36645 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36646 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36647 ALPRHT=2.16D0*(3D0/ITCM(1))
36648 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
36649 & (2D0*RTCM(2)-1D0)**2
36650 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36651 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36652 DO 320 I=MMINA,MMAXA
36653 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
36655 EI=KCHG(IABS(I),1)/3D0
36656 AI=SIGN(1D0,EI+0.1D0)
36660 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
36661 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
36662 IF(IA.LE.10) HI=HI*FACA/3D0
36667 SIGH(NCHN)=HI*FACBW*HF
36670 ELSEIF(ISUB.EQ.194) THEN
36671 C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
36672 C...Default final state is e+e-
36674 ALPRHT=2.16D0*(3D0/ITCM(1))
36677 SN2W=2D0*SQRT(XW*XW1)
36678 C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
36679 C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
36681 QUPD=2D0*RTCM(2)-1D0
36682 FAR=SQRT(AEM/ALPRHT)
36686 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36687 FZX=-FAR/SN2W*RTCM(47)
36693 CALL PYWIDT(23,SH,WDTP,WDTE)
36694 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
36695 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36696 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
36697 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36698 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
36699 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
36700 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
36701 C...Propagator including a_T^0
36702 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
36703 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
36704 C...Add in techni-a contribution
36705 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
36706 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
36707 $ SFZX*SSMR*SSMO)/DETD/SH
36708 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
36709 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
36711 XWRHT=1D0/(4D0*XW*(1D0-XW))
36712 KFF=IABS(KFPR(ISUB,1))
36714 AF=SIGN(1D0,EF+0.1D0)
36719 IF(KFF.LE.10) FCOF=3D0
36722 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
36723 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
36724 DZZ=DZZ*DCMPLX(XWRHT,0D0)
36725 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
36727 DO 330 I=MMINA,MMAXA
36728 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
36729 EI=KCHG(IABS(I),1)/3D0
36730 AI=SIGN(1D0,EI+0.1D0)
36735 IF(IABS(I).LE.10) FCOI=FCOI/3D0
36736 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
36737 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
36738 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
36739 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
36740 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
36741 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
36746 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
36749 ELSEIF(ISUB.EQ.195) THEN
36750 C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
36753 ALPRHT=2.16D0*(3D0/ITCM(1))
36754 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
36756 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36757 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36759 C...Propagator including a_T^+
36761 CALL PYWIDT(24,SH,WDTP,WDTE)
36762 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36763 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36764 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36765 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36766 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36767 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36768 & DCMPLX(FWX**2,0D0)*SSMR
36769 DWW=SSMR*SSMX/DETD/SH
36771 IF(KFA.LE.8) FCOF=3D0
36772 HP=FACTC*ABS(DWW)**2*FCOF
36774 DO 350 I=MMIN1,MMAX1
36775 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
36777 DO 340 J=MMIN2,MMAX2
36778 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
36780 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
36781 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36783 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36785 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36790 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
36795 ELSEIF(ISUB.LE.380) THEN
36796 ALPRHT=2.16D0*(3D0/ITCM(1))
36797 IF(ISUB.EQ.361) THEN
36798 FAR=SQRT(AEM/ALPRHT)
36802 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36803 FZX=-FAR/SN2W*RTCM(47)
36809 CALL PYWIDT(23,SH,WDTP,WDTE)
36810 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
36811 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36812 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
36813 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36814 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
36815 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
36816 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
36817 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
36818 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
36819 C...Add in techni-a contribution
36820 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
36821 DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
36822 $ SFZX*FAR*SSMO)/DETD/SH
36823 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
36824 DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
36825 $ SFZX*FAO*SSMR)/DETD/SH
36826 DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
36827 DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
36828 DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
36829 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
36830 $ SFZX*SSMR*SSMO)/DETD/SH
36831 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
36832 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
36834 C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
36835 C...W+W-, W pi_tc, pi_T pi_T, etc.
36836 FACA=(SH**2*BE34**2-(TH-UH)**2)
36837 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36838 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36839 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36840 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
36841 DO 370 I=MMINA,MMAXA
36842 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
36844 EI=KCHG(IABS(I),1)/3D0
36845 AI=SIGN(1D0,EI+0.1D0)
36847 VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
36848 VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
36849 C...........Eqs. (5) and (6) in LSTC-rates.pdf
36850 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
36851 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
36852 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
36853 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
36854 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
36855 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
36856 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
36857 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
36858 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
36859 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
36860 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
36861 C...........Eqs. (5) and (7) in LSTC-rates.pdf
36862 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
36863 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
36864 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
36865 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
36866 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
36867 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
36868 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
36870 C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
36872 c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36873 c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36874 c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36875 c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36876 F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36877 F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36878 HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
36880 IF(IA.LE.10) HI=HI/3D0
36885 IF(KFA.EQ.KFB) THEN
36886 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
36887 ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
36888 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
36893 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
36895 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
36899 ELSEIF(ISUB.EQ.370) THEN
36900 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
36901 C...f + fbar' -> gamma pi_tc, etc.
36902 FACA=(SH**2*BE34**2-(TH-UH)**2)
36903 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36904 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36905 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36906 ALPRHT=2.16D0*(3D0/ITCM(1))
36907 FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
36908 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36909 C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36911 CALL PYWIDT(24,SH,WDTP,WDTE)
36912 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36913 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36914 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36915 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36916 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36917 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36918 & DCMPLX(FWX**2,0D0)*SSMR
36919 DWW=SSMR*SSMX/DETD/SH
36920 DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
36921 DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
36922 HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
36923 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
36925 C...........Eq. (25) in PRD67-115011 with DWW term dropped.
36927 c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
36928 HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
36929 C...Add in W_L Z_T axial and vector contributions.
36930 IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
36931 $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
36932 $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
36933 $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
36934 DO 410 I=MMIN1,MMAX1
36935 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
36937 DO 400 J=MMIN2,MMAX2
36938 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
36940 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
36941 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36943 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36945 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36950 IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
36951 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
36953 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
36954 & WIDS(PYCOMP(KFB),2)
36960 ELSEIF(ISUB.LE.390) THEN
36961 IF(ISUB.EQ.381) THEN
36962 C...f + f' -> f + f' (g exchange)
36963 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
36964 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
36965 & MSTP(34)*2D0/3D0*UH2*REDQST)
36966 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
36967 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
36968 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
36969 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
36970 C...Modifications from contact interactions (compositeness)
36971 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
36972 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36973 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
36974 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36975 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
36976 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
36977 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
36978 ELSEIF(ITCM(5).EQ.5) THEN
36983 CSM.......Check this change from
36987 DO 430 I=MMIN1,MMAX1
36989 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36990 DO 420 J=MMIN2,MMAX2
36992 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
36997 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
37000 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
37003 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
37004 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
37011 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
37012 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
37013 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
37015 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
37016 SIGH(NCHN)=0.5D0*FACCI2*RATCII
37022 ELSEIF(ISUB.EQ.382) THEN
37023 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
37024 CALL PYWIDT(21,SH,WDTP,WDTE)
37025 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
37026 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37027 IF(ITCM(5).EQ.1) THEN
37028 C...Modifications from contact interactions (compositeness)
37031 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
37032 & WDTE(I,2)+WDTE(I,4))
37034 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
37035 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
37036 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37037 ELSEIF(ITCM(5).EQ.5) THEN
37038 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
37039 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
37040 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
37042 DO 450 I=MMINA,MMAXA
37043 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37044 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
37049 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
37051 ELSEIF(ITCM(5).EQ.5) THEN
37063 ELSEIF(ISUB.EQ.383) THEN
37064 C...f + fbar -> g + g (q + qbar -> g + g only)
37065 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37066 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37067 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37068 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37069 IF(ITCM(5).EQ.5) THEN
37070 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37071 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37072 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37073 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37075 DO 460 I=MMINA,MMAXA
37076 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37077 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
37082 SIGH(NCHN)=0.5D0*FACGG1
37083 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
37088 SIGH(NCHN)=0.5D0*FACGG2
37089 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
37092 ELSEIF(ISUB.EQ.384) THEN
37093 C...f + g -> f + g (q + g -> q + g only)
37094 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
37095 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
37096 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
37097 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
37098 DO 480 I=MMINA,MMAXA
37099 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
37101 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
37102 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
37105 ISIG(NCHN,3-ISDE)=21
37110 ISIG(NCHN,3-ISDE)=21
37116 ELSEIF(ISUB.EQ.385) THEN
37117 C...g + g -> f + fbar (g + g -> q + qbar only)
37118 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
37120 C...Begin by d, u, s flavours.
37122 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
37123 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
37124 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
37125 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
37126 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
37127 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
37128 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37129 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37130 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37131 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37142 C...Next c and b flavours: modified that and uhat for fixed
37143 C...cos(theta-hat).
37145 SQMAVG=PMAS(IFL,1)**2
37146 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
37147 BE34=SQRT(1D0-4D0*SQMAVG/SH)
37148 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37149 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37150 THUHQ=THQ*UHQ-SQMAVG*SH
37151 IF(MSTP(34).EQ.0) THEN
37152 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37153 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37155 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37156 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37157 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37158 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37160 IF(ITCM(5).GE.5) THEN
37162 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37163 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37164 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37165 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37167 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37168 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37169 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37170 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37173 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
37174 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
37178 ISIG(NCHN,3)=1+2*(IFL-3)
37183 ISIG(NCHN,3)=2+2*(IFL-3)
37189 ELSEIF(ISUB.EQ.386) THEN
37191 IF(ITCM(5).LE.4) THEN
37192 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
37193 & 2D0*TH/SH+TH2/SH2)*FACA
37194 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
37195 & 2D0*SH/UH+SH2/UH2)*FACA
37196 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
37197 & 2D0*UH/TH+UH2/TH2)
37199 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
37200 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
37201 & 4D0*REDGST*(SH + 2D0*TH)*
37202 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
37203 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
37204 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
37205 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
37206 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
37207 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
37208 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
37209 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
37210 & 4D0*REDGSU*(SH + 2D0*UH)*
37211 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
37212 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
37213 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
37214 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
37215 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
37216 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
37217 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
37218 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
37219 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
37220 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
37221 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
37222 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
37223 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
37224 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
37225 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
37226 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
37227 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
37228 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
37229 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
37230 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
37231 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
37232 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
37234 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
37239 SIGH(NCHN)=0.5D0*FACGG1
37244 SIGH(NCHN)=0.5D0*FACGG2
37249 SIGH(NCHN)=0.5D0*FACGG3
37252 ELSEIF(ISUB.EQ.387) THEN
37253 C...q + qbar -> Q + Qbar
37254 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37255 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37256 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37257 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
37259 IF(ITCM(5).GE.5) THEN
37260 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37261 FACQQB=FACQQB*SH2*SQDQTS
37263 FACQQB=FACQQB*SH2*SQDQQS
37266 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
37268 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37269 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37271 DO 520 I=MMINA,MMAXA
37272 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37273 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
37281 ELSEIF(ISUB.EQ.388) THEN
37282 C...g + g -> Q + Qbar
37283 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37284 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37285 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37286 THUHQ=THQ*UHQ-SQMAVG*SH
37287 IF(MSTP(34).EQ.0) THEN
37288 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37289 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37291 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37292 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37293 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37294 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37296 IF(ITCM(5).GE.5) THEN
37297 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37298 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37299 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37300 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37301 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37303 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37304 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37305 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37306 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37309 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
37310 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
37311 IF(MSTP(35).GE.1) THEN
37312 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
37313 FACQQ1=FACQQ1*FATRE
37314 FACQQ2=FACQQ2*FATRE
37317 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37318 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37321 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
37341 C*********************************************************************
37344 C...Subprocess cross sections for assorted exotic processes,
37345 C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
37346 C...Auxiliary to PYSIGH.
37348 SUBROUTINE PYSGEX(NCHN,SIGS)
37350 C...Double precision and integer declarations
37351 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37352 IMPLICIT INTEGER(I-N)
37353 INTEGER PYK,PYCHGE,PYCOMP
37354 C...Parameter statement to help give large particle numbers.
37355 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37356 &KEXCIT=4000000,KDIMEN=5000000)
37358 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37359 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37360 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
37361 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37362 COMMON/PYINT1/MINT(400),VINT(400)
37363 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
37364 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
37365 COMMON/PYINT4/MWID(500),WIDS(500,5)
37366 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
37367 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
37368 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
37369 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
37370 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
37371 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
37372 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
37374 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
37376 C...Differential cross section expressions.
37378 IF(ISUB.LE.160) THEN
37379 IF(ISUB.EQ.141) THEN
37380 C...f + fbar -> gamma*/Z0/Z'0
37381 SQMZP=PMAS(32,1)**2
37383 CALL PYWIDT(32,SH,WDTP,WDTE)
37389 FACZP=4D0*COMFAC*3D0
37390 DO 100 I=MMINA,MMAXA
37391 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
37392 EI=KCHG(IABS(I),1)/3D0
37398 VPI=PARU(123-2*MOD(IABS(I),2))
37399 API=PARU(124-2*MOD(IABS(I),2))
37400 ELSEIF(IA.LE.4) THEN
37401 VPI=PARJ(182-2*MOD(IABS(I),2))
37402 API=PARJ(183-2*MOD(IABS(I),2))
37404 VPI=PARJ(190-2*MOD(IABS(I),2))
37405 API=PARJ(191-2*MOD(IABS(I),2))
37409 VPI=PARU(127-2*MOD(IABS(I),2))
37410 API=PARU(128-2*MOD(IABS(I),2))
37411 ELSEIF(IA.LE.14) THEN
37412 VPI=PARJ(186-2*MOD(IABS(I),2))
37413 API=PARJ(187-2*MOD(IABS(I),2))
37415 VPI=PARJ(194-2*MOD(IABS(I),2))
37416 API=PARJ(195-2*MOD(IABS(I),2))
37420 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
37422 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
37424 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
37429 C...Special case: if only branching ratios known then use them.
37430 IF(MWID(32).EQ.2.AND.MSTP(44).EQ.3) THEN
37433 HI=SHR*WDTP(IA)*FACA/9D0
37434 ELSEIF(IA.LT.20) THEN
37437 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37438 SIGH(NCHN)=HI*FACZP*HF/((SH-SQMZP)**2+HSP**2)
37440 C...Normal cross section.
37441 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
37442 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
37443 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
37444 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
37445 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
37446 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
37447 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
37448 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
37452 ELSEIF(ISUB.EQ.142) THEN
37453 C...f + fbar' -> W'+/-
37454 SQMWP=PMAS(34,1)**2
37455 CALL PYWIDT(34,SH,WDTP,WDTE)
37457 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
37458 HP=AEM/(24D0*XW)*SH
37459 DO 120 I=MMIN1,MMAX1
37460 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
37462 DO 110 J=MMIN2,MMAX2
37463 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
37465 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
37466 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37468 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37469 C...Special case: if only branching ratios known then use them.
37470 IF(MWID(34).EQ.2) THEN
37472 DO 105 IDC=MDCY(34,2),MDCY(34,2)+MDCY(34,3)-1
37473 IF((IA.EQ.IABS(KFDP(IDC,1)).AND.JA.EQ.
37474 & IABS(KFDP(IDC,2))).OR.(IA.EQ.IABS(KFDP(IDC,2))
37475 & .AND.JA.EQ.IABS(KFDP(IDC,1))))
37476 & HI=SHR*WDTP(IDC+1-MDCY(34,2))
37478 IF(IA.LT.10) HI=HI*FACA/9D0
37480 C...Normal cross section.
37481 HI=HP*(PARU(133)**2+PARU(134)**2)
37482 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
37483 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37489 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
37490 SIGH(NCHN)=HI*FACBW*HF
37494 ELSEIF(ISUB.EQ.144) THEN
37497 CALL PYWIDT(41,SH,WDTP,WDTE)
37499 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
37500 HP=AEM/(12D0*XW)*SH
37501 DO 140 I=MMIN1,MMAX1
37502 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
37504 DO 130 J=MMIN2,MMAX2
37505 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
37507 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
37509 IF(IA.LE.10) HI=HI*FACA/3D0
37510 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
37515 SIGH(NCHN)=HI*FACBW*HF
37519 ELSEIF(ISUB.EQ.145) THEN
37520 C...q + l -> LQ (leptoquark)
37521 SQMLQ=PMAS(42,1)**2
37522 CALL PYWIDT(42,SH,WDTP,WDTE)
37524 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
37525 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
37527 KFLQQ=KFDP(MDCY(42,2),1)
37528 KFLQL=KFDP(MDCY(42,2),2)
37529 DO 160 I=MMIN1,MMAX1
37530 IF(KFAC(1,I).EQ.0) GOTO 160
37532 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
37533 DO 150 J=MMIN2,MMAX2
37534 IF(KFAC(2,J).EQ.0) GOTO 150
37536 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
37537 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
37538 IF(JA.EQ.IA) GOTO 150
37539 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
37540 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
37542 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
37547 SIGH(NCHN)=HI*FACBW*HF
37551 ELSEIF(ISUB.EQ.146) THEN
37552 C...e + gamma* -> e* (excited lepton)
37553 KFQSTR=KFPR(ISUB,1)
37554 KCQSTR=PYCOMP(KFQSTR)
37555 KFQEXC=MOD(KFQSTR,KEXCIT)
37556 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
37558 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
37559 QF=-RTCM(43)/2D0-RTCM(44)/2D0
37560 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
37561 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
37564 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
37566 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
37567 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
37569 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37570 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
37573 ISIG(NCHN,3-ISDE)=22
37575 SIGH(NCHN)=HI*FACBW*HF
37579 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
37580 C...d + g -> d* and u + g -> u* (excited quarks)
37581 KFQSTR=KFPR(ISUB,1)
37582 KCQSTR=PYCOMP(KFQSTR)
37583 KFQEXC=MOD(KFQSTR,KEXCIT)
37584 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
37586 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
37587 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
37588 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
37591 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
37593 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
37594 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
37596 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37597 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
37600 ISIG(NCHN,3-ISDE)=21
37602 SIGH(NCHN)=HI*FACBW*HF
37607 ELSEIF(ISUB.LE.190) THEN
37608 IF(ISUB.EQ.162) THEN
37609 C...q + g -> LQ + lbar; LQ=leptoquark
37610 SQMLQ=PMAS(42,1)**2
37611 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
37612 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
37613 KFLQQ=KFDP(MDCY(42,2),1)
37614 DO 220 I=MMINA,MMAXA
37615 IF(IABS(I).NE.KFLQQ) GOTO 220
37618 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
37619 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
37622 ISIG(NCHN,3-ISDE)=21
37624 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
37628 ELSEIF(ISUB.EQ.163) THEN
37629 C...g + g -> LQ + LQbar; LQ=leptoquark
37630 SQMLQ=PMAS(42,1)**2
37631 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
37632 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
37633 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
37634 & ((TH-SQMLQ)*(UH-SQMLQ)))
37635 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
37639 C...Since don't know proper colour flow, randomize between alternatives
37640 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
37644 ELSEIF(ISUB.EQ.164) THEN
37645 C...q + qbar -> LQ + LQbar; LQ=leptoquark
37646 DELTA=0.25D0*(SQM3-SQM4)**2/SH
37647 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
37650 C SQMLQ=PMAS(42,1)**2
37651 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
37652 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
37653 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
37654 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
37655 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
37656 KFLQQ=KFDP(MDCY(42,2),1)
37657 DO 240 I=MMINA,MMAXA
37658 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37659 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
37665 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
37668 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
37669 C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
37670 KFQSTR=KFPR(ISUB,2)
37671 KCQSTR=PYCOMP(KFQSTR)
37672 KFQEXC=MOD(KFQSTR,KEXCIT)
37673 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
37674 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
37675 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
37676 C...Propagators: as simulated in PYOFSH and as desired
37677 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
37678 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
37679 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
37680 GMMQC=SQRT(SQM4)*WDTP(0)
37681 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
37682 FACQSA=FACQSA*HBW4C/HBW4
37683 FACQSB=FACQSB*HBW4C/HBW4
37684 C...Branching ratios.
37685 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
37686 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
37687 DO 260 I=MMIN1,MMAX1
37689 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
37690 DO 250 J=MMIN2,MMAX2
37692 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
37693 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
37698 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
37699 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
37704 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
37705 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
37706 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
37711 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
37712 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
37713 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
37714 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
37719 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
37720 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
37725 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
37726 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
37727 ELSEIF(I.EQ.-J) THEN
37732 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37733 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37738 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37739 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37740 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
37745 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
37746 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
37747 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
37752 ELSEIF(ISUB.EQ.169) THEN
37753 C...q + qbar -> e + e* (excited lepton)
37754 KFQSTR=KFPR(ISUB,2)
37755 KCQSTR=PYCOMP(KFQSTR)
37756 KFQEXC=MOD(KFQSTR,KEXCIT)
37757 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
37758 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
37759 C...Propagators: as simulated in PYOFSH and as desired
37760 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
37761 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
37762 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
37763 GMMQC=SQRT(SQM4)*WDTP(0)
37764 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
37765 FACQSB=FACQSB*HBW4C/HBW4
37766 C...Branching ratios.
37767 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
37768 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
37769 DO 270 I=MMIN1,MMAX1
37771 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
37774 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
37779 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37780 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37785 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37786 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37790 ELSEIF(ISUB.LE.360) THEN
37791 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
37792 C...l + l -> H_L++/-- or H_R++/--.
37794 KFREC=PYCOMP(KFRES)
37795 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37797 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
37798 DO 290 I=MMIN1,MMAX1
37800 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
37802 DO 280 J=MMIN2,MMAX2
37804 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
37806 IF(I*J.LT.0) GOTO 280
37807 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37812 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
37813 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37814 SIGH(NCHN)=HI*FACBW*HF
37818 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
37819 C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
37821 KFREC=PYCOMP(KFRES)
37822 C...Propagators: as simulated in PYOFSH and as desired
37823 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
37824 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
37825 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
37826 GMMC=SQRT(SQM3)*WDTP(0)
37827 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
37828 FHCC=COMFAC*AEM*HBW3C/HBW3
37829 DO 310 I=MMINA,MMAXA
37831 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
37833 J=ISIGN(KFPR(ISUB,2),-I)
37834 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
37835 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
37836 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
37838 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
37839 & (TH-SQM4)*SH)/(TH-SQM4)**2
37840 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
37842 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
37843 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
37844 & ((UH-SQM3)*(TH-SQM4))
37845 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
37846 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
37847 & ((UH-SQM3)*(SH-SQML))
37848 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
37849 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
37850 & ((SH-SQML)*(TH-SQM4))
37851 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
37852 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
37854 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
37855 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
37858 ISIG(NCHN,3-ISDE)=22
37860 SIGH(NCHN)=FHCC*SMM*WIDSC
37864 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
37865 C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
37867 KFREC=PYCOMP(KFRES)
37868 SQMH=PMAS(KFREC,1)**2
37869 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
37870 C...Propagators: H++/-- as simulated in PYOFSH and as desired
37871 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
37872 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
37873 GMMH3=SQRT(SQM3)*WDTP(0)
37874 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
37875 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
37876 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
37877 GMMH4=SQRT(SQM4)*WDTP(0)
37878 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
37879 C...Kinematical and coupling functions
37880 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
37881 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
37882 C...Loop over allowed flavours
37883 DO 320 I=MMINA,MMAXA
37884 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
37885 EI=KCHG(IABS(I),1)/3D0
37886 AI=SIGN(1D0,EI+0.1D0)
37889 IF(IABS(I).LE.10) FCOI=FACA/3D0
37890 IF(ISUB.EQ.349) THEN
37891 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
37892 IF(IABS(I).LT.10) THEN
37893 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37894 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37895 & (VI**2+AI**2)*XWHH**2*HBWZ)
37897 IAOFF=181+3*((IABS(I)-11)/2)
37898 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37900 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37901 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37902 & (VI**2+AI**2)*XWHH**2*HBWZ)+
37903 & 8D0*AEM*(EI*HSUM/(SH*TH)+
37904 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
37908 IF(IABS(I).LT.10) THEN
37909 DSIGHH=8D0*AEM**2*EI**2/SH2
37911 IAOFF=181+3*((IABS(I)-11)/2)
37912 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37914 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
37922 SIGH(NCHN)=FACHH*FCOI*DSIGHH
37925 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
37926 C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
37928 KFREC=PYCOMP(KFRES)
37929 SQMH=PMAS(KFREC,1)**2
37930 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
37931 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
37932 & PMAS(PYCOMP(9900024),1)**2
37933 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
37934 FACPRT=1D0/((VINT(204)**2-VINT(215))*
37935 & (VINT(209)**2-VINT(216)))
37936 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
37937 & (VINT(209)**2+2D0*VINT(218)))
37938 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37940 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
37941 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
37943 DO 340 I=MMIN1,MMAX1
37944 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
37945 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
37946 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
37947 DO 330 J=MMIN2,MMAX2
37948 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
37949 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
37950 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
37952 IF(IABS(KCHH).NE.2) GOTO 330
37953 FACLR=VINT(180+I)*VINT(180+J)
37954 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37955 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
37956 FACPRP=0.5D0*(FACPRT+FACPRU)**2
37964 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
37968 ELSEIF(ISUB.EQ.353) THEN
37969 C...f + fbar -> Z_R0
37970 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37971 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37973 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
37974 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37975 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
37976 DO 350 I=MMINA,MMAXA
37977 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
37978 IF(IABS(I).LE.8) THEN
37979 EI=KCHG(IABS(I),1)/3D0
37980 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
37981 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
37986 HI=HP*(VI**2+AI**2)
37987 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37992 SIGH(NCHN)=HI*FACBW*HF
37995 ELSEIF(ISUB.EQ.354) THEN
37996 C...f + fbar' -> W_R+/-
37997 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37998 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
38000 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
38001 HP=AEM/(24D0*XW)*SH
38002 DO 370 I=MMIN1,MMAX1
38003 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
38005 DO 360 J=MMIN2,MMAX2
38006 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
38008 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
38009 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
38011 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38013 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
38018 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
38019 SIGH(NCHN)=HI*FACBW*HF
38024 ELSEIF(ISUB.LE.400) THEN
38025 IF(ISUB.EQ.391) THEN
38026 C...f + fbar -> G*.
38027 KFGSTR=KFPR(ISUB,1)
38028 KCGSTR=PYCOMP(KFGSTR)
38029 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38031 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38032 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
38033 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38034 C...Modify cross section in wings of peak.
38035 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38036 DO 380 I=MMINA,MMAXA
38037 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
38039 IF(IABS(I).LE.10) HI=HI*FACA/3D0
38047 ELSEIF(ISUB.EQ.392) THEN
38049 KFGSTR=KFPR(ISUB,1)
38050 KCGSTR=PYCOMP(KFGSTR)
38051 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38053 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38054 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
38055 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38056 C...Modify cross section in wings of peak.
38057 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38058 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
38066 ELSEIF(ISUB.EQ.393) THEN
38067 C...q + qbar -> g + G*.
38068 KFGSTR=KFPR(ISUB,2)
38069 KCGSTR=PYCOMP(KFGSTR)
38070 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
38071 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
38072 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
38074 C...Propagators: as simulated in PYOFSH and as desired
38075 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38076 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38077 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38078 HS=SQRT(SQM4)*WDTP(0)
38079 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38080 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38081 FACG=FACG*HBW4C/HBW4
38082 DO 400 I=MMINA,MMAXA
38083 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
38084 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
38092 ELSEIF(ISUB.EQ.394) THEN
38093 C...q + g -> q + G*.
38094 KFGSTR=KFPR(ISUB,2)
38095 KCGSTR=PYCOMP(KFGSTR)
38096 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
38097 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
38098 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
38099 & 2D0*TH2*TH/(UH*SH2))
38100 C...Propagators: as simulated in PYOFSH and as desired
38101 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38102 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38103 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38104 HS=SQRT(SQM4)*WDTP(0)
38105 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38106 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38107 FACG=FACG*HBW4C/HBW4
38108 DO 420 I=MMINA,MMAXA
38109 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
38111 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
38112 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
38115 ISIG(NCHN,3-ISDE)=21
38121 ELSEIF(ISUB.EQ.395) THEN
38122 C...g + g -> g + G*.
38123 KFGSTR=KFPR(ISUB,2)
38124 KCGSTR=PYCOMP(KFGSTR)
38125 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
38126 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
38127 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
38128 C...Propagators: as simulated in PYOFSH and as desired
38129 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38130 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38131 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38132 HS=SQRT(SQM4)*WDTP(0)
38133 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38134 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38135 FACG=FACG*HBW4C/HBW4
38136 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
38149 C*********************************************************************
38152 C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
38153 C...parton distributions according to a few different parametrizations.
38154 C...Note that what is coded is x times the probability distribution,
38155 C...i.e. xq(x,Q2) etc.
38157 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
38159 C...Double precision and integer declarations.
38160 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38161 IMPLICIT INTEGER(I-N)
38162 INTEGER PYK,PYCHGE,PYCOMP
38164 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38165 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38166 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38167 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38168 COMMON/PYINT1/MINT(400),VINT(400)
38169 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38171 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38172 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
38173 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
38174 & XMI(2,240),PT2MI(240),IMISEP(0:240)
38175 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
38178 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
38179 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
38182 C...Interface to PDFLIB.
38183 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
38185 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38186 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38187 CHARACTER*20 PARM(20)
38188 DATA VALUE/20*0D0/,PARM/20*' '/
38190 C...Data related to Schuler-Sjostrand photon distributions.
38191 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
38193 C...Valence PDF momentum integral parametrizations PER PARTON!
38194 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
38195 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
38196 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
38197 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
38199 C...Reset parton distributions.
38208 C...Check x and particle species.
38209 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38210 WRITE(MSTU(11),5000) X
38214 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
38215 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
38216 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
38217 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
38218 &KFA.NE.310.AND.KFA.NE.130) THEN
38219 WRITE(MSTU(11),5100) KF
38223 C...Electron (or muon or tau) parton distribution call.
38224 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
38225 CALL PYPDEL(KFA,X,Q2,XPEL)
38230 C...Photon parton distribution call (VDM+anomalous).
38231 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
38232 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
38233 CALL PYPDGA(X,Q2,XPGA)
38237 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
38240 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
38241 XPVAL(4)=MIN(XPQ(4),XPVU)
38242 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
38248 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
38251 IF(MSTP(55).GE.7) P2MX=4.0D0
38252 IF(MSTP(57).EQ.0) Q2MX=P2MX
38254 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38255 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38258 XPVAL(KFL)=VXPDGM(KFL)
38261 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
38264 IF(MSTP(55).GE.11) P2MX=4.0D0
38265 IF(MSTP(57).EQ.0) Q2MX=P2MX
38267 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38268 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38270 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38271 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38274 ELSEIF(MSTP(56).EQ.2) THEN
38275 C...Call PDFLIB parton distributions.
38279 VALUE(2)=MSTP(55)/1000
38281 VALUE(3)=MOD(MSTP(55),1000)
38282 IF(MINT(93).NE.3000000+MSTP(55)) THEN
38283 CALL PDFSET_ALICE(PARM,VALUE)
38284 MINT(93)=3000000+MSTP(55)
38287 QQ2=MAX(0D0,Q2MIN,Q2)
38288 IF(MSTP(57).EQ.0) QQ2=Q2MIN
38290 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38292 IF(MSTP(55).EQ.5004) THEN
38293 IF(5D0*P2.LT.QQ2.AND.
38294 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
38295 & P2.GE.0D0.AND.P2.LT.10D0.AND.
38296 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
38297 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
38312 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
38340 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
38343 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
38344 XPVAL(4)=MIN(XPQ(4),XPVU)
38345 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
38352 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
38355 C...Pion/gammaVDM parton distribution call.
38356 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
38357 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
38358 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
38359 & MSTP(55).LE.12) THEN
38360 ISET=1+MOD(MSTP(55)-1,4)
38363 IF(ISET.GE.3) P2MX=4.0D0
38364 IF(MSTP(57).EQ.0) Q2MX=P2MX
38366 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38367 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38369 XPQ(KFL)=XPVMD(KFL)
38370 XPVAL(KFL)=VXPVMD(KFL)
38373 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
38374 CALL PYPDPI(X,Q2,XPPI)
38378 XPVAL(2)=XPQ(2)-XPQ(-2)
38379 XPVAL(-1)=XPQ(-1)-XPQ(1)
38380 ELSEIF(MSTP(54).EQ.2) THEN
38381 C...Call PDFLIB parton distributions.
38385 VALUE(2)=MSTP(53)/1000
38387 VALUE(3)=MOD(MSTP(53),1000)
38388 IF(MINT(93).NE.2000000+MSTP(53)) THEN
38389 CALL PDFSET_ALICE(PARM,VALUE)
38390 MINT(93)=2000000+MSTP(53)
38393 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38394 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38396 & (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38414 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
38417 C...Anomalous photon parton distribution call.
38418 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
38421 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
38422 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
38423 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
38424 IF(MSTP(57).EQ.0) Q2MX=P2MX
38426 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38427 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
38429 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
38430 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
38433 ELSEIF(MSTP(56).EQ.1) THEN
38434 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
38435 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
38436 IF(MSTP(57).EQ.0) Q2MX=P2MX
38438 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38439 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
38441 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
38442 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
38445 ELSEIF(MSTP(56).EQ.2) THEN
38446 IF(MSTP(57).EQ.0) Q2MX=P2MX
38447 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
38450 XPVAL(KFL)=VXPGA(KFL)
38453 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
38454 IF(MSTP(57).EQ.0) Q2MX=P2MX
38455 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
38458 XPVAL(KFL)=VXPGA(KFL)
38462 220 RKF=11D0*PYR(0)
38464 IF(RKF.GT.1D0) KFR=2
38465 IF(RKF.GT.5D0) KFR=3
38466 IF(RKF.GT.6D0) KFR=4
38467 IF(RKF.GT.10D0) KFR=5
38468 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
38469 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
38470 IF(MSTP(57).EQ.0) Q2MX=P2MX
38471 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
38474 XPVAL(KFL)=VXPGA(KFL)
38479 C...Proton parton distribution call.
38481 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
38482 CALL PYPDPR(X,Q2,XPPR)
38486 C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
38487 XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1))
38488 XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2))
38489 ELSEIF(MSTP(52).EQ.2) THEN
38490 C...Call PDFLIB parton distributions.
38494 VALUE(2)=MSTP(51)/1000
38496 VALUE(3)=MOD(MSTP(51),1000)
38497 IF(MINT(93).NE.1000000+MSTP(51)) THEN
38498 CALL PDFSET_ALICE(PARM,VALUE)
38499 MINT(93)=1000000+MSTP(51)
38502 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38503 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38504 CALL STRUCTM_ALICE(
38505 & XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38523 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
38527 C...Isospin average for pi0/gammaVDM.
38528 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
38529 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
38534 XPS=0.5D0*(XPQ(1)+XPQ(-2))
38535 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
38539 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
38540 & XPVAL(3)+XPVAL(4)+XPVAL(5)
38544 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
38545 XPQ(1)=XPQ(1)+0.2D0*XPV
38546 XPQ(2)=XPQ(2)+0.8D0*XPV
38547 XPVAL(1)=0.2D0*XPVL
38548 XPVAL(2)=0.8D0*XPVL
38549 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
38552 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
38555 IF(MSTP(55).GE.9) THEN
38561 XPQ(1)=XPQ(1)+0.5D0*XPV
38562 XPQ(2)=XPQ(2)+0.5D0*XPV
38563 XPVAL(1)=0.5D0*XPVL
38564 XPVAL(2)=0.5D0*XPVL
38568 XPVAL(-KFL)=XPVAL(KFL)
38571 C...Rescale for gammaVDM by effective gamma -> rho coupling.
38572 C+++Do not rescale?
38573 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
38574 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
38576 XPQ(KFL)=VINT(281)*XPQ(KFL)
38577 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
38579 VINT(232)=VINT(281)*XPV
38582 C...Simple recipes for kaons.
38583 ELSEIF(KFA.EQ.321) THEN
38584 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
38586 XPVAL(-3)=XPVAL(-1)
38588 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
38589 XPS=0.5D0*(XPQ(1)+XPQ(-2))
38590 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
38593 XPQ(1)=XPQ(1)+0.5D0*XPV
38594 XPQ(-1)=XPQ(-1)+0.5D0*XPV
38595 XPQ(3)=XPQ(3)+0.5D0*XPV
38596 XPQ(-3)=XPQ(-3)+0.5D0*XPV
38597 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
38601 XPVAL(-1)=0.5D0*XPV
38603 XPVAL(-3)=0.5D0*XPV
38605 C...Isospin conjugation for neutron.
38606 ELSEIF(KFA.EQ.2112) THEN
38617 C...Simple recipes for hyperon (average valence parton distribution).
38618 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
38619 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
38620 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
38621 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
38626 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
38627 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
38628 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
38629 XPV=(XPVAL(1)+XPVAL(2))/3D0
38632 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
38633 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
38634 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
38637 C...Charge conjugation for antiparticle.
38640 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
38647 XPVAL(KFL)=XPVAL(-KFL)
38652 C...MULTIPLE INTERACTIONS - PDF RESHAPING.
38655 C...Only reshape PDFs for the non-first interactions;
38656 C...But need valence/sea separation already from first interaction.
38657 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
38658 KFVSEL=KFIVAL(JS,1)
38659 C...If valence quark kicked out of pi0 or gamma then that decides
38660 C...whether we should consider state as d dbar, u ubar, s sbar, etc.
38661 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
38664 XPVL=XPVL+XPVAL(KFL)
38665 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
38668 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
38669 XPVAL(IABS(KFVSEL))=XPVL
38672 XPVAL(-KFL)=XPVAL(KFL)
38675 C...If valence quark kicked out of K0S or K0S then that decides whether
38676 C...we should consider state as d sbar or s dbar.
38677 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
38679 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
38680 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
38681 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
38682 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
38685 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
38686 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
38687 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
38691 C...XPQ distributions are nominal for a (signed) beam particle
38692 C...of KF type, with 1-Sum(x_prev) rescaled to 1.
38700 IF(IFL.EQ.0) GOTO 350
38702 C...Count up number of original IFL valence quarks.
38704 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
38705 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
38706 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
38707 C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
38708 C...bookkeep as if d dbar (for total momentum sum in valence sector).
38709 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
38710 C...Count down number of remaining IFL valence quarks. Skip current
38711 C...interaction initiator.
38713 DO 330 I1=1,NMI(JS)
38714 IF (I1.EQ.MINT(36)) GOTO 330
38715 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
38719 C...Separate out original VALENCE and SEA content.
38721 SEA=MAX(0D0,XPQ(IFL)-VAL)
38725 C...Rescale valence content if changed.
38726 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
38727 & (VAL*IVREM)/IVORG
38729 C...Momentum integrals of original and removed valence quarks.
38730 IF(IVORG.NE.0) THEN
38731 C...For p/n/pbar/nbar beams can split into d_val and u_val.
38732 C...Isospin conjugation for neutrons
38733 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
38735 IF (KFA.EQ.2112) IAFLP=3-IAFLP
38736 VPAVG=PAVG(IAFLP,Q2)
38737 C...For other baryons average d_val and u_val, like for PDFs.
38738 ELSEIF(KFA.GT.1000) THEN
38739 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
38740 C...For mesons and photon average d_val and u_val and scale by 3/2.
38741 C...Very crude, especially for photon.
38743 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
38745 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
38746 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
38749 C...Now add companions (at X with partner having been at Z=XASSOC).
38750 C...NOTE: due to the assumed simple x scaling, the partner was at what
38751 C...corresponds to a higher Z than XASSOC, if there were intermediate
38752 C...scatterings. Nothing done about that for the moment.
38753 DO 340 IVC=1,NVC(JS,IFL)
38754 C...Skip companions that have been kicked out
38755 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
38759 C...Momentum fraction of the partner quark.
38760 C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
38761 XS=XASSOC(JS,IFL,IVC)
38764 C...Momentum fraction of the companion quark.
38765 C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
38767 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
38768 C...Add to momentum sum, with rescaling compensation factor.
38769 XCFAC=(XREM+XS)/XREM*CMPFAC
38770 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
38775 C...Wait until all flavours treated, then rescale seas and gluon.
38778 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
38779 IF (RSFAC.LE.0D0) THEN
38780 C...First calculate factor needed to exactly restore pz cons.
38781 IF (NRESC.EQ.1) CMPFAC =
38782 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
38783 C...Add a bit of headroom
38785 C...Try a few times if more headroom is needed, then print error message.
38786 IF (NRESC.LE.10) GOTO 345
38788 & '(PYPDFU:) Negative reshaping factor persists!')
38789 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
38793 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
38794 C...Also store resulting distributions in XPQ
38796 DO 360 ISVC=-1,NVC(JS,IFL)
38797 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
38800 C...Save companion reweighting factor for PYPTIS.
38805 C...Allow gluon also in position 21.
38808 C...Check positivity and reset above maximum allowed flavour.
38810 XPQ(KFL)=MAX(0D0,XPQ(KFL))
38811 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
38814 C...Formats for error printouts.
38815 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
38816 5100 FORMAT(' Error: illegal particle code for parton distribution;',
38818 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
38820 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
38821 & ' Removed valence momentum fraction : ',F6.3/
38822 & ' Added companion momentum fraction : ',F6.3/
38823 & ' Resulting rescale factor : ',F6.3)
38825 C...Reset side pointer and return
38831 C*********************************************************************
38834 C...Gives proton parton distribution at small x and/or Q^2 according to
38835 C...correct limiting behaviour.
38837 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
38839 C...Double precision and integer declarations.
38840 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38841 IMPLICIT INTEGER(I-N)
38842 INTEGER PYK,PYCHGE,PYCOMP
38844 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38845 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38846 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38847 COMMON/PYINT1/MINT(400),VINT(400)
38848 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
38850 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
38851 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
38853 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
38857 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
38858 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
38859 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
38861 CALL PYPDFU(KF,X,Q2,XPQ)
38865 C...Reset. Check x.
38869 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38870 WRITE(MSTU(11),5000) X
38874 C...Define valence content.
38878 IF(KF.EQ.2212) THEN
38881 ELSEIF(KF.EQ.-2212) THEN
38884 ELSEIF(KF.EQ.2112) THEN
38887 ELSEIF(KF.EQ.-2112) THEN
38890 ELSEIF(KF.EQ.211) THEN
38894 ELSEIF(KF.EQ.-211) THEN
38898 ELSEIF(MINT(105).LE.223) THEN
38903 ELSEIF(MINT(105).EQ.333) THEN
38908 ELSEIF(MINT(105).EQ.443) THEN
38915 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
38917 CALL PYPDFU(KFC,X,Q2,XPA)
38918 Q2MN=MAX(3D0,VINT(231))
38919 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
38920 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
38922 C...Large Q2 and large x: naive call is enough.
38923 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
38929 C...Small Q2 and large x: dampen boundary value.
38930 ELSEIF(X.GT.XMN) THEN
38932 C...Evaluate at boundary and define dampening factors.
38934 CALL PYPDFU(KFC,X,Q2MN,XPA)
38935 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
38936 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
38938 C...Separate valence and sea parts of parton distribution.
38940 XFV1=XPA(KFV1)-XPA(-KFV1)
38941 XPA(KFV1)=XPA(-KFV1)
38942 XFV2=XPA(KFV2)-XPA(-KFV2)
38943 XPA(KFV2)=XPA(-KFV2)
38945 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38946 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38947 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38948 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38951 C...Dampen valence and sea separately. Put back together.
38953 XPQ(KFL)=FS*XPA(KFL)
38956 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
38957 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
38959 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
38960 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
38961 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
38962 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
38966 C...Large Q2 and small x: interpolate behaviour.
38967 ELSEIF(Q2.GT.Q2MN) THEN
38969 C...Evaluate at extremes and define coefficients for interpolation.
38971 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38974 CALL PYPDFU(KFC,X,Q2B,XPB)
38976 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
38977 FVA=(X/XMN)**0.45D0*FLA
38978 FSA=(X/XMN)**(-0.08D0)*FLA
38981 C...Separate valence and sea parts of parton distribution.
38983 XFVA1=XPA(KFV1)-XPA(-KFV1)
38984 XPA(KFV1)=XPA(-KFV1)
38985 XFVA2=XPA(KFV2)-XPA(-KFV2)
38986 XPA(KFV2)=XPA(-KFV2)
38987 XFVB1=XPB(KFV1)-XPB(-KFV1)
38988 XPB(KFV1)=XPB(-KFV1)
38989 XFVB2=XPB(KFV2)-XPB(-KFV2)
38990 XPB(KFV2)=XPB(-KFV2)
38992 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
38993 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
38994 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
38995 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
38996 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
38997 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
38998 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
38999 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
39002 C...Interpolate for valence and sea. Put back together.
39004 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
39007 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
39008 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
39010 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39011 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39012 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39013 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39017 C...Small Q2 and small x: dampen boundary value and add term.
39020 C...Evaluate at boundary and define dampening factors.
39022 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
39023 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
39025 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
39026 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
39027 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
39028 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
39029 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
39030 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
39032 C...Separate valence and sea parts of parton distribution.
39034 XFV1=XPA(KFV1)-XPA(-KFV1)
39035 XPA(KFV1)=XPA(-KFV1)
39036 XFV2=XPA(KFV2)-XPA(-KFV2)
39037 XPA(KFV2)=XPA(-KFV2)
39039 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
39040 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
39041 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
39042 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
39045 C...Dampen valence and sea separately. Add constant terms.
39046 C...Put back together.
39048 XPQ(KFL)=FSA*XPA(KFL)
39052 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
39054 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
39055 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
39058 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
39060 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39061 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39062 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39063 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39069 C...Format for error printout.
39070 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
39075 C*********************************************************************
39078 C...Gives electron (or muon, or tau) parton distribution.
39080 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
39082 C...Double precision and integer declarations.
39083 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39084 IMPLICIT INTEGER(I-N)
39085 INTEGER PYK,PYCHGE,PYCOMP
39087 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39088 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39089 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39090 COMMON/PYINT1/MINT(400),VINT(400)
39091 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39093 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
39095 C...Interface to PDFLIB.
39096 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
39098 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
39099 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
39100 CHARACTER*20 PARM(20)
39101 DATA VALUE/20*0D0/,PARM/20*' '/
39103 C...Some common constants.
39109 IF(KFA.EQ.13) PME=PMAS(13,1)
39110 IF(KFA.EQ.15) PME=PMAS(15,1)
39111 XL=LOG(MAX(1D-10,X))
39112 X1L=LOG(MAX(1D-10,1D0-X))
39113 HLE=LOG(MAX(3D0,Q2/PME**2))
39114 HBE2=(AEM/PARU(1))*(HLE-1D0)
39116 C...Electron inside electron, see R. Kleiss et al., in Z physics at
39117 C...LEP 1, CERN 89-08, p. 34
39118 IF(MSTP(59).LE.1) THEN
39119 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
39120 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
39121 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
39122 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
39123 & 4D0*XL/(1D0-X)-5D0-X)
39125 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
39126 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
39127 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
39129 C...Zero distribution for very large x and rescale it for intermediate.
39130 IF(X.GT.1D0-1D-10) THEN
39132 ELSEIF(X.GT.1D0-1D-7) THEN
39133 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
39137 C...Photon and (transverse) W- inside electron.
39138 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
39139 IF(MSTP(13).LE.1) THEN
39142 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
39144 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
39145 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
39146 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
39148 C...Electron or positron inside photon inside electron.
39149 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
39150 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
39151 & 2D0*X*(1D0+X)*XL)
39152 XPEL(11)=XPEL(11)+XFSEA
39155 C...Initialize PDFLIB photon parton distributions.
39156 IF(MSTP(56).EQ.2) THEN
39160 VALUE(2)=MSTP(55)/1000
39162 VALUE(3)=MOD(MSTP(55),1000)
39163 IF(MINT(93).NE.3000000+MSTP(55)) THEN
39164 CALL PDFSET_ALICE(PARM,VALUE)
39165 MINT(93)=3000000+MSTP(55)
39169 C...Quarks and gluons inside photon inside electron:
39170 C...numerical convolution required.
39179 IF(ITER.EQ.0) NSTP=2
39181 SXP(KFL)=0.5D0*SXP(KFL)
39184 IF(ITER.EQ.0) WTSTP=0.5D0
39185 C...Pick grid of x_{gamma} values logarithmically even.
39190 XLE=XL*(ISTP-0.5D0)/NSTP
39192 XE=MIN(1D0-1D-10,EXP(XLE))
39193 XG=MIN(1D0-1D-10,X/XE)
39194 C...Evaluate photon inside electron parton distribution for convolution.
39195 XPGP=1D0+(1D0-XE)**2
39196 IF(MSTP(13).LE.1) THEN
39199 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
39201 C...Evaluate photon parton distributions for convolution.
39202 IF(MSTP(56).EQ.1) THEN
39203 IF(MSTP(55).EQ.1) THEN
39204 CALL PYPDGA(XG,Q2,XPGA)
39205 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
39208 IF(MSTP(55).GE.7) P2MX=4.0D0
39209 IF(MSTP(57).EQ.0) Q2MX=P2MX
39211 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39212 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39214 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
39217 IF(MSTP(55).GE.11) P2MX=4.0D0
39218 IF(MSTP(57).EQ.0) Q2MX=P2MX
39220 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39221 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39225 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
39227 ELSEIF(MSTP(56).EQ.2) THEN
39228 C...Call PDFLIB parton distributions.
39230 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39231 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39233 & (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
39234 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
39235 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
39236 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
39237 SXP(3)=SXP(3)+WTSTP*XPGP*STR
39238 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
39239 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
39240 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
39243 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
39244 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
39245 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
39247 C...Put convolution into output arrays.
39249 XPEL(0)=FCONV*SXP(0)
39251 XPEL(KFL)=FCONV*SXP(KFL)
39252 XPEL(-KFL)=XPEL(KFL)
39259 C*********************************************************************
39262 C...Gives photon parton distribution.
39264 SUBROUTINE PYPDGA(X,Q2,XPGA)
39266 C...Double precision and integer declarations.
39267 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39268 IMPLICIT INTEGER(I-N)
39269 INTEGER PYK,PYCHGE,PYCOMP
39271 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39272 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39273 COMMON/PYINT1/MINT(400),VINT(400)
39274 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
39276 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
39277 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
39278 &DGCS(4,3),DGDS(4,3),DGES(4,3)
39280 C...The following data lines are coefficients needed in the
39281 C...Drees and Grassie photon parton distribution parametrization.
39282 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
39283 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
39284 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
39285 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
39286 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
39287 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
39288 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
39289 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
39290 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
39291 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
39292 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
39293 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
39294 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
39295 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
39296 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
39297 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
39298 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
39299 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
39300 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
39301 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
39302 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
39303 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
39304 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
39305 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
39306 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
39307 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
39309 C...Photon parton distribution from Drees and Grassie.
39310 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
39315 IF(MSTP(57).LE.0) THEN
39318 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
39322 IF(Q2.GT.25D0) NF=4
39323 IF(Q2.GT.300D0) NF=5
39327 C...Evaluate gluon content.
39328 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
39329 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
39330 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
39331 XPGL=DGA*X**DGB*X1**DGC
39333 C...Evaluate up- and down-type quark content.
39334 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
39335 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
39336 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
39337 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
39338 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
39339 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
39340 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
39341 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
39342 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
39343 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
39344 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
39346 IF(NF.EQ.4) DGF=10D0
39347 IF(NF.EQ.5) DGF=55D0/6D0
39348 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
39350 XPQU=(XPQS+9D0*XPQN)/6D0
39351 XPQD=(XPQS-4.5D0*XPQN)/6D0
39352 ELSEIF(NF.EQ.4) THEN
39353 XPQU=(XPQS+6D0*XPQN)/8D0
39354 XPQD=(XPQS-6D0*XPQN)/8D0
39356 XPQU=(XPQS+7.5D0*XPQN)/10D0
39357 XPQD=(XPQS-5D0*XPQN)/10D0
39360 C...Put into output arrays.
39365 IF(NF.GE.4) XPGA(4)=AEM*XPQU
39366 IF(NF.GE.5) XPGA(5)=AEM*XPQD
39368 XPGA(-KFL)=XPGA(KFL)
39374 C*********************************************************************
39377 C...Constructs the F2 and parton distributions of the photon
39378 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
39379 C...For F2, c and b are included by the Bethe-Heitler formula;
39380 C...in the 'MSbar' scheme additionally a Cgamma term is added.
39381 C...Contains the SaS sets 1D, 1M, 2D and 2M.
39382 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39384 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
39386 C...Double precision and integer declarations.
39387 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39388 IMPLICIT INTEGER(I-N)
39389 INTEGER PYK,PYCHGE,PYCOMP
39391 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
39393 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
39394 SAVE /PYINT8/,/PYINT9/
39396 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
39397 C...Charm and bottom masses (low to compensate for J/psi etc.).
39398 DATA PMC/1.3D0/, PMB/4.6D0/
39399 C...alpha_em and alpha_em/(2*pi).
39400 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
39401 C...Lambda value for 4 flavours.
39403 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
39405 C...VMD couplings f_V**2/(4*pi).
39406 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
39407 C...Masses for rho (=omega) and phi.
39408 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
39409 C...Number of points in integration for IP2=1.
39427 C...Set Q0 cut-off parameter as function of set used.
39435 C...Scale choice for off-shell photon; common factors.
39440 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
39441 FACNOR=LOG(Q2/Q02)/NSTEP
39442 ELSEIF(IP2.EQ.2) THEN
39444 ELSEIF(IP2.EQ.3) THEN
39446 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
39447 ELSEIF(IP2.EQ.4) THEN
39448 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39449 & ((Q2+P2)*(Q02+P2)))
39450 ELSEIF(IP2.EQ.5) THEN
39451 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39452 & ((Q2+P2)*(Q02+P2)))
39453 P2MX=Q0*SQRT(P2MXA)
39454 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
39455 ELSEIF(IP2.EQ.6) THEN
39456 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39457 & ((Q2+P2)*(Q02+P2)))
39458 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
39460 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39461 & ((Q2+P2)*(Q02+P2)))
39462 P2MX=Q0*SQRT(P2MXA)
39464 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
39465 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
39466 IF(ABS(Q2-Q02).GT.1D-6) THEN
39467 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
39468 ELSEIF(P2.LT.Q02) THEN
39469 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
39475 C...Call VMD parametrization for d quark and use to give rho, omega,
39476 C...phi. Note dipole dampening for off-shell photon.
39477 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39481 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
39482 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
39484 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
39486 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
39487 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
39488 XPVMD(3)=XPVMD(3)+FACS*XFVAL
39489 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
39490 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
39491 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
39492 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
39493 VXPVMD(2)=FRACU*FACUD*XFVAL
39494 VXPVMD(3)=FACS*XFVAL
39495 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
39496 VXPVMD(-2)=FRACU*FACUD*XFVAL
39497 VXPVMD(-3)=FACS*XFVAL
39500 C...Anomalous parametrizations for different strategies
39501 C...for off-shell photons; except full integration.
39503 C...Call anomalous parametrization for d + u + s.
39504 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39506 XPANL(KFL)=FACNOR*XPGA(KFL)
39507 VXPANL(KFL)=FACNOR*VXPGA(KFL)
39510 C...Call anomalous parametrization for c and b.
39511 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39513 XPANH(KFL)=FACNOR*XPGA(KFL)
39514 VXPANH(KFL)=FACNOR*VXPGA(KFL)
39516 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39518 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
39519 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
39523 C...Special option: loop over flavours and integrate over k2.
39525 DO 160 ISTEP=1,NSTEP
39526 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
39527 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
39528 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
39529 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
39530 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
39531 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
39532 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
39534 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
39535 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
39536 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
39537 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
39543 C...Call Bethe-Heitler term expression for charm and bottom.
39544 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
39547 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
39551 C...For MSbar subtraction call C^gamma term expression for d, u, s.
39552 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
39553 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
39555 XPDIR(KFL)=XPGA(KFL)
39559 C...Store result in output array.
39562 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
39563 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
39564 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
39565 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
39566 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
39572 C*********************************************************************
39575 C...Evaluates the VMD parton distributions of a photon,
39576 C...evolved homogeneously from an initial scale P2 to Q2.
39577 C...Does not include dipole suppression factor.
39578 C...ISET is parton distribution set, see above;
39579 C...additionally ISET=0 is used for the evolution of an anomalous photon
39580 C...which branched at a scale P2 and then evolved homogeneously to Q2.
39581 C...ALAM is the 4-flavour Lambda, which is automatically converted
39582 C...to 3- and 5-flavour equivalents as needed.
39583 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39585 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39587 C...Double precision and integer declarations.
39588 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39589 IMPLICIT INTEGER(I-N)
39590 INTEGER PYK,PYCHGE,PYCOMP
39591 C...Local arrays and data.
39592 DIMENSION XPGA(-6:6), VXPGA(-6:6)
39593 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
39602 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39603 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
39604 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
39605 P2EFF=MAX(P2,1.2D0*ALAM3**2)
39606 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
39607 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
39608 Q2EFF=MAX(Q2,P2EFF)
39610 C...Find number of flavours at lower and upper scale.
39612 IF(P2EFF.LT.PMC**2) NFP=3
39613 IF(P2EFF.GT.PMB**2) NFP=5
39615 IF(Q2EFF.LT.PMC**2) NFQ=3
39616 IF(Q2EFF.GT.PMB**2) NFQ=5
39618 C...Find s as sum of 3-, 4- and 5-flavour parts.
39622 IF(NFQ.EQ.3) Q2DIV=Q2EFF
39623 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
39625 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
39627 IF(NFP.EQ.3) P2DIV=PMC**2
39629 IF(NFQ.EQ.5) Q2DIV=PMB**2
39630 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
39634 IF(NFP.EQ.5) P2DIV=P2EFF
39635 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
39638 C...Calculate frequent combinations of x and s.
39645 C...Evaluate homogeneous anomalous parton distributions below or
39646 C...above threshold.
39648 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39649 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39650 XVAL = X * 1.5D0 * (X**2+X1**2)
39654 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
39655 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
39656 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
39657 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
39658 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
39659 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
39660 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
39661 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
39662 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
39663 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
39664 & (2D0*X-1D0)*X*XL**2)
39667 C...Evaluate set 1D parton distributions below or above threshold.
39668 ELSEIF(ISET.EQ.1) THEN
39669 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39670 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39671 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
39672 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
39673 XSEA = 0.100D0 * X1**3.76D0
39675 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
39676 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
39677 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
39678 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
39679 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
39680 & X**0.40D0 * X1**(1.76D0+3D0*S)
39681 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
39682 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
39683 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
39684 XSEA0 = 0.100D0 * X1**3.76D0
39687 C...Evaluate set 1M parton distributions below or above threshold.
39688 ELSEIF(ISET.EQ.2) THEN
39689 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39690 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39691 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
39692 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
39695 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
39696 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
39697 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
39698 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
39699 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
39700 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
39701 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
39702 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
39707 C...Evaluate set 2D parton distributions below or above threshold.
39708 ELSEIF(ISET.EQ.3) THEN
39709 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39710 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39711 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
39712 XGLU = 1.925D0 * X1**2
39713 XSEA = 0.242D0 * X1**4
39715 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
39716 & X**(0.46D0+0.25D0*S) *
39717 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
39718 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
39719 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
39720 & EXP(-18.67D0*S) *
39721 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
39722 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
39723 & XL**(9.3D0*S/(1D0+1.7D0*S))
39724 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
39725 & (1D0-0.607D0*S+21.95D0*S2) *
39726 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
39727 XSEA0 = 0.242D0 * X1**4
39730 C...Evaluate set 2M parton distributions below or above threshold.
39731 ELSEIF(ISET.EQ.4) THEN
39732 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39733 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39734 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
39735 XGLU = 1.808D0 * X1**2
39736 XSEA = 0.209D0 * X1**4
39738 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
39739 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
39740 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
39741 & XL**(5.15D0*S/(1D0+2D0*S)) +
39742 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
39743 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
39744 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
39745 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
39746 & XL**(10.9D0*S/(1D0+2.5D0*S))
39747 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
39748 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
39749 & X1**(4D0+S) * XL**(0.45D0*S)
39750 XSEA0 = 0.209D0 * X1**4
39754 C...Threshold factors for c and b sea.
39755 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39757 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39758 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39760 XCHM=XSEA*(1D0-(SCH/SLL)**2)
39762 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
39766 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39767 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39769 XBOT=XSEA*(1D0-(SBT/SLL)**2)
39771 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
39775 C...Fill parton distributions.
39782 XPGA(KFA)=XPGA(KFA)+XVAL
39784 XPGA(-KFL)=XPGA(KFL)
39792 C*********************************************************************
39795 C...Evaluates the parton distributions of the anomalous photon,
39796 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
39797 C...KF=0 gives the sum over (up to) 5 flavours,
39798 C...KF<0 limits to flavours up to abs(KF),
39799 C...KF>0 is for flavour KF only.
39800 C...ALAM is the 4-flavour Lambda, which is automatically converted
39801 C...to 3- and 5-flavour equivalents as needed.
39802 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39804 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39806 C...Double precision and integer declarations.
39807 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39808 IMPLICIT INTEGER(I-N)
39809 INTEGER PYK,PYCHGE,PYCOMP
39810 C...Local arrays and data.
39811 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
39812 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
39819 IF(Q2.LE.P2) RETURN
39822 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39823 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
39825 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
39826 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
39827 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
39828 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
39829 Q2EFF=MAX(Q2,P2EFF)
39832 C...Find number of flavours at lower and upper scale.
39834 IF(P2EFF.LT.PMC**2) NFP=3
39835 IF(P2EFF.GT.PMB**2) NFP=5
39837 IF(Q2EFF.LT.PMC**2) NFQ=3
39838 IF(Q2EFF.GT.PMB**2) NFQ=5
39840 C...Define range of flavour loop.
39844 ELSEIF(KF.LT.0) THEN
39852 C...Loop over flavours the photon can branch into.
39853 DO 110 KFL=KFLMN,KFLMX
39855 C...Light flavours: calculate t range and (approximate) s range.
39856 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
39857 TDIFF=LOG(Q2EFF/P2EFF)
39858 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39859 & LOG(P2EFF/ALAMSQ(NFQ)))
39860 IF(NFQ.GT.NFP) THEN
39862 IF(NFQ.EQ.4) Q2DIV=PMC**2
39863 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
39864 & LOG(P2EFF/ALAMSQ(NFQ)))
39865 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
39866 & LOG(P2EFF/ALAMSQ(NFQ-1)))
39867 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
39869 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
39871 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
39872 & LOG(P2EFF/ALAMSQ(4)))
39873 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
39874 & LOG(P2EFF/ALAMSQ(3)))
39875 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
39878 C...u and s quark do not need a separate treatment when d has been done.
39879 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
39881 C...Charm: as above, but only include range above c threshold.
39882 ELSEIF(KFL.EQ.4) THEN
39883 IF(Q2.LE.PMC**2) GOTO 110
39884 P2EFF=MAX(P2EFF,PMC**2)
39885 Q2EFF=MAX(Q2EFF,P2EFF)
39886 TDIFF=LOG(Q2EFF/P2EFF)
39887 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39888 & LOG(P2EFF/ALAMSQ(NFQ)))
39889 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
39891 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
39892 & LOG(P2EFF/ALAMSQ(NFQ)))
39893 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
39894 & LOG(P2EFF/ALAMSQ(NFQ-1)))
39895 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
39898 C...Bottom: as above, but only include range above b threshold.
39899 ELSEIF(KFL.EQ.5) THEN
39900 IF(Q2.LE.PMB**2) GOTO 110
39901 P2EFF=MAX(P2EFF,PMB**2)
39902 Q2EFF=MAX(Q2,P2EFF)
39903 TDIFF=LOG(Q2EFF/P2EFF)
39904 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39905 & LOG(P2EFF/ALAMSQ(NFQ)))
39908 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
39910 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
39911 FAC=AEM2PI*2D0*CHSQ*TDIFF
39913 C...Evaluate parton distributions (normalized to unit momentum sum).
39914 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
39915 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
39916 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
39917 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
39918 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
39919 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
39920 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
39921 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
39922 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
39923 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
39924 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
39925 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
39927 C...Threshold factors for c and b sea.
39928 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39930 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39931 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39932 XCHM=XSEA*(1D0-(SCH/SLL)**3)
39935 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39936 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39937 XBOT=XSEA*(1D0-(SBT/SLL)**3)
39941 C...Add contribution of each valence flavour.
39942 XPGA(0)=XPGA(0)+FAC*XGLU
39943 XPGA(1)=XPGA(1)+FAC*XSEA
39944 XPGA(2)=XPGA(2)+FAC*XSEA
39945 XPGA(3)=XPGA(3)+FAC*XSEA
39946 XPGA(4)=XPGA(4)+FAC*XCHM
39947 XPGA(5)=XPGA(5)+FAC*XBOT
39948 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
39949 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
39952 XPGA(-KFL)=XPGA(KFL)
39953 VXPGA(-KFL)=VXPGA(KFL)
39960 C*********************************************************************
39963 C...Evaluates the Bethe-Heitler cross section for heavy flavour
39965 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39967 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
39969 C...Double precision and integer declarations.
39970 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39971 IMPLICIT INTEGER(I-N)
39972 INTEGER PYK,PYCHGE,PYCOMP
39975 DATA AEM2PI/0.0011614D0/
39981 C...Check kinematics limits.
39982 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
39984 BETA2=1D0-4D0*PM2/W2
39985 IF(BETA2.LT.1D-10) RETURN
39989 C...Simple case: P2 = 0.
39990 IF(P2.LT.1D-4) THEN
39991 IF(BETA.LT.0.99D0) THEN
39992 XBL=LOG((1D0+BETA)/(1D0-BETA))
39994 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
39996 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
39997 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
39999 C...Complicated case: P2 > 0, based on approximation of
40000 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
40002 RPQ=1D0-4D0*X**2*P2/Q2
40003 IF(RPQ.GT.1D-10) THEN
40004 RPBE=SQRT(RPQ*BETA2)
40005 IF(RPBE.LT.0.99D0) THEN
40006 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
40007 XBI=2D0*RPBE/(1D0-RPBE**2)
40009 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
40010 XBL=LOG((1D0+RPBE)**2/RPBESN)
40011 XBI=2D0*RPBE/RPBESN
40013 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
40014 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
40015 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
40019 C...Multiply by charge-squared etc. to get parton distribution.
40021 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
40022 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
40027 C*********************************************************************
40030 C...Evaluates the direct contribution, i.e. the C^gamma term,
40031 C...as needed in MSbar parametrizations.
40032 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40034 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
40036 C...Double precision and integer declarations.
40037 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40038 IMPLICIT INTEGER(I-N)
40039 INTEGER PYK,PYCHGE,PYCOMP
40040 C...Local array and data.
40041 DIMENSION XPGA(-6:6)
40042 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
40049 C...Evaluate common x-dependent expression.
40050 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
40051 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
40053 C...d, u, s part by simple charge factor.
40054 XPGA(1)=(1D0/9D0)*CGAM
40055 XPGA(2)=(4D0/9D0)*CGAM
40056 XPGA(3)=(1D0/9D0)*CGAM
40058 C...Also fill for antiquarks.
40066 C*********************************************************************
40069 C...Gives pi+ parton distribution according to two different
40070 C...parametrizations.
40072 SUBROUTINE PYPDPI(X,Q2,XPPI)
40074 C...Double precision and integer declarations.
40075 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40076 IMPLICIT INTEGER(I-N)
40077 INTEGER PYK,PYCHGE,PYCOMP
40079 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40080 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40081 COMMON/PYINT1/MINT(400),VINT(400)
40082 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40084 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
40086 C...The following data lines are coefficients needed in the
40087 C...Owens pion parton distribution parametrizations, see below.
40088 C...Expansion coefficients for up and down valence quark distributions.
40089 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
40090 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40091 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40092 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40093 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
40094 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40095 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40096 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40097 C...Expansion coefficients for gluon distribution.
40098 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
40099 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
40100 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
40101 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
40102 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
40103 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
40104 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
40105 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
40106 C...Expansion coefficients for (up+down+strange) quark sea distribution.
40107 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
40108 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40109 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
40110 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
40111 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
40112 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40113 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
40114 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
40115 C...Expansion coefficients for charm quark sea distribution.
40116 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
40117 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
40118 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
40119 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
40120 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
40121 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
40122 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
40123 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
40125 C...Euler's beta function, requires ordinary Gamma function
40126 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
40128 C...Reset output array.
40133 IF(MSTP(53).LE.2) THEN
40134 C...Pion parton distributions from Owens.
40135 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
40137 C...Determine set, Lambda and s expansion variable.
40139 IF(NSET.EQ.1) ALAM=0.2D0
40140 IF(NSET.EQ.2) ALAM=0.4D0
40142 IF(MSTP(57).LE.0) THEN
40145 Q2IN=MIN(2D3,MAX(4D0,Q2))
40146 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
40149 C...Calculate parton distributions.
40152 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
40153 & COW(3,IS,KFL,NSET)*SD**2
40156 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
40158 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
40163 C...Put into output array.
40166 XPPI(2)=XQ(1)+XQ(3)/6D0
40169 XPPI(-1)=XQ(1)+XQ(3)/6D0
40174 C...Leading order pion parton distributions from Glueck, Reya and Vogt.
40175 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40179 C...Determine s expansion variable and some x expressions.
40181 IF(MSTP(57).LE.0) THEN
40184 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
40185 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
40191 C...Evaluate valence, gluon and sea distributions.
40192 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
40193 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
40194 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
40196 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
40197 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
40199 & (1D0-X)**(0.390D0+1.053D0*SD)
40200 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
40202 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
40204 & XL**(2.538D0-0.763D0*SD)
40205 IF(SD.LE.0.888D0) THEN
40208 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
40210 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
40213 IF(SD.LE.1.351D0) THEN
40216 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
40217 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
40221 C...Put into output array.
40229 XPPI(-KFL)=XPPI(KFL)
40231 XPPI(2)=XPPI(2)+XFVAL
40232 XPPI(-1)=XPPI(-1)+XFVAL
40238 C*********************************************************************
40241 C...Gives proton parton distributions according to a few different
40242 C...parametrizations.
40244 SUBROUTINE PYPDPR(X,Q2,XPPR)
40246 C...Double precision and integer declarations.
40247 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40248 IMPLICIT INTEGER(I-N)
40249 INTEGER PYK,PYCHGE,PYCOMP
40251 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40252 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40253 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40254 COMMON/PYINT1/MINT(400),VINT(400)
40255 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
40256 C...Arrays and data.
40257 DIMENSION XPPR(-6:6),Q2MIN(16)
40258 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
40259 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
40261 C...Reset output array.
40266 C...Common preliminaries.
40267 NSET=MAX(1,MIN(16,MSTP(51)))
40268 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
40269 VINT(231)=Q2MIN(NSET)
40270 IF(MSTP(57).EQ.0) THEN
40273 Q2L=MAX(Q2MIN(NSET),Q2)
40276 IF(NSET.GE.1.AND.NSET.LE.3) THEN
40277 C...Interface to the CTEQ 3 parton distributions.
40278 QRT=SQRT(MAX(1D0,Q2L))
40280 C...Loop over flavours.
40283 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
40284 ELSEIF(I.LE.2) THEN
40285 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
40291 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
40292 C...Interface to the GRV 94 distributions.
40294 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40295 ELSEIF(NSET.EQ.5) THEN
40296 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40298 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40301 C...Put into output array.
40303 XPPR(-1)=0.5D0*(UDB+DEL)
40304 XPPR(-2)=0.5D0*(UDB-DEL)
40308 XPPR(1)=DV+XPPR(-1)
40309 XPPR(2)=UV+XPPR(-2)
40314 ELSEIF(NSET.EQ.7) THEN
40315 C...Interface to the CTEQ 5L parton distributions.
40316 C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
40317 C...freezing x*f(x,Q2) at borders.
40318 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
40319 XIN=MAX(1D-6,MIN(1D0,X))
40321 C...Loop over flavours (with u <-> d notation mismatch).
40322 SUMUDB=PYCT5L(-1,XIN,QRT)
40323 RATUDB=PYCT5L(-2,XIN,QRT)
40326 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
40327 ELSEIF(I.EQ.2) THEN
40328 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
40329 ELSEIF(I.EQ.-1) THEN
40330 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
40331 ELSEIF(I.EQ.-2) THEN
40332 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
40334 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
40335 IF(I.LT.0) XPPR(-I)=XPPR(I)
40339 ELSEIF(NSET.EQ.8) THEN
40340 C...Interface to the CTEQ 5M1 parton distributions.
40341 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
40342 XIN=MAX(1D-6,MIN(1D0,X))
40344 C...Loop over flavours (with u <-> d notation mismatch).
40345 SUMUDB=PYCT5M(-1,XIN,QRT)
40346 RATUDB=PYCT5M(-2,XIN,QRT)
40349 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
40350 ELSEIF(I.EQ.2) THEN
40351 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
40352 ELSEIF(I.EQ.-1) THEN
40353 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
40354 ELSEIF(I.EQ.-2) THEN
40355 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
40357 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
40358 IF(I.LT.0) XPPR(-I)=XPPR(I)
40362 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
40363 C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
40364 C...obsolete but offers backwards compatibility.
40365 CALL PYPDPO(X,Q2L,XPPR)
40367 C...Symmetric choice for debugging only
40368 ELSEIF(NSET.EQ.16) THEN
40386 C*********************************************************************
40389 C...Gives the CTEQ 3 parton distribution function sets in
40390 C...parametrized form, of October 24, 1994.
40391 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
40392 C...J. Qiu, W.K. Tung and H. Weerts.
40394 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
40396 C...Double precision declaration.
40397 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40398 IMPLICIT INTEGER(I-N)
40400 C...Data on Lambda values of fits, minimum Q and quark masses.
40401 DIMENSION ALM(3), QMS(4:6)
40402 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
40403 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
40405 C....Check flavour thresholds. Set up QI for SB.
40408 IF(Q .LE. QMS(IP)) THEN
40417 C...Use "standard lambda" of parametrization program for expansion.
40419 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
40424 C...Expansion for CTEQ3L.
40425 IF(ISET .EQ. 1) THEN
40426 IF(IPRT .EQ. 2) THEN
40427 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
40429 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
40430 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
40431 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
40432 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
40433 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
40434 ELSEIF(IPRT .EQ. 1) THEN
40435 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
40437 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
40438 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
40439 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
40440 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
40441 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
40442 ELSEIF(IPRT .EQ. 0) THEN
40443 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
40445 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
40446 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
40447 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
40448 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
40449 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
40450 ELSEIF(IPRT .EQ. -1) THEN
40451 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
40453 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
40454 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
40455 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
40456 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
40457 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
40458 ELSEIF(IPRT .EQ. -2) THEN
40459 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
40461 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
40462 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
40463 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
40464 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
40465 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
40466 ELSEIF(IPRT .EQ. -3) THEN
40467 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
40469 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
40470 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
40471 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
40472 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
40473 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
40474 ELSEIF(IPRT .EQ. -4) THEN
40475 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
40477 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
40478 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
40479 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
40480 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
40481 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
40482 ELSEIF(IPRT .EQ. -5) THEN
40483 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
40485 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
40486 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
40487 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
40488 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
40489 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
40490 ELSEIF(IPRT .EQ. -6) THEN
40491 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
40493 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
40494 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
40495 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
40496 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
40497 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
40500 C...Expansion for CTEQ3M.
40501 ELSEIF(ISET .EQ. 2) THEN
40502 IF(IPRT .EQ. 2) THEN
40503 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
40505 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
40506 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
40507 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
40508 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
40509 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
40510 ELSEIF(IPRT .EQ. 1) THEN
40511 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
40513 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
40514 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
40515 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
40516 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
40517 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
40518 ELSEIF(IPRT .EQ. 0) THEN
40519 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
40521 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
40522 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
40523 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
40524 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
40525 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
40526 ELSEIF(IPRT .EQ. -1) THEN
40527 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
40529 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
40530 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
40531 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
40532 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
40533 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
40534 ELSEIF(IPRT .EQ. -2) THEN
40535 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
40537 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
40538 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
40539 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
40540 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
40541 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
40542 ELSEIF(IPRT .EQ. -3) THEN
40543 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
40545 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
40546 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
40547 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
40548 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
40549 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
40550 ELSEIF(IPRT .EQ. -4) THEN
40551 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
40553 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
40554 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
40555 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
40556 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
40557 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
40558 ELSEIF(IPRT .EQ. -5) THEN
40559 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
40561 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
40562 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
40563 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
40564 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
40565 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
40566 ELSEIF(IPRT .EQ. -6) THEN
40567 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
40569 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
40570 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
40571 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
40572 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
40573 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
40576 C...Expansion for CTEQ3D.
40577 ELSEIF(ISET .EQ. 3) THEN
40578 IF(IPRT .EQ. 2) THEN
40579 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
40581 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
40582 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
40583 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
40584 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
40585 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
40586 ELSEIF(IPRT .EQ. 1) THEN
40587 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
40589 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
40590 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
40591 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
40592 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
40593 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
40594 ELSEIF(IPRT .EQ. 0) THEN
40595 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
40597 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
40598 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
40599 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
40600 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
40601 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
40602 ELSEIF(IPRT .EQ. -1) THEN
40603 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
40605 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
40606 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
40607 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
40608 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
40609 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
40610 ELSEIF(IPRT .EQ. -2) THEN
40611 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
40613 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
40614 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
40615 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
40616 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
40617 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
40618 ELSEIF(IPRT .EQ. -3) THEN
40619 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
40621 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
40622 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
40623 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
40624 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
40625 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
40626 ELSEIF(IPRT .EQ. -4) THEN
40627 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
40629 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
40630 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
40631 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
40632 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
40633 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
40634 ELSEIF(IPRT .EQ. -5) THEN
40635 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
40637 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
40638 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
40639 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
40640 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
40641 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
40642 ELSEIF(IPRT .EQ. -6) THEN
40643 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
40645 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
40646 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
40647 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
40648 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
40649 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
40653 C...Calculation of x * f(x, Q).
40654 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
40655 & *(LOG(1D0+1D0/X))**A5 )
40660 C*********************************************************************
40663 C...Gives the GRV 94 L (leading order) parton distribution function set
40664 C...in parametrized form.
40665 C...Authors: M. Glueck, E. Reya and A. Vogt.
40667 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40669 C...Double precision declaration.
40670 IMPLICIT DOUBLE PRECISION (A - Z)
40672 C...Common expressions.
40674 LAM2 = 0.2322D0 * 0.2322D0
40675 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40681 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
40682 AKU = 0.590D0 - 0.024D0 * S
40683 BKU = 0.131D0 + 0.063D0 * S
40684 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
40685 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
40686 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
40687 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
40688 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40691 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
40693 BKD = 0.486D0 + 0.062D0 * S
40694 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
40695 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
40696 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
40697 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
40698 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40701 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
40702 AKE = 0.409D0 - 0.005D0 * S
40703 BKE = 0.799D0 + 0.071D0 * S
40704 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
40705 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
40707 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
40708 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40713 AKX = 0.410D0 - 0.232D0 * S
40714 BKX = 0.534D0 - 0.457D0 * S
40715 AGX = 0.890D0 - 0.140D0 * S
40717 CX = 0.320D0 + 0.683D0 * S
40718 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
40719 EX = 4.119D0 + 1.713D0 * S
40720 ESX = 0.682D0 + 2.978D0 * S
40721 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40728 AKS = 1.798D0 - 0.596D0 * S
40729 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
40730 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
40731 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
40732 EST = 3.981D0 + 1.638D0 * S
40734 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40742 BC = 4.24D0 - 0.804D0 * S
40743 DCT = 3.46D0 - 1.076D0 * S
40744 ECT = 4.61D0 + 1.49D0 * S
40745 ESC = 2.555D0 + 1.961D0 * S
40746 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40755 DBT = 2.929D0 + 1.396D0 * S
40756 EBT = 4.71D0 + 1.514D0 * S
40757 ESB = 4.02D0 + 1.239D0 * S
40758 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40763 AKG = 1.742D0 - 0.930D0 * S
40764 BKG = - 0.399D0 * S2
40765 AG = 7.486D0 - 2.185D0 * S
40766 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
40767 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
40768 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
40769 EG = 0.807D0 + 2.005D0 * S
40770 ESG = 3.841D0 + 0.316D0 * S
40771 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
40777 C*********************************************************************
40780 C...Gives the GRV 94 M (MSbar) parton distribution function set
40781 C...in parametrized form.
40782 C...Authors: M. Glueck, E. Reya and A. Vogt.
40784 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40786 C...Double precision declaration.
40787 IMPLICIT DOUBLE PRECISION (A - Z)
40789 C...Common expressions.
40791 LAM2 = 0.248D0 * 0.248D0
40792 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40798 NU = 1.304D0 + 0.863D0 * S
40799 AKU = 0.558D0 - 0.020D0 * S
40801 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
40802 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
40803 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
40804 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
40805 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40808 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
40809 AKD = 0.270D0 - 0.019D0 * S
40811 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
40812 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
40813 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
40814 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
40815 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40818 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
40819 AKE = 0.409D0 - 0.007D0 * S
40820 BKE = 0.782D0 + 0.082D0 * S
40821 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
40822 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
40824 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
40825 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40833 BGX = 3.210D0 - 1.866D0 * S
40835 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
40836 EX = 3.077D0 + 1.446D0 * S
40837 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
40838 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40845 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
40846 AS = -4.329D0 + 1.131D0 * S
40847 BS = 9.568D0 - 1.744D0 * S
40848 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
40849 EST = 3.031D0 + 1.639D0 * S
40850 ESS = 5.837D0 + 0.815D0 * S
40851 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40857 AKC = -0.625D0 - 0.523D0 * S
40859 BC = 1.896D0 + 1.616D0 * S
40860 DCT = 4.12D0 + 0.683D0 * S
40861 ECT = 4.36D0 + 1.328D0 * S
40862 ESC = 0.677D0 + 0.679D0 * S
40863 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40869 AKB = - 0.193D0 * S
40872 DBT = 3.447D0 + 0.927D0 * S
40873 EBT = 4.68D0 + 1.259D0 * S
40874 ESB = 1.892D0 + 2.199D0 * S
40875 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40880 AKG = 1.724D0 + 0.157D0 * S
40881 BKG = 0.800D0 + 1.016D0 * S
40882 AG = 7.517D0 - 2.547D0 * S
40883 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
40884 CG = 4.039D0 + 1.491D0 * S
40885 DG = 3.404D0 + 0.830D0 * S
40886 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
40887 ESG = 3.256D0 - 0.436D0 * S
40888 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
40893 C*********************************************************************
40896 C...Gives the GRV 94 D (DIS) parton distribution function set
40897 C...in parametrized form.
40898 C...Authors: M. Glueck, E. Reya and A. Vogt.
40900 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40902 C...Double precision declaration.
40903 IMPLICIT DOUBLE PRECISION (A - Z)
40905 C...Common expressions.
40907 LAM2 = 0.248D0 * 0.248D0
40908 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40914 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
40915 AKU = 0.563D0 - 0.025D0 * S
40916 BKU = 0.054D0 + 0.154D0 * S
40917 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
40918 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
40919 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
40920 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
40921 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40924 ND = 0.156D0 - 0.017D0 * S
40925 AKD = 0.299D0 - 0.022D0 * S
40926 BKD = 0.259D0 - 0.015D0 * S
40927 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
40928 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
40929 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
40930 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
40931 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40934 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
40935 AKE = 0.419D0 - 0.013D0 * S
40936 BKE = 1.064D0 - 0.038D0 * S
40937 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
40938 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
40939 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
40940 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
40941 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40946 AKX = 0.326D0 + 0.150D0 * S
40947 BKX = 0.956D0 + 0.405D0 * S
40949 BGX = 3.794D0 - 2.359D0 * DS
40951 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
40952 EX = 3.049D0 + 1.597D0 * S
40953 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
40954 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40961 AKS = 1.415D0 - 0.641D0 * DS
40962 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
40963 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
40964 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
40965 EST = 4.546D0 + 0.372D0 * S2
40966 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
40967 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40973 AKC = -0.625D0 - 0.523D0 * S
40975 BC = 1.896D0 + 1.616D0 * S
40976 DCT = 4.12D0 + 0.683D0 * S
40977 ECT = 4.36D0 + 1.328D0 * S
40978 ESC = 0.677D0 + 0.679D0 * S
40979 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40985 AKB = - 0.193D0 * S
40988 DBT = 3.447D0 + 0.927D0 * S
40989 EBT = 4.68D0 + 1.259D0 * S
40990 ESB = 1.892D0 + 2.199D0 * S
40991 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40997 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
40998 AG = 25.09D0 - 7.935D0 * S
40999 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
41000 CG = 590.3D0 - 173.8D0 * S
41001 DG = 5.196D0 + 1.857D0 * S
41002 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
41003 ESG = 3.232D0 - 0.542D0 * S
41004 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
41009 C*********************************************************************
41012 C...Auxiliary for the GRV 94 parton distribution functions
41013 C...for u and d valence and d-u sea.
41014 C...Authors: M. Glueck, E. Reya and A. Vogt.
41016 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
41018 C...Double precision declaration.
41019 IMPLICIT DOUBLE PRECISION (A - Z)
41023 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
41029 C*********************************************************************
41032 C...Auxiliary for the GRV 94 parton distribution functions
41033 C...for d+u sea and gluon.
41034 C...Authors: M. Glueck, E. Reya and A. Vogt.
41036 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
41038 C...Double precision declaration.
41039 IMPLICIT DOUBLE PRECISION (A - Z)
41043 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
41044 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
41049 C*********************************************************************
41052 C...Auxiliary for the GRV 94 parton distribution functions
41053 C...for s, c and b sea.
41054 C...Authors: M. Glueck, E. Reya and A. Vogt.
41056 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
41058 C...Double precision declaration.
41059 IMPLICIT DOUBLE PRECISION (A - Z)
41067 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
41068 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
41074 C*********************************************************************
41077 C...Auxiliary function for parametrization of CTEQ5L.
41078 C...Author: J. Pumplin 9/99.
41080 C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
41081 C...in Parametrized Form
41082 C... September 15, 1999
41084 C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
41085 C... CTEQ5 PPARTON DISTRIBUTIONS"
41088 C...The CTEQ5M1 set given here is an updated version of the original
41089 C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
41090 C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
41091 C...almost all applications.
41092 C...The improvement is in the QCD evolution which is now more
41093 C...accurate, and which agrees completely with the benchmark work
41094 C...of the HERA 96/97 Workshop.
41095 C...The differences between the parametrized and the corresponding
41096 C...table versions (on which it is based) are of similar order as
41097 C...between the two version.
41099 C...!! Because accurate parametrizations over a wide range of (x,Q)
41100 C...is hard to obtain, only the most widely used sets CTEQ5M and
41101 C...CTEQ5L are available in parametrized form for now.
41103 C...These parametrizations were obtained by Jon Pumplin.
41105 C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
41106 C -------------------------------------------------------------------
41107 C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
41108 C 3 CTEQ5L Leading Order 0.127 192 146
41109 C -------------------------------------------------------------------
41110 C...Note the Qcd-lambda values given for CTEQ5L is for the leading
41111 C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
41114 C...The two Iset value are adopted to agree with the standard table
41117 C...Range of validity:
41118 C...The range of (x, Q) covered by this parametrization of the QCD
41119 C...evolved parton distributions is 1E-6 < x < 1 ;
41120 C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
41121 C...data only in a subset of that region; and the assumed DGLAP
41122 C...evolution is unlikely to be valid for all of it either.
41124 C...The range of (x, Q) used in the CTEQ5 round of global analysis is
41125 C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
41126 C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
41127 C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
41129 FUNCTION PYCT5L(IFL,X,Q)
41131 C...Double precision declaration.
41132 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41133 IMPLICIT INTEGER(I-N)
41135 PARAMETER (NEX=8, NLF=2)
41136 DIMENSION AM(0:NEX,0:NLF,-5:2)
41137 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41138 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41139 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41140 DIMENSION AF(0:NEX)
41142 DATA MEXVEC( 2) / 8 /
41143 DATA MLFVEC( 2) / 2 /
41144 DATA UT1VEC( 2) / 0.4971265E+01 /
41145 DATA UT2VEC( 2) / -0.1105128E+01 /
41146 DATA ALFVEC( 2) / 0.2987216E+00 /
41147 DATA QMAVEC( 2) / 0.0000000E+00 /
41148 DATA (AM( 0,K, 2),K=0, 2)
41149 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
41150 DATA (AM( 1,K, 2),K=0, 2)
41151 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
41152 DATA (AM( 2,K, 2),K=0, 2)
41153 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
41154 DATA (AM( 3,K, 2),K=0, 2)
41155 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
41156 DATA (AM( 4,K, 2),K=0, 2)
41157 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
41158 DATA (AM( 5,K, 2),K=0, 2)
41159 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
41160 DATA (AM( 6,K, 2),K=0, 2)
41161 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
41162 DATA (AM( 7,K, 2),K=0, 2)
41163 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
41164 DATA (AM( 8,K, 2),K=0, 2)
41165 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
41167 DATA MEXVEC( 1) / 8 /
41168 DATA MLFVEC( 1) / 2 /
41169 DATA UT1VEC( 1) / 0.2612618E+01 /
41170 DATA UT2VEC( 1) / -0.1258304E+06 /
41171 DATA ALFVEC( 1) / 0.3407552E+00 /
41172 DATA QMAVEC( 1) / 0.0000000E+00 /
41173 DATA (AM( 0,K, 1),K=0, 2)
41174 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
41175 DATA (AM( 1,K, 1),K=0, 2)
41176 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
41177 DATA (AM( 2,K, 1),K=0, 2)
41178 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
41179 DATA (AM( 3,K, 1),K=0, 2)
41180 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
41181 DATA (AM( 4,K, 1),K=0, 2)
41182 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
41183 DATA (AM( 5,K, 1),K=0, 2)
41184 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
41185 DATA (AM( 6,K, 1),K=0, 2)
41186 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
41187 DATA (AM( 7,K, 1),K=0, 2)
41188 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
41189 DATA (AM( 8,K, 1),K=0, 2)
41190 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
41192 DATA MEXVEC( 0) / 8 /
41193 DATA MLFVEC( 0) / 2 /
41194 DATA UT1VEC( 0) / -0.4656819E+00 /
41195 DATA UT2VEC( 0) / -0.2742390E+03 /
41196 DATA ALFVEC( 0) / 0.4491863E+00 /
41197 DATA QMAVEC( 0) / 0.0000000E+00 /
41198 DATA (AM( 0,K, 0),K=0, 2)
41199 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
41200 DATA (AM( 1,K, 0),K=0, 2)
41201 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
41202 DATA (AM( 2,K, 0),K=0, 2)
41203 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
41204 DATA (AM( 3,K, 0),K=0, 2)
41205 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
41206 DATA (AM( 4,K, 0),K=0, 2)
41207 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
41208 DATA (AM( 5,K, 0),K=0, 2)
41209 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
41210 DATA (AM( 6,K, 0),K=0, 2)
41211 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
41212 DATA (AM( 7,K, 0),K=0, 2)
41213 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
41214 DATA (AM( 8,K, 0),K=0, 2)
41215 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
41217 DATA MEXVEC(-1) / 8 /
41218 DATA MLFVEC(-1) / 2 /
41219 DATA UT1VEC(-1) / 0.3862583E+01 /
41220 DATA UT2VEC(-1) / -0.1265969E+01 /
41221 DATA ALFVEC(-1) / 0.2457668E+00 /
41222 DATA QMAVEC(-1) / 0.0000000E+00 /
41223 DATA (AM( 0,K,-1),K=0, 2)
41224 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
41225 DATA (AM( 1,K,-1),K=0, 2)
41226 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
41227 DATA (AM( 2,K,-1),K=0, 2)
41228 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
41229 DATA (AM( 3,K,-1),K=0, 2)
41230 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
41231 DATA (AM( 4,K,-1),K=0, 2)
41232 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
41233 DATA (AM( 5,K,-1),K=0, 2)
41234 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
41235 DATA (AM( 6,K,-1),K=0, 2)
41236 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
41237 DATA (AM( 7,K,-1),K=0, 2)
41238 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
41239 DATA (AM( 8,K,-1),K=0, 2)
41240 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
41242 DATA MEXVEC(-2) / 7 /
41243 DATA MLFVEC(-2) / 2 /
41244 DATA UT1VEC(-2) / 0.1895615E+00 /
41245 DATA UT2VEC(-2) / -0.3069097E+01 /
41246 DATA ALFVEC(-2) / 0.5293999E+00 /
41247 DATA QMAVEC(-2) / 0.0000000E+00 /
41248 DATA (AM( 0,K,-2),K=0, 2)
41249 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
41250 DATA (AM( 1,K,-2),K=0, 2)
41251 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
41252 DATA (AM( 2,K,-2),K=0, 2)
41253 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
41254 DATA (AM( 3,K,-2),K=0, 2)
41255 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
41256 DATA (AM( 4,K,-2),K=0, 2)
41257 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
41258 DATA (AM( 5,K,-2),K=0, 2)
41259 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
41260 DATA (AM( 6,K,-2),K=0, 2)
41261 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
41262 DATA (AM( 7,K,-2),K=0, 2)
41263 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
41265 DATA MEXVEC(-3) / 7 /
41266 DATA MLFVEC(-3) / 2 /
41267 DATA UT1VEC(-3) / 0.3753257E+01 /
41268 DATA UT2VEC(-3) / -0.1113085E+01 /
41269 DATA ALFVEC(-3) / 0.3713141E+00 /
41270 DATA QMAVEC(-3) / 0.0000000E+00 /
41271 DATA (AM( 0,K,-3),K=0, 2)
41272 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
41273 DATA (AM( 1,K,-3),K=0, 2)
41274 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
41275 DATA (AM( 2,K,-3),K=0, 2)
41276 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
41277 DATA (AM( 3,K,-3),K=0, 2)
41278 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
41279 DATA (AM( 4,K,-3),K=0, 2)
41280 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
41281 DATA (AM( 5,K,-3),K=0, 2)
41282 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
41283 DATA (AM( 6,K,-3),K=0, 2)
41284 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
41285 DATA (AM( 7,K,-3),K=0, 2)
41286 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
41288 DATA MEXVEC(-4) / 7 /
41289 DATA MLFVEC(-4) / 2 /
41290 DATA UT1VEC(-4) / 0.4400772E+01 /
41291 DATA UT2VEC(-4) / -0.1356116E+01 /
41292 DATA ALFVEC(-4) / 0.3712017E-01 /
41293 DATA QMAVEC(-4) / 0.1300000E+01 /
41294 DATA (AM( 0,K,-4),K=0, 2)
41295 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
41296 DATA (AM( 1,K,-4),K=0, 2)
41297 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
41298 DATA (AM( 2,K,-4),K=0, 2)
41299 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
41300 DATA (AM( 3,K,-4),K=0, 2)
41301 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
41302 DATA (AM( 4,K,-4),K=0, 2)
41303 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
41304 DATA (AM( 5,K,-4),K=0, 2)
41305 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
41306 DATA (AM( 6,K,-4),K=0, 2)
41307 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
41308 DATA (AM( 7,K,-4),K=0, 2)
41309 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
41311 DATA MEXVEC(-5) / 6 /
41312 DATA MLFVEC(-5) / 2 /
41313 DATA UT1VEC(-5) / 0.5562568E+01 /
41314 DATA UT2VEC(-5) / -0.1801317E+01 /
41315 DATA ALFVEC(-5) / 0.4952010E-02 /
41316 DATA QMAVEC(-5) / 0.4500000E+01 /
41317 DATA (AM( 0,K,-5),K=0, 2)
41318 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
41319 DATA (AM( 1,K,-5),K=0, 2)
41320 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
41321 DATA (AM( 2,K,-5),K=0, 2)
41322 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
41323 DATA (AM( 3,K,-5),K=0, 2)
41324 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
41325 DATA (AM( 4,K,-5),K=0, 2)
41326 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
41327 DATA (AM( 5,K,-5),K=0, 2)
41328 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
41329 DATA (AM( 6,K,-5),K=0, 2)
41330 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
41332 IF(Q .LE. QMAVEC(IFL)) THEN
41337 IF(X .GE. 1.D0) THEN
41342 TMP = LOG(Q/ALFVEC(IFL))
41343 IF(TMP .LE. 0.D0) THEN
41355 DO 100 K = 0, MLFVEC(IFL)
41356 AF(I) = AF(I) + SBX*AM(I,K,IFL)
41362 U = LOG(X/0.00001D0)
41364 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
41365 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
41366 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
41367 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
41368 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
41370 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
41372 C...Include threshold factor.
41373 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
41378 C*********************************************************************
41381 C...Auxiliary function for parametrization of CTEQ5M1.
41382 C...Author: J. Pumplin 9/99.
41384 FUNCTION PYCT5M(IFL,X,Q)
41386 C...Double precision declaration.
41387 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41388 IMPLICIT INTEGER(I-N)
41390 PARAMETER (NEX=8, NLF=2)
41391 DIMENSION AM(0:NEX,0:NLF,-5:2)
41392 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41393 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41394 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41395 DIMENSION AF(0:NEX)
41397 DATA MEXVEC( 2) / 8 /
41398 DATA MLFVEC( 2) / 2 /
41399 DATA UT1VEC( 2) / 0.5141718E+01 /
41400 DATA UT2VEC( 2) / -0.1346944E+01 /
41401 DATA ALFVEC( 2) / 0.5260555E+00 /
41402 DATA QMAVEC( 2) / 0.0000000E+00 /
41403 DATA (AM( 0,K, 2),K=0, 2)
41404 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
41405 DATA (AM( 1,K, 2),K=0, 2)
41406 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
41407 DATA (AM( 2,K, 2),K=0, 2)
41408 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
41409 DATA (AM( 3,K, 2),K=0, 2)
41410 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
41411 DATA (AM( 4,K, 2),K=0, 2)
41412 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
41413 DATA (AM( 5,K, 2),K=0, 2)
41414 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
41415 DATA (AM( 6,K, 2),K=0, 2)
41416 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
41417 DATA (AM( 7,K, 2),K=0, 2)
41418 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
41419 DATA (AM( 8,K, 2),K=0, 2)
41420 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
41422 DATA MEXVEC( 1) / 8 /
41423 DATA MLFVEC( 1) / 2 /
41424 DATA UT1VEC( 1) / 0.4138426E+01 /
41425 DATA UT2VEC( 1) / -0.3221374E+01 /
41426 DATA ALFVEC( 1) / 0.4960962E+00 /
41427 DATA QMAVEC( 1) / 0.0000000E+00 /
41428 DATA (AM( 0,K, 1),K=0, 2)
41429 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
41430 DATA (AM( 1,K, 1),K=0, 2)
41431 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
41432 DATA (AM( 2,K, 1),K=0, 2)
41433 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
41434 DATA (AM( 3,K, 1),K=0, 2)
41435 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
41436 DATA (AM( 4,K, 1),K=0, 2)
41437 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
41438 DATA (AM( 5,K, 1),K=0, 2)
41439 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
41440 DATA (AM( 6,K, 1),K=0, 2)
41441 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
41442 DATA (AM( 7,K, 1),K=0, 2)
41443 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
41444 DATA (AM( 8,K, 1),K=0, 2)
41445 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
41447 DATA MEXVEC( 0) / 8 /
41448 DATA MLFVEC( 0) / 2 /
41449 DATA UT1VEC( 0) / -0.1026789E+01 /
41450 DATA UT2VEC( 0) / -0.9051707E+01 /
41451 DATA ALFVEC( 0) / 0.9462977E+00 /
41452 DATA QMAVEC( 0) / 0.0000000E+00 /
41453 DATA (AM( 0,K, 0),K=0, 2)
41454 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
41455 DATA (AM( 1,K, 0),K=0, 2)
41456 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
41457 DATA (AM( 2,K, 0),K=0, 2)
41458 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
41459 DATA (AM( 3,K, 0),K=0, 2)
41460 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
41461 DATA (AM( 4,K, 0),K=0, 2)
41462 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
41463 DATA (AM( 5,K, 0),K=0, 2)
41464 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
41465 DATA (AM( 6,K, 0),K=0, 2)
41466 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
41467 DATA (AM( 7,K, 0),K=0, 2)
41468 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
41469 DATA (AM( 8,K, 0),K=0, 2)
41470 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
41472 DATA MEXVEC(-1) / 8 /
41473 DATA MLFVEC(-1) / 2 /
41474 DATA UT1VEC(-1) / 0.5243571E+01 /
41475 DATA UT2VEC(-1) / -0.2870513E+01 /
41476 DATA ALFVEC(-1) / 0.6701448E+00 /
41477 DATA QMAVEC(-1) / 0.0000000E+00 /
41478 DATA (AM( 0,K,-1),K=0, 2)
41479 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
41480 DATA (AM( 1,K,-1),K=0, 2)
41481 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
41482 DATA (AM( 2,K,-1),K=0, 2)
41483 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
41484 DATA (AM( 3,K,-1),K=0, 2)
41485 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
41486 DATA (AM( 4,K,-1),K=0, 2)
41487 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
41488 DATA (AM( 5,K,-1),K=0, 2)
41489 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
41490 DATA (AM( 6,K,-1),K=0, 2)
41491 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
41492 DATA (AM( 7,K,-1),K=0, 2)
41493 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
41494 DATA (AM( 8,K,-1),K=0, 2)
41495 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
41497 DATA MEXVEC(-2) / 7 /
41498 DATA MLFVEC(-2) / 2 /
41499 DATA UT1VEC(-2) / 0.4782210E+01 /
41500 DATA UT2VEC(-2) / -0.1976856E+02 /
41501 DATA ALFVEC(-2) / 0.7558374E+00 /
41502 DATA QMAVEC(-2) / 0.0000000E+00 /
41503 DATA (AM( 0,K,-2),K=0, 2)
41504 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
41505 DATA (AM( 1,K,-2),K=0, 2)
41506 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
41507 DATA (AM( 2,K,-2),K=0, 2)
41508 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
41509 DATA (AM( 3,K,-2),K=0, 2)
41510 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
41511 DATA (AM( 4,K,-2),K=0, 2)
41512 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
41513 DATA (AM( 5,K,-2),K=0, 2)
41514 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
41515 DATA (AM( 6,K,-2),K=0, 2)
41516 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
41517 DATA (AM( 7,K,-2),K=0, 2)
41518 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
41520 DATA MEXVEC(-3) / 7 /
41521 DATA MLFVEC(-3) / 2 /
41522 DATA UT1VEC(-3) / 0.4518239E+01 /
41523 DATA UT2VEC(-3) / -0.2690590E+01 /
41524 DATA ALFVEC(-3) / 0.6124079E+00 /
41525 DATA QMAVEC(-3) / 0.0000000E+00 /
41526 DATA (AM( 0,K,-3),K=0, 2)
41527 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
41528 DATA (AM( 1,K,-3),K=0, 2)
41529 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
41530 DATA (AM( 2,K,-3),K=0, 2)
41531 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
41532 DATA (AM( 3,K,-3),K=0, 2)
41533 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
41534 DATA (AM( 4,K,-3),K=0, 2)
41535 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
41536 DATA (AM( 5,K,-3),K=0, 2)
41537 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
41538 DATA (AM( 6,K,-3),K=0, 2)
41539 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
41540 DATA (AM( 7,K,-3),K=0, 2)
41541 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
41543 DATA MEXVEC(-4) / 7 /
41544 DATA MLFVEC(-4) / 2 /
41545 DATA UT1VEC(-4) / 0.2783230E+01 /
41546 DATA UT2VEC(-4) / -0.1746328E+01 /
41547 DATA ALFVEC(-4) / 0.1115653E+01 /
41548 DATA QMAVEC(-4) / 0.1300000E+01 /
41549 DATA (AM( 0,K,-4),K=0, 2)
41550 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
41551 DATA (AM( 1,K,-4),K=0, 2)
41552 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
41553 DATA (AM( 2,K,-4),K=0, 2)
41554 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
41555 DATA (AM( 3,K,-4),K=0, 2)
41556 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
41557 DATA (AM( 4,K,-4),K=0, 2)
41558 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
41559 DATA (AM( 5,K,-4),K=0, 2)
41560 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
41561 DATA (AM( 6,K,-4),K=0, 2)
41562 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
41563 DATA (AM( 7,K,-4),K=0, 2)
41564 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
41566 DATA MEXVEC(-5) / 6 /
41567 DATA MLFVEC(-5) / 2 /
41568 DATA UT1VEC(-5) / 0.1619654E+02 /
41569 DATA UT2VEC(-5) / -0.3367346E+01 /
41570 DATA ALFVEC(-5) / 0.5109891E-02 /
41571 DATA QMAVEC(-5) / 0.4500000E+01 /
41572 DATA (AM( 0,K,-5),K=0, 2)
41573 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
41574 DATA (AM( 1,K,-5),K=0, 2)
41575 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
41576 DATA (AM( 2,K,-5),K=0, 2)
41577 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
41578 DATA (AM( 3,K,-5),K=0, 2)
41579 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
41580 DATA (AM( 4,K,-5),K=0, 2)
41581 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
41582 DATA (AM( 5,K,-5),K=0, 2)
41583 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
41584 DATA (AM( 6,K,-5),K=0, 2)
41585 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
41587 IF(Q .LE. QMAVEC(IFL)) THEN
41592 IF(X .GE. 1.D0) THEN
41597 TMP = LOG(Q/ALFVEC(IFL))
41598 IF(TMP .LE. 0.D0) THEN
41610 DO 100 K = 0, MLFVEC(IFL)
41611 AF(I) = AF(I) + SBX*AM(I,K,IFL)
41617 U = LOG(X/0.00001D0)
41619 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
41620 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
41621 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
41622 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
41623 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
41625 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
41627 C...Include threshold factor.
41628 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
41633 C*********************************************************************
41636 C...Auxiliary to PYPDPR. Gives proton parton distributions according to
41637 C...a few older parametrizations, now obsolete but convenient for
41638 C...backwards checks.
41640 SUBROUTINE PYPDPO(X,Q2,XPPR)
41642 C...Double precision and integer declarations.
41643 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41644 IMPLICIT INTEGER(I-N)
41645 INTEGER PYK,PYCHGE,PYCOMP
41647 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41648 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41649 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41650 COMMON/PYINT1/MINT(400),VINT(400)
41651 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
41652 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
41653 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
41656 C...The following data lines are coefficients needed in the
41657 C...Eichten, Hinchliffe, Lane, Quigg proton structure function
41658 C...parametrizations, see below.
41659 C...Powers of 1-x in different cases.
41660 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
41661 C...Expansion coefficients for up valence quark distribution.
41662 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
41663 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
41664 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
41665 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
41666 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
41667 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
41668 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
41669 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
41670 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
41671 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
41672 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
41673 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
41674 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
41675 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
41676 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
41677 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
41678 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
41679 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
41680 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
41681 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
41682 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
41683 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
41684 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
41685 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
41686 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
41687 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
41688 C...Expansion coefficients for down valence quark distribution.
41689 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
41690 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
41691 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
41692 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
41693 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
41694 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
41695 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
41696 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
41697 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
41698 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
41699 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
41700 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
41701 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
41702 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
41703 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
41704 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
41705 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
41706 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
41707 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
41708 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
41709 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
41710 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
41711 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
41712 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
41713 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
41714 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
41715 C...Expansion coefficients for up and down sea quark distributions.
41716 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
41717 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
41718 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
41719 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
41720 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
41721 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
41722 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
41723 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
41724 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
41725 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
41726 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
41727 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
41728 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
41729 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
41730 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
41731 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
41732 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
41733 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
41734 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
41735 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
41736 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
41737 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
41738 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
41739 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
41740 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
41741 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
41742 C...Expansion coefficients for gluon distribution.
41743 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
41744 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
41745 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
41746 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
41747 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
41748 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
41749 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
41750 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
41751 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
41752 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
41753 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
41754 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
41755 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
41756 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
41757 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
41758 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
41759 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
41760 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
41761 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
41762 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
41763 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
41764 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
41765 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
41766 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
41767 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
41768 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
41769 C...Expansion coefficients for strange sea quark distribution.
41770 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
41771 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
41772 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
41773 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
41774 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
41775 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
41776 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
41777 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
41778 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
41779 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
41780 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
41781 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
41782 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
41783 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
41784 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
41785 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
41786 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
41787 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
41788 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
41789 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
41790 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
41791 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
41792 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
41793 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
41794 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
41795 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
41796 C...Expansion coefficients for charm sea quark distribution.
41797 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
41798 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
41799 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
41800 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
41801 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
41802 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
41803 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
41804 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
41805 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
41806 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
41807 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
41808 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
41809 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
41810 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
41811 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
41812 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
41813 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
41814 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
41815 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
41816 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
41817 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
41818 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
41819 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
41820 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
41821 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
41822 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
41823 C...Expansion coefficients for bottom sea quark distribution.
41824 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
41825 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
41826 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
41827 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
41828 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
41829 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
41830 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
41831 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
41832 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
41833 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
41834 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
41835 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
41836 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
41837 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
41838 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
41839 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
41840 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
41841 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
41842 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
41843 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
41844 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
41845 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
41846 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
41847 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
41848 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
41849 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
41850 C...Expansion coefficients for top sea quark distribution.
41851 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
41852 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
41853 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
41854 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
41855 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
41856 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
41857 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
41858 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
41859 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
41860 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
41861 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
41862 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
41863 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
41864 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
41865 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
41866 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
41867 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
41868 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
41869 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
41870 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
41871 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
41872 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
41873 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
41874 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
41875 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
41876 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
41878 C...The following data lines are coefficients needed in the
41879 C...Duke, Owens proton structure function parametrizations, see below.
41880 C...Expansion coefficients for (up+down) valence quark distribution.
41881 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
41882 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41883 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41884 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
41885 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
41886 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41887 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41888 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
41889 C...Expansion coefficients for down valence quark distribution.
41890 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
41891 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41892 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
41893 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
41894 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
41895 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41896 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
41897 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
41898 C...Expansion coefficients for (up+down+strange) sea quark distribution.
41899 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
41900 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41901 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
41902 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
41903 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
41904 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41905 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
41906 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
41907 C...Expansion coefficients for charm sea quark distribution.
41908 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
41909 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41910 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
41911 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
41912 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
41913 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41914 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
41915 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
41916 C...Expansion coefficients for gluon distribution.
41917 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
41918 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41919 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
41920 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
41921 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
41922 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41923 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
41924 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
41926 C...Euler's beta function, requires ordinary Gamma function
41927 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
41929 C...Leading order proton parton distributions from Glueck, Reya and
41930 C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
41932 IF(MSTP(51).EQ.11) THEN
41934 C...Determine s expansion variable and some x expressions.
41935 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
41936 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
41941 C...Evaluate valence, gluon and sea distributions.
41942 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
41943 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
41944 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
41945 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
41946 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
41947 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
41948 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
41949 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
41950 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
41951 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
41952 & SQRT(4.066D0*SD**1.218D0*XL)))*
41953 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
41954 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
41955 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
41956 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
41957 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
41958 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
41959 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
41960 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
41961 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
41962 IF(SD.LE.0.888D0) THEN
41965 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
41966 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
41967 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
41969 IF(SD.LE.1.351D0) THEN
41972 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
41973 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
41974 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
41977 C...Put into output array.
41979 XPPR(1)=XFVDD+XFSEA
41980 XPPR(2)=XFVUD-XFVDD+XFSEA
41990 C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
41991 C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
41992 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
41994 C...Determine set, Lambda and x and t expansion variables.
41996 IF(NSET.EQ.1) ALAM=0.2D0
41997 IF(NSET.EQ.2) ALAM=0.29D0
41998 TMIN=LOG(5D0/ALAM**2)
41999 TMAX=LOG(1D8/ALAM**2)
42000 T=LOG(MAX(1D0,Q2/ALAM**2))
42001 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42003 IF(X.LE.0.1D0) NX=2
42004 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
42005 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
42007 C...Chebyshev polynomials for x and t expansion.
42010 TX(3)=2D0*VX**2-1D0
42011 TX(4)=4D0*VX**3-3D0*VX
42012 TX(5)=8D0*VX**4-8D0*VX**2+1D0
42013 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
42016 TT(3)=2D0*VT**2-1D0
42017 TT(4)=4D0*VT**3-3D0*VT
42018 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42019 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42021 C...Calculate structure functions.
42026 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
42029 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
42032 C...Put into output array.
42034 XPPR(1)=XQ(2)+XQ(3)
42035 XPPR(2)=XQ(1)+XQ(3)
42043 C...Special expansion for bottom (threshold effects).
42044 IF(MSTP(58).GE.5) THEN
42045 IF(NSET.EQ.1) TMIN=8.1905D0
42046 IF(NSET.EQ.2) TMIN=7.4474D0
42048 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42051 TT(3)=2D0*VT**2-1D0
42052 TT(4)=4D0*VT**3-3D0*VT
42053 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42054 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42058 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
42061 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
42066 C...Special expansion for top (threshold effects).
42067 IF(MSTP(58).GE.6) THEN
42068 IF(NSET.EQ.1) TMIN=11.5528D0
42069 IF(NSET.EQ.2) TMIN=10.8097D0
42070 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
42071 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
42073 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42076 TT(3)=2D0*VT**2-1D0
42077 TT(4)=4D0*VT**3-3D0*VT
42078 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42079 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42083 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
42086 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
42091 C...Proton parton distributions from Duke, Owens.
42092 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
42093 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
42095 C...Determine set, Lambda and s expansion parameter.
42097 IF(NSET.EQ.1) ALAM=0.2D0
42098 IF(NSET.EQ.2) ALAM=0.4D0
42099 Q2IN=MIN(1D6,MAX(4D0,Q2))
42100 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
42102 C...Calculate structure functions.
42105 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
42106 & CDO(3,IS,KFL,NSET)*SD**2
42109 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
42110 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
42112 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
42113 & TS(5)*X**2+TS(6)*X**3)
42117 C...Put into output arrays.
42119 XPPR(1)=XQ(2)+XQ(3)/6D0
42120 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
42133 C*********************************************************************
42136 C...Gives threshold attractive/repulsive factor for heavy flavour
42139 FUNCTION PYHFTH(SH,SQM,FRATT)
42141 C...Double precision and integer declarations.
42142 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42143 IMPLICIT INTEGER(I-N)
42144 INTEGER PYK,PYCHGE,PYCOMP
42146 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42147 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42148 COMMON/PYINT1/MINT(400),VINT(400)
42149 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
42151 C...Value for alpha_strong.
42152 IF(MSTP(35).LE.1) THEN
42157 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
42163 C...Evaluate attractive and repulsive factors.
42164 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42165 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
42166 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42167 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
42168 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
42174 C*********************************************************************
42177 C...Splits a hadron remnant into two (partons or hadron + parton)
42178 C...in case it is more complicated than just a quark or a diquark.
42180 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
42182 C...Double precision and integer declarations.
42183 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42184 IMPLICIT INTEGER(I-N)
42185 INTEGER PYK,PYCHGE,PYCOMP
42186 C...Commonblocks. PYDAT1 temporary
42187 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42188 COMMON/PYINT1/MINT(400),VINT(400)
42189 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42190 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
42194 C...Preliminaries. Parton composition.
42197 KFL(1)=MOD(KFA/1000,10)
42198 KFL(2)=MOD(KFA/100,10)
42199 KFL(3)=MOD(KFA/10,10)
42200 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
42201 KFL(2)=INT(1.5D0+PYR(0))
42202 IF(MINT(105).EQ.333) KFL(2)=3
42203 IF(MINT(105).EQ.443) KFL(2)=4
42205 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
42208 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
42211 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
42212 KFL(2)=MOD(KFA/10,10)
42213 KFL(3)=MOD(KFA/100,10)
42215 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
42222 C...Subdivide lepton.
42223 IF(KFA.GE.11.AND.KFA.LE.18) THEN
42224 IF(KFLR.EQ.KFA) THEN
42226 ELSEIF(KFLR.EQ.22) THEN
42228 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
42230 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
42232 ELSEIF(KFLR.EQ.21) THEN
42240 C...Subdivide photon.
42241 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
42242 IF(KFLR.NE.21) THEN
42247 IF(RAGR.GT.0.125D0) KFLSP=2
42248 IF(RAGR.GT.0.625D0) KFLSP=3
42249 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
42253 C...Subdivide Reggeon or Pomeron.
42254 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
42255 IF(KFLIN.EQ.21) THEN
42261 C...Subdivide meson.
42262 ELSEIF(KFL(1).EQ.0) THEN
42263 KFL(2)=KFL(2)*(-1)**KFL(2)
42264 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
42265 IF(KFLR.EQ.KFL(2)) THEN
42267 ELSEIF(KFLR.EQ.KFL(3)) THEN
42269 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
42272 ELSEIF(KFLR.EQ.21) THEN
42275 ELSEIF(KFLR*KFL(2).GT.0) THEN
42278 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
42279 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42281 ELSEIF(KFLCH.EQ.0) THEN
42282 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42290 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
42291 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42293 ELSEIF(KFLCH.EQ.0) THEN
42294 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42301 C...Special case for extracting photon from baryon without splitting
42302 C...the latter. (Currently only used by external programs.)
42303 ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
42307 C...Subdivide baryon.
42311 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
42314 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
42317 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
42318 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
42321 IAGR=1.00001D0+2.99998D0*PYR(0)
42324 IF(IAGR.EQ.1) ID1=2
42325 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
42328 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
42329 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
42330 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
42331 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
42332 ELSEIF(MOD(KFA,10).EQ.2) THEN
42333 IF(IAGR.EQ.1) KSP=1
42334 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
42336 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
42337 IF(KFLR.EQ.21) THEN
42339 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
42342 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
42343 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42345 ELSEIF(KFLCH.EQ.0) THEN
42346 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42350 ELSEIF(NAGR.EQ.0) THEN
42353 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
42354 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42356 ELSEIF(KFLCH.EQ.0) THEN
42357 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42365 C...Add on correct sign for result.
42372 C*********************************************************************
42375 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
42376 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
42377 C...(Dover, 1965) 6.1.36.
42381 C...Double precision and integer declarations.
42382 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42383 IMPLICIT INTEGER(I-N)
42384 INTEGER PYK,PYCHGE,PYCOMP
42385 C...Local array and data.
42387 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
42388 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
42397 PYGAMM=PYGAMM+B(I)*DXP
42403 PYGAMM=(X-IX)*PYGAMM
42410 C***********************************************************************
42413 C...Calculates real and imaginary parts of the auxiliary functions W1
42414 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
42415 C...der Bij, Nucl. Phys. B297 (1988) 221.
42417 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
42419 C...Double precision and integer declarations.
42420 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42421 IMPLICIT INTEGER(I-N)
42422 INTEGER PYK,PYCHGE,PYCOMP
42424 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42427 ASINH(X)=LOG(X+SQRT(X**2+1D0))
42428 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
42430 IF(EPS.LT.0D0) THEN
42431 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
42432 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
42434 ELSEIF(EPS.LT.1D0) THEN
42435 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
42436 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
42437 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
42438 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
42440 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
42441 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
42448 C***********************************************************************
42451 C...Calculates real and imaginary parts of the auxiliary function I3;
42452 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
42453 C...Nucl. Phys. B297 (1988) 221.
42455 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
42457 C...Double precision and integer declarations.
42458 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42459 IMPLICIT INTEGER(I-N)
42460 INTEGER PYK,PYCHGE,PYCOMP
42462 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42465 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
42466 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
42468 IF(EPS.LT.0D0) THEN
42469 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42470 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
42471 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
42472 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
42473 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
42474 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
42475 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
42476 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
42478 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
42479 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
42480 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
42481 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
42482 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
42483 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
42484 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
42485 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
42486 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42487 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
42488 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
42489 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
42490 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
42491 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
42492 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
42493 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
42495 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
42496 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
42497 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
42498 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
42499 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
42502 ELSEIF(EPS.LT.1D0) THEN
42503 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42504 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
42505 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
42506 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
42507 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
42508 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
42509 & (0.25D0*(RAT+1D0)*EPS))
42510 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
42511 & (0.25D0*(RAT+1D0)*EPS))
42512 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
42513 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
42514 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
42515 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
42516 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
42517 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
42518 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
42519 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
42520 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42521 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
42522 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
42523 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
42524 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
42525 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
42526 & (1D0+0.25D0*RAT*EPS-GA))
42527 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
42528 & (1D0+0.25D0*RAT*EPS-GA))
42530 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
42531 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
42532 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
42533 & LOG((GA+BE-1D0)/(BE-GA))
42534 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
42537 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
42538 RCTHE=RSQ*(1D0-2D0*BE/EPS)
42539 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
42540 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
42541 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
42543 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
42544 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
42545 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
42546 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
42547 & (PHI-THE)*(PHI+THE-PARU(1))
42548 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
42549 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
42552 Y3RE=2D0/(2D0*BE-1D0)*F3RE
42553 Y3IM=2D0/(2D0*BE-1D0)*F3IM
42558 C***********************************************************************
42561 C...Calculates real and imaginary part of Spence function; see
42562 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
42564 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
42566 C...Double precision and integer declarations.
42567 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42568 IMPLICIT INTEGER(I-N)
42569 INTEGER PYK,PYCHGE,PYCOMP
42571 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42573 C...Local array and data.
42576 &1.000000D+00, -5.000000D-01, 1.666667D-01,
42577 &0.000000D+00, -3.333333D-02, 0.000000D+00,
42578 &2.380952D-02, 0.000000D+00, -3.333333D-02,
42579 &0.000000D+00, 7.575757D-02, 0.000000D+00,
42580 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
42584 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
42585 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
42586 IF(IREIM.EQ.2) PYSPEN=0D0
42590 XMOD=SQRT(XRE**2+XIM**2)
42591 IF(XMOD.LT.1D-6) THEN
42592 IF(IREIM.EQ.1) PYSPEN=0D0
42593 IF(IREIM.EQ.2) PYSPEN=0D0
42597 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42601 IF(XMOD.GT.1D0) THEN
42603 ALGXIM=XARG-SIGN(PARU(1),XARG)
42604 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
42605 SP0IM=-ALGXRE*ALGXIM
42612 IF(XRE.GT.0.5D0) THEN
42617 XMOD=SQRT(XRE**2+XIM**2)
42618 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42621 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
42622 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
42628 XMOD=SQRT(XRE**2+XIM**2)
42629 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42638 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
42639 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
42640 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
42643 SPRE=SPRE+B(I)*TERMRE
42644 SPIM=SPIM+B(I)*TERMIM
42647 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
42648 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
42653 C***********************************************************************
42656 C...Calculates the matrix element for the processes
42657 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
42658 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
42659 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
42661 SUBROUTINE PYQQBH(WTQQBH)
42663 C...Double precision and integer declarations.
42664 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42665 IMPLICIT INTEGER(I-N)
42666 INTEGER PYK,PYCHGE,PYCOMP
42668 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42669 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42670 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42671 COMMON/PYINT1/MINT(400),VINT(400)
42672 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42673 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
42674 C...Local arrays and function.
42675 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
42676 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
42679 C...Mass parameters.
42682 SHPR=SQRT(VINT(26))*VINT(1)
42683 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
42684 PH=SQRT(VINT(21))*VINT(1)
42688 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
42690 PT=SQRT(MAX(0D0,VINT(197+5*I)))
42691 PP(I,1)=PT*COS(VINT(198+5*I))
42692 PP(I,2)=PT*SIN(VINT(198+5*I))
42694 PP(3,1)=-PP(1,1)-PP(2,1)
42695 PP(3,2)=-PP(1,2)-PP(2,2)
42696 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
42697 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
42698 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
42700 PP(3,3)=PMT3*SINH(VINT(211))
42701 PP(3,4)=PMT3*COSH(VINT(211))
42702 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
42703 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
42704 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
42705 PP(2,3)=-PP(1,3)-PP(3,3)
42706 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
42707 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
42709 C...Set up incoming kinematics and derived momentum combinations.
42713 PP(I,3)=-0.5D0*SHPR*(-1)**I
42714 PP(I,4)=-0.5D0*SHPR
42717 PP(6,J)=PP(1,J)+PP(2,J)
42718 PP(7,J)=PP(1,J)+PP(3,J)
42719 PP(8,J)=PP(1,J)+PP(4,J)
42720 PP(9,J)=PP(1,J)+PP(5,J)
42721 PP(10,J)=-PP(2,J)-PP(3,J)
42722 PP(11,J)=-PP(2,J)-PP(4,J)
42723 PP(12,J)=-PP(2,J)-PP(5,J)
42724 PP(13,J)=-PP(4,J)-PP(5,J)
42727 C...Derived kinematics invariants.
42756 C...Define colour coefficients for g + g -> Q + Qbar + H.
42757 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
42761 CLR(I+3,J+3)=16D0/3D0
42762 CLR(I,J+3)=-2D0/3D0
42763 CLR(I+3,J)=-2D0/3D0
42776 CLR(6+K1,6+K2)=12D0
42780 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
42781 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
42782 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
42783 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
42784 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
42785 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
42786 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
42788 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
42789 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
42790 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42791 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
42792 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
42793 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
42794 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
42795 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
42796 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
42797 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
42798 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
42799 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
42800 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
42801 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
42802 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
42803 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
42804 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
42805 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
42807 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
42808 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
42809 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
42810 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
42811 & +X4*X9*X5+X4*X5**2)
42812 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
42813 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
42814 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
42815 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
42816 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
42817 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
42818 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
42819 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
42820 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
42821 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
42822 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
42823 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
42824 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
42825 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
42826 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
42827 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
42828 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
42829 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
42830 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
42831 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
42833 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
42834 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
42835 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
42836 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
42837 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
42838 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
42839 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
42841 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
42842 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
42843 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
42844 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
42845 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
42846 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
42848 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
42849 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
42850 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
42851 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
42852 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
42853 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
42854 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
42856 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
42857 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
42858 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
42859 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
42860 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
42861 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
42862 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
42863 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
42864 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
42865 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
42866 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
42867 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
42868 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
42869 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
42870 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
42871 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
42872 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
42873 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
42874 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
42875 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
42876 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
42877 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
42878 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
42879 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
42880 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
42881 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
42882 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
42883 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
42884 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
42885 & +X3*X8*X5+X3*X5**2)
42886 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
42887 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
42888 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
42889 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
42890 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
42891 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
42892 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
42894 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
42895 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
42896 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
42897 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
42898 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
42899 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
42900 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
42901 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
42902 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
42903 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
42904 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
42905 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
42906 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
42907 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
42908 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
42909 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
42910 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
42911 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
42912 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
42913 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
42914 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
42915 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
42916 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
42917 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
42918 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
42919 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
42921 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
42922 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
42923 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42924 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
42925 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
42926 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
42927 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
42928 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
42929 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
42930 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
42931 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
42932 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
42933 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
42934 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
42935 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
42936 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
42937 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
42938 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
42939 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
42940 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
42941 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
42942 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
42943 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
42944 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
42945 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
42946 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
42948 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42949 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42950 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
42951 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
42952 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
42953 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
42954 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
42955 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
42956 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
42957 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
42958 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
42959 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42960 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42961 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
42962 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
42963 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
42964 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
42965 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
42966 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
42967 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
42968 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
42969 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
42970 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
42971 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
42972 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
42973 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
42974 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
42975 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
42976 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
42977 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
42978 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
42979 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
42980 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
42981 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
42982 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
42983 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
42984 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
42985 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
42986 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
42987 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
42988 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
42989 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
42990 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
42991 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
42993 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
42994 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
42995 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
42996 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
42997 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
42998 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
42999 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
43000 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
43001 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
43002 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
43003 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
43005 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43006 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
43007 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
43008 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43009 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
43010 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
43012 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43013 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
43014 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
43016 FM(9,10)=0.5D0*(FMXX+FM(9,10))
43017 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43018 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
43019 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
43021 C...Repackage matrix elements.
43027 RM(7,7)=FM(7,7)-2D0*FM(9,9)
43028 RM(7,8)=FM(7,8)-2D0*FM(9,10)
43029 RM(8,8)=FM(8,8)-2D0*FM(10,10)
43031 C...Produce final result: matrix elements * colours * propagators.
43036 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
43039 WTQQBH=-WTQQBH/256D0
43042 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
43043 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
43044 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
43046 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
43047 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
43048 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
43050 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
43051 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
43054 C...Produce final result: matrix elements * propagators.
43056 A12=A12/(DX(7)*DX(8))
43058 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
43064 C*********************************************************************
43066 C...PYSTBH (and auxiliaries)
43067 C.. Evaluates the matrix elements for t + b + H production.
43069 SUBROUTINE PYSTBH(WTTBH)
43071 C...DOUBLE PRECISION AND INTEGER DECLARATIONS
43072 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43073 IMPLICIT INTEGER(I-N)
43074 INTEGER PYK,PYCHGE,PYCOMP
43077 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43078 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43079 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43080 COMMON/PYINT1/MINT(400),VINT(400)
43081 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43082 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
43083 COMMON/PYINT4/MWID(500),WIDS(500,5)
43084 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
43085 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43086 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
43087 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
43088 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
43089 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
43090 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43091 DOUBLE PRECISION MW2
43092 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
43093 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
43095 C...LOCAL ARRAYS AND COMPLEX VARIABLES
43096 DIMENSION QQ(4,2),PP(4,3)
43101 C...KINEMATIC PARAMETERS.
43102 SHPR=SQRT(VINT(26))*VINT(1)
43103 PH=SQRT(VINT(21))*VINT(1)
43106 C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
43108 PT=SQRT(MAX(0D0,VINT(197+5*I)))
43109 PP(1,I)=PT*COS(VINT(198+5*I))
43110 PP(2,I)=PT*SIN(VINT(198+5*I))
43112 PP(1,3)=-PP(1,1)-PP(1,2)
43113 PP(2,3)=-PP(2,1)-PP(2,2)
43114 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
43115 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
43116 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
43118 PP(3,3)=PMT3*SINH(VINT(211))
43119 PP(4,3)=PMT3*COSH(VINT(211))
43120 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
43121 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
43122 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
43123 PP(3,2)=-PP(3,1)-PP(3,3)
43124 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
43125 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
43127 C...CM SYSTEM, INGOING QUARKS/GLUONS
43128 QQ(3,1) = SHPR/2.D0
43133 C...PARAMETERS FOR AMPLITUDE METHOD
43137 MW2 = PMAS(24,1)**2
43140 RMB=PYMRUN(5,VINT(52))
43144 IF (ISUB.EQ.401) THEN
43145 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43146 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43147 ELSE IF (ISUB.EQ.402) THEN
43148 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43149 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43154 C------------------------------------------------------------------
43155 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
43156 C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
43157 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43158 IMPLICIT INTEGER(I-N)
43159 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
43160 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43163 C TOP WIDTH CALCULATION
43170 IF (MT .LT. (MHP+MB)) THEN
43172 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43173 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43174 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43177 C T ->BW +T ->B H^+
43178 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43179 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43180 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43182 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
43183 & -4.D0*(MHP*MB/MT**2)**2 )
43184 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
43185 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
43186 GAMT = GAMTBW+GAMTBH
43193 C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
43194 C GG->TBH^+, QQBAR->TBH^+
43195 C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
43196 C (FOR INSTANCE WITH PYTHIA)
43197 C------------------------------------------------------------
43198 C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
43199 C PHYS REV. D 60 (1999) 115011
43200 C (THESE FILES PREPARED BY J.-L. KNEUR)
43201 C------------------------------------------------------------
43203 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43205 C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
43207 C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
43208 C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
43209 C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
43210 C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
43211 C "PHYSICAL PARAMETERS" INPUT:
43212 C MT,MB TOP AND BOTTOM MASSES;
43213 C MHP CHARGED HIGGS MASS
43214 C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
43216 C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
43217 C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
43218 C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
43219 C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
43220 C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
43221 C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
43222 C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
43224 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43225 IMPLICIT INTEGER(I-N)
43226 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43227 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43228 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43229 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43230 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43232 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43233 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
43234 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43235 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43236 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43237 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
43238 C (TAN BETA) VALUES
43240 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43241 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43246 C COLLECTING THE RELEVANT OVERALL FACTORS:
43247 C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
43248 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
43249 C COUPLING CONSTANT (OVERALL NORMALIZATION)
43250 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
43251 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
43252 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
43253 C ALPHAS IS ALPHA_STRONG;
43254 C SW2 IS SIN(THETA_W)**2.
43257 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
43259 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
43260 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
43261 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
43263 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
43264 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
43266 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
43268 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
43269 S = 2*PYTBHS(Q1,Q2)
43276 C TOP WIDTH CALCULATION
43277 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
43278 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
43279 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
43280 A1INV= S -2*P1Q1 -2*P1Q2
43281 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
43282 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
43283 C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
43285 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
43286 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
43287 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
43288 C NOW COMES THE AMP**2:
43289 C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
43290 C THE EXPRESSIONS BELOW
43293 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
43294 &512*A1*A2*MB*MT/3-
43295 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
43296 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
43297 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
43298 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
43299 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
43300 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
43301 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
43302 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
43303 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
43304 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
43305 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
43306 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
43307 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43308 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43309 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
43310 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
43311 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
43312 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
43313 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43314 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
43315 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
43316 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43317 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43318 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43319 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
43320 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43321 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43322 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43323 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43324 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43325 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
43326 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43327 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43328 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
43329 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
43330 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43331 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
43332 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43333 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43334 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
43335 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
43336 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43337 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
43338 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43339 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43340 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43341 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43342 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
43343 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
43344 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43345 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
43346 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43347 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
43348 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
43349 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43350 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43351 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
43352 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
43353 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
43354 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43355 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43356 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43357 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43358 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43359 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
43360 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43361 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43362 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43363 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
43364 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43365 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
43366 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43367 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43368 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
43369 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43370 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43371 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43372 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
43373 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43374 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43375 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43376 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43377 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43378 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43379 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
43380 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43381 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43382 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
43383 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43384 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43385 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43386 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43387 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43388 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43389 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
43390 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43391 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43392 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43393 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
43394 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43395 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43396 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43397 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43398 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
43399 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
43400 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
43401 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
43402 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
43403 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
43404 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
43405 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
43406 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
43407 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
43408 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
43409 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
43410 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
43411 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
43412 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
43413 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
43414 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
43415 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
43416 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
43417 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
43418 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
43419 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
43420 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
43421 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
43422 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
43423 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
43424 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
43425 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
43426 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
43427 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
43428 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
43429 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
43430 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
43431 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
43432 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
43433 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
43434 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
43435 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
43436 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
43437 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
43438 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
43439 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
43440 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
43441 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
43442 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43443 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
43444 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43445 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
43446 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
43447 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43448 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43449 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43450 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
43451 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
43452 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
43453 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43454 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43455 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
43456 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
43457 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
43458 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
43459 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43460 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43461 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
43462 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
43463 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
43464 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
43465 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
43466 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
43467 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
43468 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
43469 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43470 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
43471 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43472 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43473 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43474 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
43475 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
43476 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43477 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43478 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
43479 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43480 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43481 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
43482 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
43483 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
43484 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
43485 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
43486 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
43487 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
43488 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
43489 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
43490 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
43491 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
43492 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
43493 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
43494 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
43495 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
43496 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
43497 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43498 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43499 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
43500 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
43501 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
43502 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
43503 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
43504 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43505 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43506 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
43507 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43508 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43509 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
43510 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
43511 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
43512 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
43513 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
43514 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
43515 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
43516 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
43517 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
43518 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
43519 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
43520 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
43521 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
43522 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
43523 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
43524 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
43525 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
43526 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
43527 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
43528 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
43529 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
43530 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
43531 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
43532 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
43533 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
43534 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
43535 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
43536 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
43537 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
43538 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43539 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43540 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43541 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
43542 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
43543 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
43544 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
43545 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
43546 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
43547 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
43548 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
43549 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
43550 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
43551 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
43552 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43553 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43554 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
43555 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43556 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43557 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
43558 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
43559 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
43560 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
43561 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
43562 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
43563 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
43564 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
43565 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
43566 &384*A12*MB*MT*P1Q1**2/S**2+
43567 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
43568 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
43569 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
43570 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
43571 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
43572 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
43573 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
43574 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
43575 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
43576 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
43577 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
43578 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
43579 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
43580 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
43581 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
43582 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
43583 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
43584 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
43585 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
43586 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
43587 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
43588 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
43589 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
43590 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
43591 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
43592 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
43593 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
43594 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
43595 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
43596 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
43597 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
43598 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
43599 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
43600 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
43601 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
43602 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
43603 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
43604 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
43605 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
43606 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
43607 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
43608 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
43609 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
43610 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
43611 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
43612 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
43613 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
43614 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
43615 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
43616 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
43617 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
43618 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
43619 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
43620 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
43621 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43622 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43623 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
43624 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43625 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43626 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
43627 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
43628 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
43629 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
43630 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
43631 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
43632 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
43633 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
43634 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
43635 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
43636 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
43637 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
43638 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
43639 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
43640 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
43641 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
43642 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
43643 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43644 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43645 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
43646 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
43647 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
43648 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
43649 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
43650 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
43651 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
43652 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
43653 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
43654 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
43655 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
43656 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
43657 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
43658 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
43659 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
43660 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
43661 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
43662 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
43663 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
43664 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
43665 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43666 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43667 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
43668 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
43669 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
43670 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
43671 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
43672 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
43673 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
43674 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
43675 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
43676 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
43677 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43678 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43679 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
43680 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43681 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43682 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
43683 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
43684 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
43685 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
43686 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
43687 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
43688 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43689 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43690 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43691 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43692 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43693 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43694 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
43695 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
43696 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
43697 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
43698 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
43699 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
43700 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43701 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43702 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
43703 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
43704 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
43705 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
43706 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
43707 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
43708 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
43709 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
43710 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
43711 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
43712 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
43713 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
43714 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
43715 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
43716 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
43717 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
43718 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
43719 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
43720 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
43721 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
43722 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
43723 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
43724 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
43725 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43726 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43727 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
43728 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
43729 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
43730 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
43731 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
43732 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
43733 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43734 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43735 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
43736 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
43737 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
43738 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43739 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43740 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
43741 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
43742 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
43745 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43746 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43747 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43748 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43749 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
43750 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43751 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43752 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
43753 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
43754 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
43755 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
43756 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
43757 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
43758 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
43759 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
43760 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
43761 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
43762 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
43763 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
43764 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43765 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43766 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
43767 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
43768 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
43769 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
43770 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
43771 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
43772 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
43773 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
43774 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
43775 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
43776 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
43777 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
43778 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
43779 &272*A1*A2*P1Q1*S/(3*P1Q2)+
43780 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
43781 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
43782 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
43783 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
43784 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
43785 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
43786 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
43787 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
43788 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
43789 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
43790 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
43791 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
43792 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
43793 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
43794 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
43795 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
43796 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
43797 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
43798 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
43799 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
43800 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
43801 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
43802 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
43803 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
43804 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
43805 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
43806 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
43807 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43808 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
43809 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
43810 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
43811 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
43812 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
43813 &32*A12*P2Q1*S/(3*P1Q1)-
43814 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
43815 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
43816 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
43817 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
43818 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
43819 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
43820 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
43821 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
43822 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
43823 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
43824 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
43825 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
43826 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
43827 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
43828 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
43829 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
43830 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
43831 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
43832 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
43833 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
43834 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
43835 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
43836 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
43837 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
43838 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
43839 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
43840 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
43841 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
43842 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43843 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43844 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43845 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
43846 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
43847 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
43848 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
43849 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
43850 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
43851 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
43852 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43853 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
43854 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43855 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43856 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43857 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43858 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43859 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43860 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43861 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43862 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
43863 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
43864 &272*A1*A2*P2Q1*S/(3*P2Q2)-
43865 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
43866 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
43867 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
43868 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
43869 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
43870 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
43871 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
43872 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
43873 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
43874 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
43875 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
43876 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
43877 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
43878 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
43879 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
43880 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
43881 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
43882 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
43883 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
43884 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
43885 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
43886 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
43887 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43890 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
43891 &512*A1*A2*MB*MT/3+
43892 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
43893 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
43894 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
43895 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
43896 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
43897 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
43898 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
43899 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
43900 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
43901 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
43902 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
43903 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
43904 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43905 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43906 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
43907 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
43908 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
43909 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
43910 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43911 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
43912 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
43913 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43914 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43915 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43916 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
43917 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43918 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43919 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43920 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43921 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43922 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
43923 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43924 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43925 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
43926 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
43927 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43928 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
43929 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43930 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43931 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
43932 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
43933 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43934 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
43935 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43936 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43937 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43938 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43939 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
43940 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
43941 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43942 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
43943 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43944 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43945 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43946 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43947 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43948 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
43949 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
43950 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
43951 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43952 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43953 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43954 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
43955 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43956 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
43957 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43958 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43959 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43960 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
43961 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43962 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
43963 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43964 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43965 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43966 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43967 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43968 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43969 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
43970 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43971 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43972 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
43973 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43974 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43975 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43976 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
43977 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43978 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43979 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
43980 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43981 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43982 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
43983 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43984 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43985 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43986 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
43987 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43988 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43989 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43990 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
43991 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43992 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43993 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43994 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43995 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
43996 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
43997 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
43998 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
43999 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
44000 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
44001 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
44002 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
44003 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
44004 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
44005 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
44006 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
44007 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
44008 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
44009 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
44010 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
44011 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
44012 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
44013 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
44014 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
44015 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
44016 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
44017 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
44018 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
44019 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
44020 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
44021 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
44022 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
44023 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
44024 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
44025 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
44026 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
44027 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
44028 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
44029 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
44030 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
44031 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
44032 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
44033 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
44034 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
44035 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
44036 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44037 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44038 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
44039 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44040 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44041 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44042 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
44043 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
44044 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44045 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
44046 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44047 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
44048 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
44049 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
44050 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44051 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
44052 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
44053 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
44054 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
44055 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
44056 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44057 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
44058 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
44059 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
44060 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
44061 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
44062 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
44063 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
44064 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
44065 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
44066 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
44067 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44068 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44069 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44070 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44071 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
44072 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44073 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44074 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44075 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44076 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44077 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44078 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
44079 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
44080 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
44081 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
44082 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
44083 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
44084 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
44085 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
44086 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
44087 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
44088 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
44089 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
44090 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
44091 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
44092 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
44093 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
44094 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44095 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44096 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
44097 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
44098 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
44099 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
44100 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
44101 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44102 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
44103 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
44104 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44105 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44106 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
44107 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
44108 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
44109 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
44110 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
44111 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
44112 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
44113 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
44114 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
44115 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
44116 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
44117 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
44118 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
44119 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
44120 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
44121 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
44122 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
44123 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
44124 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
44125 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
44126 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
44127 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
44128 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
44129 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
44130 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
44131 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
44132 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
44133 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
44134 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
44135 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
44136 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44137 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44138 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
44139 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
44140 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
44141 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
44142 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
44143 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
44144 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
44145 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
44146 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
44147 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
44148 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
44149 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44150 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
44151 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
44152 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44153 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44154 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
44155 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
44156 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
44157 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
44158 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
44159 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
44160 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
44161 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
44162 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
44163 &384*A12*MB*MT*P1Q1**2/S**2+
44164 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
44165 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
44166 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
44167 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
44168 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
44169 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
44170 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
44171 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
44172 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
44173 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
44174 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
44175 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
44176 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
44177 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
44178 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
44179 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
44180 &384*A2**2*MB*MT*P2Q2**2/S**2+
44181 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
44182 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
44183 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
44184 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
44185 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
44186 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
44187 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
44188 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
44189 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
44190 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
44191 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
44192 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
44193 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
44194 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
44195 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
44196 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
44197 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
44198 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
44199 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
44200 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
44201 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
44202 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
44203 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
44204 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
44205 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
44206 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
44207 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
44208 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
44209 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
44210 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
44211 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
44212 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
44213 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
44214 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
44215 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
44216 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
44217 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
44218 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
44219 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44220 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
44221 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44222 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
44223 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
44224 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
44225 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
44226 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
44227 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
44228 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
44229 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
44230 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
44231 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
44232 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
44233 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
44234 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
44235 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
44236 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
44237 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
44238 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
44239 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44240 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44241 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
44242 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
44243 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
44244 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
44245 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
44246 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
44247 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
44248 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
44249 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
44250 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
44251 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
44252 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
44253 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
44254 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
44255 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
44256 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
44257 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
44258 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
44259 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
44260 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
44261 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
44262 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
44263 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
44264 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
44265 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
44266 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
44267 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
44268 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
44269 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
44270 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
44271 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
44272 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
44273 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44274 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44275 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
44276 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
44277 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
44278 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
44279 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
44280 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
44281 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
44282 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
44283 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
44284 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44285 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44286 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44287 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44288 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44289 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44290 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
44291 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
44292 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
44293 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
44294 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
44295 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
44296 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
44297 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
44298 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
44299 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
44300 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
44301 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
44302 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
44303 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
44304 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
44305 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
44306 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
44307 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
44308 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
44309 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
44310 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
44311 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
44312 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
44313 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
44314 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
44315 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
44316 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
44317 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
44318 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
44319 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
44320 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44321 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44322 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
44323 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
44324 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
44325 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
44326 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
44327 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
44328 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
44329 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
44330 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
44331 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
44332 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
44333 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44334 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44335 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
44336 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44337 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44338 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44339 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44340 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44341 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44342 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
44343 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
44344 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
44345 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
44346 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
44347 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
44348 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
44349 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
44350 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
44351 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
44352 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
44353 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
44354 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
44355 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
44356 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44357 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44358 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
44359 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
44360 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
44361 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
44362 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
44363 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
44364 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
44365 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
44366 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
44367 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
44368 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
44369 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
44370 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
44371 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
44372 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
44373 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
44376 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
44377 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
44378 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
44379 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
44380 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
44381 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
44382 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
44383 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
44384 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
44385 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
44386 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
44387 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
44388 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
44389 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
44390 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
44391 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
44392 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
44394 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
44395 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
44396 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
44397 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
44398 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
44399 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
44400 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44401 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44402 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
44403 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
44404 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
44405 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
44406 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
44407 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
44408 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
44409 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
44410 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
44411 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
44412 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
44413 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
44414 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
44415 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
44416 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
44417 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
44418 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
44419 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
44420 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
44421 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
44422 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
44423 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
44424 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
44425 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
44426 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
44427 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
44428 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
44429 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
44430 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
44431 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
44432 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
44433 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
44434 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
44435 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44436 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44437 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
44438 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
44439 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
44440 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
44441 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
44442 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
44443 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
44444 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
44445 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44446 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44447 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
44448 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44449 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44450 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44451 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44452 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44453 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44454 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44455 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
44456 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
44457 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
44458 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
44459 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
44460 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
44461 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
44462 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
44463 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
44464 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
44465 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
44466 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
44467 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
44468 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
44469 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
44470 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
44471 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
44472 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
44473 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
44474 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
44475 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
44476 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
44477 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
44478 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
44479 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44483 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
44484 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
44485 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44486 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44487 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
44488 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
44489 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44490 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
44491 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
44492 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
44493 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44494 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44495 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
44496 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
44497 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
44498 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
44499 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
44500 V910=V910+96*A1*A2*P1P2*P2Q1/S-
44501 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
44502 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
44503 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
44504 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
44505 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
44507 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
44508 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
44509 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44510 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44511 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
44512 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
44513 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44514 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
44515 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
44516 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
44517 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44518 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44519 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
44520 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
44521 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
44522 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
44523 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
44524 A910=A910+96*A1*A2*P1P2*P2Q1/S-
44525 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
44526 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
44527 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
44528 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
44529 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
44533 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
44536 C---------------------------------------------------------
44537 C 2) Q QBAR ->TBH^+
44538 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
44540 C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
44541 C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
44542 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44543 IMPLICIT INTEGER(I-N)
44544 DOUBLE PRECISION MW2,MT,MB,MHP,MW
44545 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
44546 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44547 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44548 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44549 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
44550 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
44551 C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
44552 C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
44553 C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
44554 C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
44556 C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
44557 C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
44564 C COLLECTING THE RELEVANT OVERALL FACTORS:
44565 C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
44566 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
44567 C COUPLING CONSTANT (OVERALL NORMALIZATION)
44568 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
44569 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
44570 C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
44571 C ALPHAS IS ALPHA_STRONG;
44572 C SW2 IS SIN(THETA_W)**2.
44575 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
44577 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
44578 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
44579 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
44581 C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
44582 C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
44584 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
44586 C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
44587 S = 2*PYTBHS(Q1,Q2)
44594 C TOP WIDTH CALCULATION
44595 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
44596 C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
44597 C THEN DEFINE TOP (RESONANT) PROPAGATOR:
44598 A1INV= S -2*P1Q1 -2*P1Q2
44599 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
44600 C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
44601 C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
44602 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
44603 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
44604 C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
44605 C NOW COMES THE AMP**2:
44606 C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
44607 C THE EXPRESSIONS BELOW
44608 YY(1, 1) = -16*A**2*A2**2*MB*MT+
44609 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
44610 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
44611 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
44612 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44613 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44614 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
44615 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
44616 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
44617 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
44618 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
44619 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
44620 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
44621 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
44622 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
44623 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
44624 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
44625 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
44626 &32*A2**2*MB**2*P1P2*V**2/S+
44627 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
44628 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
44629 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
44630 YY(1, 1)=2*YY(1, 1)
44632 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
44633 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
44634 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44635 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44636 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
44637 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
44638 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
44639 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44640 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
44641 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
44642 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
44643 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
44644 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
44645 &64*A**2*A1*A2*MB*MT*P1P2/S+
44646 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
44647 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
44648 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
44649 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
44650 &64*A**2*A1*A2*P1Q1*P2Q1/S-
44651 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
44652 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
44653 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
44654 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
44655 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
44656 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
44657 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
44658 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
44659 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
44660 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
44661 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
44662 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
44663 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
44664 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
44665 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
44666 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
44667 &32*A1*A2*P1P2*P1Q1*V**2/S+
44668 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
44669 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
44670 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
44671 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
44674 YY(2, 2) =-16*A**2*A12*MB*MT+
44675 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
44676 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
44677 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
44678 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
44679 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
44680 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
44681 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
44682 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
44683 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
44684 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
44685 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
44686 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
44687 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
44688 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
44689 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
44690 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
44691 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
44692 &32*A12*MT**2*P2Q2*V**2/S-
44693 &32*A12*P1Q2*P2Q2*V**2/S
44694 YY(2, 2)=2*YY(2, 2)
44696 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
44697 AMP2= FACT*PS*VTB**2*RES
44700 C=====================================================================
44701 C ************* FUNCTION SCALAR PRODUCTS *************************
44702 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
44703 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44704 IMPLICIT INTEGER(I-N)
44705 DIMENSION A(4),B(4)
44708 DUM=DUM-A(ID)*B(ID)
44714 C*********************************************************************
44717 C...Initializes supersymmetry: finds sparticle masses and
44718 C...branching ratios and stores this information.
44719 C...AUTHOR: STEPHEN MRENNA
44720 C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
44724 C...Double precision and integer declarations.
44725 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44726 IMPLICIT INTEGER(I-N)
44727 INTEGER PYK,PYCHGE,PYCOMP
44728 C...Parameter statement to help give large particle numbers.
44729 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44730 &KEXCIT=4000000,KDIMEN=5000000)
44732 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44733 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44734 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44735 COMMON/PYDAT4/CHAF(500,2)
44737 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44738 COMMON/PYINT4/MWID(500),WIDS(500,5)
44739 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44740 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44741 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
44742 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
44743 COMMON/PYHTRI/HHH(7)
44744 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
44745 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
44746 &/PYMSSM/,/PYMSRV/,/PYSSMT/
44748 C...Local variables.
44749 DOUBLE PRECISION ALFA,BETA
44750 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
44751 INTEGER I,J,J1,I1,K1
44752 INTEGER KC,LKNT,IDLAM(400,3)
44753 DOUBLE PRECISION XLAM(0:400)
44754 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
44755 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
44756 DOUBLE PRECISION DELM,XMDIF
44757 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
44758 DOUBLE PRECISION ARG,SGNMU,R
44761 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
44764 &1000001,2000001,1000002,2000002,1000003,2000003,
44765 &1000004,2000004,1000005,2000005,1000006,2000006,
44766 &1000011,2000011,1000012,2000012,1000013,2000013,
44767 &1000014,2000014,1000015,2000015,1000016,2000016,
44768 &1000021,1000022,1000023,1000025,1000035,1000024,
44769 &1000037,1000039, 25, 35, 36, 37,
44770 & 6, 24, 45, 46,1000045, 9*0/
44773 C...Automatically read QNUMBERS, MASS, and DECAY tables
44774 IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
44776 CALL PYSLHA(0,0,IFAIL)
44777 CALL PYSLHA(5,0,IFAIL)
44779 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
44781 C...Do nothing further if SUSY not requested
44783 IF(IMSSM.EQ.0) RETURN
44785 C...Save copy of MWID(KC) and MDCY(KC,1) values before
44786 C...they are set to zero for the LSP.
44793 MDCYSU(I)=MDCY(KC,1)
44797 C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
44801 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
44803 MDCY(KC,1)=MDCYSU(I)
44807 C...First part of routine: set masses and couplings.
44809 C...Reset mixing values in sfermion sector to pure left/right.
44817 C...Add NMSSM states if NMSSM switched on, and change old names.
44818 IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
44819 C... Switch on NMSSM
44820 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
44850 DO 123 KCT=100,MSTU(6)
44851 IF(KCHG(KCT,4).GT.100) KCN=KCT
44857 C... Set stable for now
44863 CHAF(KCN,1)='~chi_50'
44867 C...Read spectrum from SLHA file.
44868 IF (IMSSM.EQ.11) THEN
44869 CALL PYSLHA(1,0,IFAIL)
44872 C...Common couplings.
44877 COS2B=COS(2D0*BETA)
44883 C...Define sparticle masses for a general MSSM simulation.
44884 IF(IMSSM.EQ.1) THEN
44885 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
44887 KC=PYCOMP(KSUSY1+I)
44888 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
44889 KC=PYCOMP(KSUSY2+I)
44890 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
44891 KC=PYCOMP(KSUSY1+I+1)
44892 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
44893 KC=PYCOMP(KSUSY2+I+1)
44894 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
44896 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
44897 IF(XARG.LT.0D0) THEN
44898 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
44899 & ' FROM THE SUM RULE. '
44900 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
44906 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
44907 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
44908 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
44909 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
44911 IF(IMSS(8).EQ.1) THEN
44916 C...Alternatively derive masses from SUGRA relations.
44917 ELSEIF(IMSSM.EQ.2) THEN
44921 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
44930 C...Add in extra D-term contributions.
44931 IF(IMSS(7).EQ.1) THEN
44936 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44937 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
44938 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
44939 WRITE(MSTU(11),*) 'C DX = ',DX
44940 WRITE(MSTU(11),*) 'C DY = ',DY
44941 WRITE(MSTU(11),*) 'C DS = ',DS
44942 WRITE(MSTU(11),*) 'C '
44943 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
44944 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
44945 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44946 DQ2=DY/6D0-DX/3D0-DS/3D0
44947 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
44948 DD2=DY/3D0+DX-2D0*DS/3D0
44949 DL2=-DY/2D0+DX-2D0*DS/3D0
44950 DE2=DY-DX/3D0-DS/3D0
44951 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
44952 DHD2=-DY/2D0-2D0*DX/3D0+DS
44953 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
44955 DMA2 = 2D0*DMU2+DHU2+DHD2
44957 KC=PYCOMP(KSUSY1+I)
44958 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44959 KC=PYCOMP(KSUSY2+I)
44960 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
44961 KC=PYCOMP(KSUSY1+I+1)
44962 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44963 KC=PYCOMP(KSUSY2+I+1)
44964 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
44967 KC=PYCOMP(KSUSY1+I)
44968 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44969 KC=PYCOMP(KSUSY2+I)
44970 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
44971 KC=PYCOMP(KSUSY1+I+1)
44972 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44974 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
44975 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
44978 SGNMU=SIGN(1D0,RMSS(4))
44979 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
44980 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
44981 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
44982 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
44983 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
44984 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
44985 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
44986 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
44987 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
44988 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
44989 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
44990 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
44991 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
44994 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
44995 RMSS(6)=SQRT(RMSS(6)**2+DL2)
44996 RMSS(7)=SQRT(RMSS(7)**2+DE2)
44997 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
44998 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
44999 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
45000 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
45001 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
45004 C...Fix the third generation sfermions.
45007 C...Fix the neutralino--chargino--gluino sector.
45010 C...Fix the Higgs sector.
45013 C...Choose the Gunion-Haber convention.
45017 C...Print information on mass parameters.
45018 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
45019 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45020 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
45021 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
45022 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
45023 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
45024 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
45025 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
45026 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
45027 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
45028 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45030 IF(IMSS(20).EQ.1) THEN
45031 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45032 WRITE(MSTU(11),*) ' DEBUG MODE '
45033 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
45034 & UMIX(2,1),UMIX(2,2)
45035 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
45036 & UMIXI(2,1),UMIXI(2,2)
45037 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
45038 & VMIX(2,1),VMIX(2,2)
45039 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
45040 & VMIXI(2,1),VMIXI(2,2)
45041 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
45042 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
45043 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
45044 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
45045 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
45046 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
45047 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
45048 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
45049 WRITE(MSTU(11),*) ' ALFA = ',ALFA
45050 WRITE(MSTU(11),*) ' BETA = ',BETA
45051 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
45052 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
45053 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45056 C...Set up the Higgs couplings - needed here since initialization
45057 C...in PYINRE did not yet occur when PYWIDT is called below.
45069 C2B=COSB**2-SINB**2
45070 C...tanb (used for H+)
45074 C...Coupling to d-type quarks
45075 PARU(161)=SINA/COSB
45076 C...Coupling to u-type quarks
45077 PARU(162)=-COSA/SINB
45078 C...Coupling to leptons
45079 PARU(163)=PARU(161)
45083 PARU(165)=PARU(164)
45086 C...Coupling to d-type quarks
45087 PARU(171)=-COSA/COSB
45088 C...Coupling to u-type quarks
45089 PARU(172)=-SINA/SINB
45090 C...Coupling to leptons
45091 PARU(173)=PARU(171)
45095 PARU(175)=PARU(174)
45097 IF(IMSS(4).GE.2) THEN
45098 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
45100 HHH(3)=HHH(3)+HHH(4)+HHH(5)
45101 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
45102 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
45103 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
45104 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
45108 IF(IMSS(4).GE.2) THEN
45109 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
45111 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
45112 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
45113 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
45114 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
45117 IF(IMSS(4).GE.2) THEN
45118 PARU(177)=COS(2D0*BE)*COS(BE+AL)
45120 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
45121 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
45122 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
45123 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
45126 IF(IMSS(4).GE.2) THEN
45127 PARU(178)=PARU(177)
45129 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
45132 C...Coupling to d-type quarks
45134 C...Coupling to u-type quarks
45135 PARU(182)=1D0/PARU(181)
45136 C...Coupling to leptons
45137 PARU(183)=PARU(181)
45140 C...Coupling to Z h
45141 PARU(186)=COS(BE-AL)
45142 C...Coupling to Z H
45143 PARU(187)=SIN(BE-AL)
45149 C...Coupling to W h
45150 PARU(195)=COS(BE-AL)
45152 C...Tell that all Higgs couplings have been set.
45155 C...Set R-Violating couplings.
45156 C...Set lambda couplings to common value or "natural values".
45157 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
45158 VIR3=1D0/(126D0)**3
45162 IF (IRI.NE.IRJ) THEN
45163 IF (IRI.LT.IRJ) THEN
45164 RVLAM(IRI,IRJ,IRK)=RMSS(51)
45165 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
45166 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
45167 & PMAS(9+2*IRK,1)*VIR3)
45169 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
45172 RVLAM(IRI,IRJ,IRK)=0D0
45178 C...Set lambda' couplings to common value or "natural values".
45179 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
45180 VIR3=1D0/(126D0)**3
45184 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
45185 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
45186 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
45187 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
45192 C...Set lambda'' couplings to common value or "natural values".
45193 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
45194 VIR3=1D0/(126D0)**3
45198 IF (IRJ.NE.IRK) THEN
45199 IF (IRJ.LT.IRK) THEN
45200 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
45201 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
45202 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
45203 & PMAS(2*IRK-1,1)*VIR3)
45205 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
45208 RVLAMB(IRI,IRJ,IRK) = 0D0
45215 C...Antisymmetrize couplings set by user
45216 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
45220 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
45221 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
45222 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
45224 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
45225 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
45226 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
45233 C...Write spectrum to SLHA file
45234 IF (IMSS(23).NE.0) THEN
45236 CALL PYSLHA(3,0,IFAIL)
45239 C...Second part of routine: set decay modes and branching ratios.
45241 C...Allow chi10 -> gravitino + gamma or not.
45242 KC=PYCOMP(KSUSY1+39)
45243 IF( IMSS(11) .NE. 0 ) THEN
45244 PMAS(KC,1)=RMSS(21)/1D9
45247 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
45248 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
45250 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
45251 & ' ALLOWING SUSY LLE DECAYS'
45252 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
45253 & ' ALLOWING SUSY LQD DECAYS'
45254 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
45255 & ' ALLOWING SUSY UDD DECAYS'
45256 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
45257 & ' --- Warning: R-Violating couplings possibly',
45258 & ' incompatible with proton decay'
45264 C...Loop over sparticle and Higgs species.
45265 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
45266 C...Find the LSP or NLSP for a gravitino LSP
45271 IF(KF.EQ.1000039) GOTO 300
45273 IF(PMAS(KC,1).LT.PMLSP) THEN
45279 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
45281 IF (KF.EQ.0) GOTO 370
45285 C...Check if there are any decays listed for this sparticle
45287 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
45289 CALL PYSLHA(2,KF,IFAIL)
45290 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
45291 ELSEIF (I.GE.37) THEN
45295 C...Sfermion decays.
45297 C...First check to see if sneutrino is lighter than chi10.
45298 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
45299 & PMAS(KC,1).LT.PMCHI1) THEN
45301 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
45305 ELSEIF(I.EQ.25) THEN
45306 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
45307 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
45309 C...Neutralino decays.
45310 ELSEIF(I.GE.26.AND.I.LE.29) THEN
45311 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
45312 C...chi10 stable or chi10 -> gravitino + gamma.
45313 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
45319 C...Chargino decays.
45320 ELSEIF(I.GE.30.AND.I.LE.31) THEN
45321 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
45323 C...Gravitino is stable.
45324 ELSEIF(I.EQ.32) THEN
45329 ELSEIF(I.GE.33.AND.I.LE.36) THEN
45330 C...Calculate decays to non-SUSY particles.
45331 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
45336 DO 330 I1=1,MDCY(KC,3)
45338 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
45339 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
45341 XLAM(0)=XLAM(0)+XLAM(I1)
45343 IDLAM(I1,J1)=KFDP(K1,J1)
45347 C...Add the decays to SUSY particles.
45348 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
45350 C...Zero the branching ratios for use in loop mode
45351 C...thanks to K. Matchev (FNAL)
45352 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45356 C...Set stable particles.
45364 C...Store branching ratios in the standard tables.
45366 IDC=MDCY(KC,2)+MDCY(KC,3)-1
45372 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
45373 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
45374 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
45375 BRAT(IDC)=XLAM(IL)/XLAM(0)
45377 IF(MDME(IDC,1).GE.1) THEN
45378 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
45379 & PMAS(PYCOMP(KFDP(IDC,2)),1)
45380 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
45381 & PMAS(PYCOMP(KFDP(IDC,3)),1)
45384 IF(XMDIF.GE.0D0) THEN
45385 DELM=MIN(DELM,XMDIF)
45387 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
45388 WRITE(MSTU(11),*) ' KF = ',KF
45389 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
45393 ELSEIF(IDC.EQ.IDCSV) THEN
45394 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
45395 & 'channel not recognized:'
45396 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
45403 C...Store width, cutoff and lifetime.
45405 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
45406 PMAS(KC,3)=PMAS(KC,2)*10D0
45408 PMAS(KC,3)=0.95D0*DELM
45410 IF(PMAS(KC,2).NE.0D0) THEN
45411 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
45413 C...Write decays to SLHA file
45414 IF (IMSS(24).NE.0) THEN
45416 CALL PYSLHA(4,KF,IFAIL)
45424 C*********************************************************************
45427 C...Read/write spectrum or decay data from SLHA standard file(s).
45430 C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
45431 C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
45432 C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
45433 C... (KFORIG=0 : read all decay tables)
45434 C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
45435 C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
45436 C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
45437 C... (KFORIG=0 : read all MASS entries)
45439 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
45441 C...Double precision and integer declarations.
45442 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45443 IMPLICIT INTEGER(I-N)
45444 INTEGER PYK,PYCHGE,PYCOMP
45445 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45446 &KEXCIT=4000000,KDIMEN=5000000)
45448 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45449 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45450 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45451 COMMON/PYDAT4/CHAF(500,2)
45453 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
45454 CHARACTER*40 ISAVER,VISAJE
45455 COMMON/PYINT4/MWID(500),WIDS(500,5)
45456 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
45458 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45459 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45460 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45461 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
45462 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
45464 C...Local arrays, character variables and data.
45465 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
45466 & AU(3,3),AD(3,3),AE(3,3)
45467 COMMON/PYLH3C/CPRO(2),CVER(2)
45468 C...The common block of new states (QNUMBERS / PARTICLE)
45469 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
45470 C...- NQNUM : Number of QNUMBERS blocks that have been read in
45471 C...- KQNUM(I,0) : KF of new state
45472 C...- KQNUM(I,1) : 3 times electric charge
45473 C...- KQNUM(I,2) : Number of spin states: (2S + 1)
45474 C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
45475 C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
45476 C...- KQNUM(I,5:9) : space available for further quantum numbers
45477 DIMENSION MMOD(100),MSPC(100),KFDEC(100)
45478 SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
45479 C...MMOD: flags to set for each block read in.
45480 C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
45481 C...MSPC: Flags to set for each block read in.
45482 C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
45483 C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
45484 C...11: AD 12: AE 13: YU 14: YD 15: YE
45485 C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
45486 CHARACTER CPRO*12,CVER*12,CHNLIN*6
45487 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
45488 CHARACTER CHINL*120,CHKF*9,CHTMP*16
45491 C...Date of last Change
45492 PARAMETER (DOC='13 Jul 2009')
45493 C...Local arrays and initial values
45494 DIMENSION IDC(5),KFSUSY(50)
45503 &1000001,1000002,1000003,1000004,1000005,1000006,
45504 &2000001,2000002,2000003,2000004,2000005,2000006,
45505 &1000011,1000012,1000013,1000014,1000015,1000016,
45506 &2000011,2000012,2000013,2000014,2000015,2000016,
45507 &1000021,1000022,1000023,1000025,1000035,1000024,
45508 &1000037,1000039, 25, 35, 36, 37,
45509 & 6, 24, 45, 46,1000045, 9*0/
45511 RMFUN(IP)=PMAS(PYCOMP(IP),1)
45513 C...Shorthand for spectrum and decay table unit numbers
45517 C...Default for LHEF input: read header information
45518 IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
45519 IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
45520 IF (IMSS21.EQ.MSTP(161).AND.IMSS21.NE.0) MLHEF=1
45521 IF (IMSS22.EQ.MSTP(161).AND.IMSS22.NE.0) MLHEFD=1
45524 IF (NHELLO.EQ.0) THEN
45525 IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
45526 WRITE(MSTU(11),5000) DOC
45531 C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
45534 IF (MUPDA.EQ.2) LFN=IMSS22
45535 IF (MUPDA.EQ.3) LFN=IMSS(23)
45536 IF (MUPDA.EQ.4) LFN=IMSS(24)
45537 C...Flag that we have not yet found whatever we were asked to find.
45539 C...Flag that we are skipping until <slha> tag found (if LHEF)
45541 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) ISKIP=1
45543 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
45545 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
45549 C...If reading LHEF header, start by rewinding file
45550 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
45552 C...If told to read spectrum, first zero all previous information.
45553 IF (MUPDA.EQ.1) THEN
45554 C...Zero all block read flags
45559 C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
45561 KC=PYCOMP(KFSUSY(ISUSY))
45564 C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
45572 IF (J.LE.2.AND.L.LE.2) THEN
45579 C...Zero signed masses.
45581 IF (J.LE.2) SMW(J)=0D0
45584 C...If reading decays, reset PYTHIA decay counters.
45585 ELSEIF (MUPDA.EQ.2) THEN
45586 C...Check if DECAY for this KF already read
45587 IF (KFORIG.NE.0) THEN
45588 DO 140 IDEC=1,NDECAY
45589 IF (KFORIG.EQ.KFDEC(IDEC)) THEN
45598 DO 150 KC=1,MSTU(6)
45599 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
45600 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
45602 ELSEIF (MUPDA.EQ.5) THEN
45603 C...Zero block read flags
45610 C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
45611 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
45612 C...Initialize program and version strings
45613 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
45618 C...Initialize read loop
45622 C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
45624 READ(LFN,'(A120)',END=400) CHINL
45625 C...Count which line number we're at.
45627 WRITE(CHNLIN,'(I6)') NLINE
45629 C...Skip comment and empty lines without processing.
45630 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
45632 C...We assume all upper case below. Rewrite CHINL to all upper case.
45636 IF (CHINL(INL:INL).NE.'#') THEN
45638 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
45640 C...Extra safety. Chek for sensible input on line
45641 IF (IGOOD.EQ.0) THEN
45643 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
45646 IF (INL.LT.120) GOTO 180
45648 IF (IGOOD.EQ.0) GOTO 170
45650 C...If reading from LHEF file, skip until <slha> begin tag found
45651 IF (ISKIP.NE.0) THEN
45653 IF (CHINL(I1:I1+4).EQ.'<SLHA') ISKIP=0
45655 IF (ISKIP.NE.0) GOTO 170
45658 C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
45660 IF (CHINL(I1:I1+5).EQ.'</SLHA'
45661 & .OR.CHINL(I1:I1+5).EQ.'<EVENT'
45662 & .OR.CHINL(I1:I1+4).EQ.'<INIT') THEN
45668 C...Check for BLOCK begin statement (spectrum).
45669 IF (CHINL(1:5).EQ.'BLOCK') THEN
45671 READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
45672 C...Check if another of this type of block was already read.
45673 C...(logarithmic interpolation not yet implemented, so duplicates always
45675 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
45676 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
45677 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
45678 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
45679 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
45680 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
45681 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
45682 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
45683 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
45684 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
45685 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
45686 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
45687 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
45688 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
45689 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
45690 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
45691 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
45692 C...Check for new particles
45693 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
45695 MSPC(19)=MSPC(19)+1
45697 READ(CHBLCK(9:60),*) KFQ
45700 IF (KQNUM(MQ,0).EQ.KFQ) THEN
45705 IF (NHELLO.EQ.0) THEN
45706 WRITE(MSTU(11),5000) DOC
45709 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45710 & ' * (PYSLHA:) Reading '//CHBLCK(1:8)//
45714 MSPC(19)=MSPC(19)+1
45716 C...Only read in new codes (also OK to overwrite if KF > 3000000)
45717 IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
45719 DO 230 KCT=100,MSTU(6)
45720 IF(KCHG(KCT,4).GT.100) KCQ=KCT
45726 C...First write PDG code as name
45728 WRITE(CHTMP,'(A)') CHTMP(2:10)
45729 C...Then look for real name
45732 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
45734 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
45737 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
45738 IF (IEND.LT.59) THEN
45739 READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
45740 IF (CHDUM.NE.' ') CHTMP=CHDUM
45742 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
45744 C...Set stable for now
45752 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
45753 & CHAF(KCQ,1), '. Entry ignored.'
45757 C...Finalize this line and read next.
45759 C...Check for DECAY begin statement (decays).
45760 ELSEIF (CHINL(1:3).EQ.'DEC') THEN
45764 C...Read KF code and WIDTH
45766 READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
45771 C...If this is not the KF we're looking for...
45772 IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
45773 C...Set block skip flag and read next line.
45777 C...Check whether decay table for this particle already read in
45778 DO 280 IDECAY=1,NDECAY
45779 IF (KFDEC(IDECAY).EQ.KF) THEN
45780 WRITE(MSTU(11),'(A,A,I9,A,A6,A)')
45781 & ' * (PYSLHA:) Ignoring DECAY table ',
45782 & 'for KF =',KF,' on line ',CHNLIN,
45790 C...Determine PYTHIA KC code of particle
45796 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
45800 IF (KCREP.NE.0) THEN
45801 C...Particle is already known. Do not overwrite low-mass SM particles,
45802 C...since this could give problems at hadronization / hadron decay stage.
45803 IF (IABS(KF).LT.1000000.AND.PMAS(KC,1).LT.20D0) THEN
45804 C...Set block skip flag and read next line
45805 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45806 & ' * (PYSLHA:) Ignoring DECAY table for KF =',
45807 & KF, ' (SLHA read-in not allowed)'
45812 C... Add new particle. Actually, this should not happen.
45813 C... New particles should be added already when reading the spectrum
45814 C... information, so go under previously stable category.
45819 IF (WIDTH.LE.0D0) THEN
45820 C...Stable (i.e. LSP)
45821 WRITE(MSTU(11),'(A,I9,A,A)')
45822 & ' * (PYSLHA:) Reading SLHA stable particle KF =',
45823 & KF,', ',CHAF(KCREP,1)(1:16)
45824 IF (WIDTH.LT.0D0) THEN
45825 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
45832 C...Ignore any decay lines that may be present for this KF
45839 C...Finalize and start reading in decay modes.
45841 ELSEIF (MOD(MERR,10).GE.6) THEN
45842 C...If ignore block flag set, skip directly to next line.
45847 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
45848 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
45850 READ(CHINL,*) INDX, IVAL
45851 IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
45852 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
45853 IF (INDX.EQ.3) KCHG(KCQ,2)=0
45854 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
45855 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
45856 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
45857 IF (INDX.EQ.4) THEN
45859 IF (IVAL.EQ.1) THEN
45861 IF (CHTMP.EQ.' ') THEN
45862 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
45863 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
45867 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
45868 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
45869 CHTMP(ILAST:ILAST)='-'
45871 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
45880 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
45881 C...MASS: Mass spectrum
45882 IF (CHBLCK(1:4).EQ.'MASS') THEN
45883 READ(CHINL,*) KF, VAL
45886 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
45887 C...Read in masses for almost anything
45891 C...Don't read in masses for special code particles
45892 IF (IABS(KF).GE.80.AND.IABS(KF).LT.100) THEN
45893 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45894 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45895 & KF, ' (KF reserved by PYTHIA)'
45898 C...Be careful with light SM particles / hadrons
45899 IF (PMAS(KC,1).LE.20D0) THEN
45900 IF (IABS(KF).LE.22) THEN
45901 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45902 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45903 & KF, ' (SLHA read-in not allowed)'
45906 ELSEIF (IABS(KF).GE.100.AND.IABS(KF).LT.1000000) THEN
45907 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45908 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45909 & KF, ' (SLHA read-in not allowed)'
45914 PMAS(KC,1) = ABS(VAL)
45915 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
45916 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45917 & ' * (PYSLHA:) Reading MASS entry for KF =',
45918 & KF, ', pole mass =', VAL
45921 C...Check Z, W and top masses
45922 IF (KF.EQ.23.AND.ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0)
45924 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45925 CALL PYERRM(9,'(PYSLHA:) Note Z boson mass, M ='
45928 IF (KF.EQ.24.AND.ABS(PMAS(PYCOMP(24),1)-80.4D0).GT.1D0)
45930 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45931 CALL PYERRM(9,'(PYSLHA:) Note W boson mass, M ='
45934 IF (KF.EQ.6.AND.ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0)
45936 WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
45937 CALL PYERRM(9,'(PYSLHA:) Note top quark mass, M ='
45941 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
45942 IF (KF.EQ.1000022) SMZ(1)=VAL
45943 IF (KF.EQ.1000023) SMZ(2)=VAL
45944 IF (KF.EQ.1000025) SMZ(3)=VAL
45945 IF (KF.EQ.1000035) SMZ(4)=VAL
45946 IF (KF.EQ.1000024) SMW(1)=VAL
45947 IF (KF.EQ.1000037) SMW(2)=VAL
45949 ELSEIF (MUPDA.EQ.5) THEN
45952 C... MODSEL: Model selection and global switches
45953 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
45954 READ(CHINL,*) INDX, IVAL
45955 IF (INDX.LE.200.AND.INDX.GT.0) THEN
45956 IF (IMSS(1).EQ.0) IMSS(1)=11
45959 IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
45960 C... Switch on NMSSM
45961 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
45962 IMSS(13)=MAX(1,IMSS(13))
45963 C... Add NMSSM states if not already done
45993 DO 310 KCT=100,MSTU(6)
45994 IF(KCHG(KCT,4).GT.100) KCN=KCT
46000 C... Set stable for now
46006 CHAF(KCN,1)='~chi_50'
46012 ELSEIF (MUPDA.EQ.5) THEN
46013 C...If MUPDA = 5, skip all except MASS, return if MODSEL
46015 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
46016 & CHBLCK(1:8).EQ.'PARTICLE') THEN
46017 C...Don't print a warning for QNUMBERS when reading spectrum
46019 C...MINPAR: Minimal model parameters
46020 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
46021 READ(CHINL,*) INDX, VAL
46022 IF (INDX.LE.100.AND.INDX.GT.0) THEN
46028 IF (MMOD(3).NE.0) THEN
46030 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
46034 IF (INDX.EQ.3) RMSS(5)=VAL
46035 C...EXTPAR: non-minimal model parameters.
46036 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
46037 IF (MMOD(1).NE.0) THEN
46038 READ(CHINL,*) INDX, VAL
46039 IF (INDX.LE.200.AND.INDX.GT.0) THEN
46047 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
46051 IF (INDX.EQ.25) RMSS(5)=VAL
46052 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
46053 READ(CHINL,*) INDX, VAL
46054 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
46056 ELSEIF (INDX.EQ.4) THEN
46057 PMAS(PYCOMP(23),1)=VAL
46058 ELSEIF (INDX.EQ.6) THEN
46059 PMAS(PYCOMP(6),1)=VAL
46061 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
46062 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
46063 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
46065 C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
46067 IF (CHBLCK(5:6).EQ.'IM') IM=1
46068 320 READ(CHINL,*) INDX1, INDX2, VAL
46069 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
46070 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
46071 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
46073 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
46074 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
46075 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
46077 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
46078 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
46079 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
46081 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
46082 $ .CHBLCK(1:4).EQ.'STAU') THEN
46083 IF (CHBLCK(1:4).EQ.'STOP') THEN
46086 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
46089 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
46093 C...Set SFMIX element
46094 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
46095 MSPC(ISPC)=MSPC(ISPC)+1
46097 C...Running parameters
46098 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
46099 READ(CHBLCK(8:25),*,ERR=620) Q
46100 READ(CHINL,*) INDX, VAL
46102 IF (INDX.EQ.1) THEN
46108 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
46109 READ(CHINL,*,ERR=630) VAL
46111 MSPC(17)=MSPC(17)+1
46112 C...Higgs parameters set manually or with FeynHiggs.
46113 IMSS(4)=MAX(2,IMSS(4))
46114 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
46115 & .CHBLCK(1:2).EQ.'AE') THEN
46116 READ(CHBLCK(9:26),*,ERR=620) Q
46117 READ(CHINL,*) INDX1, INDX2, VAL
46118 IF (CHBLCK(2:2).EQ.'U') THEN
46119 AU(INDX1,INDX2)=VAL
46120 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
46121 MSPC(11)=MSPC(11)+1
46122 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
46123 AD(INDX1,INDX2)=VAL
46124 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
46125 MSPC(10)=MSPC(10)+1
46126 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
46127 AE(INDX1,INDX2)=VAL
46128 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
46129 MSPC(12)=MSPC(12)+1
46133 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
46134 IF (MSPC(18).EQ.0) THEN
46135 READ(CHBLCK(9:25),*,ERR=620) Q
46138 READ(CHINL,*) INDX, VAL
46140 MSPC(18)=MSPC(18)+1
46141 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
46143 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
46144 & .CHBLCK(1:2).EQ.'YE') THEN
46146 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
46147 READ(CHINL(1:6),*) INDX
46151 IF (CHINL(IT:IT).EQ.' ') GOTO 330
46152 C...Don't read index
46153 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
46157 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
46158 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
46160 C... Set unrecognized block flag.
46165 C...Read in decay information
46166 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
46167 C...Read new decay chanel
46168 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
46170 C...Read in branching ratio and number of daughters for this mode.
46171 READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
46172 READ(CHINL(4:50),*,ERR=600) DUM, NDA
46174 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
46175 & '(PYSLHA:) Decay data arrays full by KF = '
46177 C...If first decay channel, set decays start point in decay table
46178 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
46179 IF (KFORIG.EQ.0) WRITE(MSTU(11),'(1x,A,I9,A,A16)')
46180 & '* (PYSLHA:) Reading DECAY table for '//
46181 & 'KF =',KF,', ',CHAF(KCREP,1)(1:16)
46182 C...Set particle parameters (mass set when reading BLOCK MASS above)
46184 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
46185 WRITE(MSTU(11),'(1x,A)')
46186 & '* Note: the Pythia gg->h/H/A cross section'//
46187 & ' is proportional to the h/H/A->gg width'
46188 ELSEIF (KF.EQ.23.OR.KF.EQ.24.OR.KF.EQ.6.OR.KF.EQ.32
46189 & .OR.KF.EQ.33.OR.KF.EQ.34) THEN
46190 WRITE(MSTU(11),'(1x,A,A16)')
46191 & '* Warning: will use DECAY table (fixed-width,'//
46192 & ' flat PS) for ',CHAF(KC,1)(1:16)
46195 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
46200 C...Add to list of DECAY blocks currently read
46206 C... Count up number of decay modes for this particle
46207 MDCY(KC,3)=MDCY(KC,3)+1
46208 C... Read in decay daughters.
46209 READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
46210 C... Flip sign if reading antiparticle decays (if antipartner exists)
46212 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
46213 & IDC(IDA)=MPSIGN*IDC(IDA)
46215 C...Switch on decay channel, with products ordered in decreasing ABS(KF)
46217 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
46218 BRSUM=BRSUM+ABS(BRAT(NDC))
46219 BRAT(NDC)=ABS(BRAT(NDC))
46222 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
46224 IDC(IDA)=IDC(IDA+1)
46229 IF (IFLIP.GT.0) GOTO 350
46230 C...Treat as ordinary decay, no fancy stuff.
46233 IF (IDA.LE.NDA) THEN
46234 KFDP(NDC,IDA)=IDC(IDA)
46239 C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
46240 C & (KFDP(NDC,J),J=1,NDA)
46242 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '//
46247 ELSEIF(CHINL(1:1).EQ.'+') THEN
46249 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
46256 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
46257 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
46260 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
46261 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
46262 & CHBLCK(1:MIN(INL,40))//'... on line '//CHNLIN
46263 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
46264 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
46265 & //CHBLCK(1:INL)//'... on line'//CHNLIN
46266 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
46267 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
46268 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
46269 & //'... on line'//CHNLIN
46270 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
46271 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
46272 & /CHBLCK(1:INL)//'... on line'//CHNLIN
46273 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
46276 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
46277 & CHTMP(1:9)//' on line'//CHNLIN
46279 C...Iterate read loop
46282 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
46283 & ', ignoring subsequent lines.'
46284 WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
46287 C...End of read loop
46289 C...Set flag that KC codes have been rearranged.
46293 C...Perform possible tests that new information is consistent.
46294 IF (MUPDA.EQ.1) THEN
46300 C...Don't complain about right-handed neutrinos
46301 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
46303 C...Only check gravitino in GMSB scenarios
46304 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
46306 IF (PMAS(KC,1).EQ.0D0) THEN
46309 & ,'(PYSLHA:) No mass information found for KF ='
46313 C...Check mixing matrices (MSSM only)
46314 IF (IMSS(13).EQ.0) THEN
46315 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
46316 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
46317 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
46318 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
46319 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
46320 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
46321 IF (MSPC(5).NE.4) CALL PYERRM(9
46322 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
46323 IF (MSPC(6).NE.4) CALL PYERRM(9
46324 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
46325 IF (MSPC(7).NE.4) CALL PYERRM(9
46326 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
46327 IF (MSPC(8).LT.1) CALL PYERRM(9
46328 & ,'(PYSLHA:) Too few elements in HMIX')
46329 IF (MSPC(10).EQ.0) CALL PYERRM(9
46330 & ,'(PYSLHA:) Missing A_b trilinear coupling')
46331 IF (MSPC(11).EQ.0) CALL PYERRM(9
46332 & ,'(PYSLHA:) Missing A_t trilinear coupling')
46333 IF (MSPC(12).EQ.0) CALL PYERRM(9
46334 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
46335 IF (MSPC(17).LT.1) CALL PYERRM(9
46336 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
46338 C...Check wavefunction normalizations.
46341 IF (MSPC(ISPC).EQ.4) THEN
46343 IF (ISPC.EQ.7) KFSM=15
46344 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
46346 IF (ABS(1D0-CHECK).GT.1D-3) THEN
46349 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
46352 C...Bug fix 30/09 2008: PS
46353 C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
46354 IF (SFMIX(KFSM,1)*SFMIX(KFSM,4).LT.0D0) THEN
46355 SFMIX(KFSM,3) = -SFMIX(KFSM,3)
46356 SFMIX(KFSM,4) = -SFMIX(KFSM,4)
46360 C...Neutralinos + charginos
46369 CN1=CN1+ZMIX(J,L)**2
46370 CN2=CN2+ZMIX(L,J)**2
46371 IF (J.LE.2.AND.L.LE.2) THEN
46372 CU1=CU1+UMIX(J,L)**2
46373 CU2=CU2+UMIX(L,J)**2
46374 CV1=CV1+VMIX(J,L)**2
46375 CV2=CV2+VMIX(L,J)**2
46378 C...NMIX normalization
46379 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
46380 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
46382 & '(PYSLHA:) NMIX: Inconsistent normalization.')
46383 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
46385 C...UMIX, VMIX normalizations
46386 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
46388 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
46390 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
46391 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
46394 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
46396 & '(PYSLHA:) VMIX: Inconsistent normalization.')
46397 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
46403 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
46404 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
46405 & '* (PYSLHA:) No spectrum inconsistencies were found.'
46407 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
46408 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
46409 & ,' Warning: one or more (serious)'//
46410 & ' inconsistencies were found in the spectrum !'
46411 & ,' Read the error messages above and check your'//
46414 C...Increase precision in Higgs sector using FeynHiggs
46415 IF (IMSS(4).EQ.3) THEN
46416 C...FeynHiggs needs MSOFT.
46418 IF (MSPC(18).EQ.0) THEN
46419 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
46420 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
46421 & ' Cannot call FeynHiggs.'
46424 WRITE(MSTU(11),'(1x,/1x,A/)')
46425 & '* (PYSLHA:) Now calling FeynHiggs.'
46427 IF (IERR.NE.0) IMSS(4)=2
46430 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
46432 IF (KFORIG.NE.0) IBEG=NDECAY
46433 DO 490 IDECAY=IBEG,NDECAY
46436 WRITE(CHKF,8300) KF
46437 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
46438 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
46439 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
46440 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
46444 DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46445 IF(MDME(IDA,2).GT.80) GOTO 460
46447 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
46451 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
46453 ELSEIF(PYCOMP(KP).EQ.0) THEN
46458 PMS=PMS-PMAS(KPC,1)
46459 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
46463 IF(KQ.NE.0) MERR=MAX(2,MERR)
46464 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
46466 IF(MERR.EQ.3) CALL PYERRM(17,
46467 & '(PYSLHA:) Unknown particle code in decay of KF ='
46469 IF(MERR.EQ.2) CALL PYERRM(17,
46470 & '(PYSLHA:) Charge not conserved in decay of KF ='
46472 IF(MERR.EQ.1) CALL PYERRM(7,
46473 & '(PYSLHA:) Kinematically unallowed decay of KF ='
46475 BRSUM=BRSUM+BRAT(IDA)
46476 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
46478 C...Check branching ratio sum.
46479 IF (BROPN.LE.0D0) THEN
46480 C...If zero, set stable.
46481 WRITE(CHTMP,8500) BROPN
46483 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
46484 & CHTMP(9:16)//'. Changed to stable.')
46487 C...If BR's > 1, rescale.
46488 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
46489 WRITE(CHTMP,8500) BRSUM
46490 IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
46491 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
46492 & ' ; sum was'//CHTMP(9:16)//'.')
46494 DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46495 IF(MDME(IDA,2).GT.80) GOTO 470
46496 BRAT(IDA)=FAC*BRAT(IDA)
46498 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
46499 C...If BR's < 1, insert dummy mode for proper cross section rescaling.
46500 WRITE(CHTMP,8500) BRSUM
46501 IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
46502 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
46503 & CHTMP(9:16)//'. Dummy mode will be inserted.')
46504 C...Move table and insert dummy mode
46505 DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46507 BRAT(NDC)=BRAT(IDA)
46508 KFDP(NDC,1)=KFDP(IDA,1)
46509 KFDP(NDC,2)=KFDP(IDA,2)
46510 KFDP(NDC,3)=KFDP(IDA,3)
46511 KFDP(NDC,4)=KFDP(IDA,4)
46512 KFDP(NDC,5)=KFDP(IDA,5)
46513 MDME(NDC,1)=MDME(IDA,1)
46516 BRAT(NDC)=1D0-BRSUM
46525 MDCY(KC,3)=MDCY(KC,3)+1
46526 MDCY(KC,2)=NDC-MDCY(KC,3)+1
46532 C...WRITE SPECTRUM ON SLHA FILE
46533 ELSEIF(MUPDA.EQ.3) THEN
46534 C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
46535 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
46540 PARMIN(4)=SIGN(1D0,RMSS(4))
46544 WRITE(LFN,7000) 'SLHA MSSM spectrum'
46545 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
46547 WRITE(LFN,7010) 'MODSEL', 'Model selection'
46548 WRITE(LFN,7110) 1, MODSEL(1)
46549 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
46550 IF (MODSEL(1).EQ.1) THEN
46551 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
46552 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
46553 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
46554 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
46555 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
46556 ELSEIF(MODSEL(2).EQ.2) THEN
46557 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
46558 WRITE(LFN,7210) 2, PARMIN(2), 'M'
46559 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
46560 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
46561 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
46562 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
46564 WRITE(LFN,7000) ' '
46565 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
46569 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
46571 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
46572 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
46573 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
46574 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
46575 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
46576 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
46577 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
46579 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
46583 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
46584 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
46585 WRITE(LFN,7210) 1, RMSS(4),'mu'
46586 WRITE(LFN,7010) 'ALPHA',' '
46587 WRITE(LFN,7210) 1, RMSS(18), 'alpha'
46588 WRITE(LFN,7020) 'AU',RMSUSY
46589 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
46590 WRITE(LFN,7020) 'AD',RMSUSY
46591 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
46592 WRITE(LFN,7020) 'AE',RMSUSY
46593 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
46594 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
46595 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
46596 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
46597 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
46598 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
46599 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
46600 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
46601 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
46602 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
46603 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
46604 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
46605 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
46606 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
46607 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
46608 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
46609 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
46612 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
46615 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
46618 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
46621 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
46624 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
46627 WRITE(LFN,7010) 'SPINFO'
46628 IF (IMSS(1).EQ.2) THEN
46631 ELSEIF (IMSS(1).EQ.12) THEN
46634 CVER(1)=ISAVER(1:12)
46636 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
46637 WRITE(LFN,7310) 2, CVER(1), 'Version number'
46640 C...Print user information about spectrum
46641 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
46642 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
46643 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
46644 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
46645 IF (MUPDA.EQ.1) THEN
46646 WRITE(MSTU(11),5020) LFN
46648 WRITE(MSTU(11),5010) LFN
46651 WRITE(MSTU(11),5400)
46652 WRITE(MSTU(11),5500) 'Pole masses'
46653 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
46654 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
46655 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
46656 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
46657 IF (IMSS(13).EQ.0) THEN
46658 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
46659 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
46660 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
46661 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
46662 & CHAF(37,1), ' ', ' ',' ',' ',
46663 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
46664 ELSEIF (IMSS(13).EQ.1) THEN
46673 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
46674 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
46675 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
46676 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
46677 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
46678 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
46679 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
46680 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
46681 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
46684 WRITE(MSTU(11),5400)
46685 WRITE(MSTU(11),5500) 'Mixing structure'
46686 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
46687 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
46688 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
46689 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
46690 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
46691 & ),(SFMIX(15,J),J=3,4)
46692 WRITE(MSTU(11),5400)
46693 WRITE(MSTU(11),5500) 'Couplings'
46694 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
46695 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
46696 WRITE(MSTU(11),5400)
46697 WRITE(MSTU(11),6500)
46701 C...Only rewind when reading
46702 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
46706 C...Serious error catching
46707 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
46708 write(*,*) CHINL(1:80)
46710 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
46711 WRITE(*,*) CHINL(1:72)
46713 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
46714 WRITE(*,*) CHINL(1:80)
46716 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
46717 WRITE(*,*) CHINL(1:80)
46718 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
46720 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
46721 WRITE(*,*) CHINL(1:80)
46727 C...Formats for user information printout.
46728 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.13: SUSY/BSM SPECTRUM '
46729 & ,'INTERFACE',1x,17('*')/1x,'*',1x
46730 & ,'(PYSLHA:) Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
46731 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
46732 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
46733 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
46734 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
46735 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
46736 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
46737 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
46738 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
46739 & ,'----------------')
46740 5400 FORMAT(1x,'*',1x,A)
46741 5500 FORMAT(1x,'*',1x,A,':')
46742 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
46743 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
46744 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
46745 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
46746 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
46747 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
46748 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
46749 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
46750 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
46751 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
46752 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
46753 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
46754 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
46755 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
46756 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
46757 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
46758 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
46759 & ,1x,F6.3,1x),'|')
46760 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
46761 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
46762 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
46763 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
46764 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
46765 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
46766 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
46767 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
46768 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
46769 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
46770 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
46771 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
46772 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
46773 & ,'A_tau = ',F8.2)
46774 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
46776 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
46778 C...Format to use for comments
46779 7000 FORMAT('# ',A)
46780 C...Format to use for block statements
46781 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
46782 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
46784 7110 FORMAT(1x,I4,1x,I4,3x,'#')
46785 C...Non-Indexed Double
46786 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
46788 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
46789 C...Long Indexed Double (PDG + double)
46790 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
46791 C...Indexed Char(12)
46792 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
46794 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
46796 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
46797 C...Write Decay Table
46798 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
46799 7510 FORMAT(4x,I5,1x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),
46805 C*********************************************************************
46808 C...Uses approximate analytical formulae to determine the full set of
46809 C...MSSM parameters from SUGRA input.
46810 C...See M. Drees and S.P. Martin, hep-ph/9504124
46814 C...Double precision and integer declarations.
46815 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46816 IMPLICIT INTEGER(I-N)
46817 INTEGER PYK,PYCHGE,PYCOMP
46818 C...Parameter statement to help give large particle numbers.
46819 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46820 &KEXCIT=4000000,KDIMEN=5000000)
46822 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46823 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46824 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46825 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
46827 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
46828 &' not intended for serious physics studies'
46841 C...Temporary sign change for AT. Others unchanged.
46845 SINB=TANB/SQRT(TANB**2+1D0)
46848 DTERM=XMZ2*COS(2D0*BETA)
46849 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
46850 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
46853 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
46854 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
46855 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
46856 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
46858 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
46859 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
46860 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
46861 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
46863 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
46864 IF(XARG.LT.0D0) THEN
46865 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
46866 & ' FROM THE SUM RULE. '
46867 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
46873 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
46874 PMAS(PYCOMP(KSUSY2+I),1)=XMER
46875 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
46876 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
46878 RMT=PYMRUN(6,PMAS(6,1)**2)
46879 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
46880 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
46881 RMB=PYMRUN(5,PMAS(6,1)**2)
46882 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
46883 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
46884 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
46885 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
46888 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
46889 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
46890 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
46891 XMU=SIGN(SQRT(XMU2),RMSS(4))
46893 IF(XMA2.GT.0D0) THEN
46894 RMSS(19)=SQRT(XMA2)
46896 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
46899 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
46900 IF(ARG.GT.0D0) THEN
46903 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
46906 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
46907 IF(ARG.GT.0D0) THEN
46910 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
46913 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
46914 IF(ARG.GT.0D0) THEN
46917 RMSS(10)=-SQRT(-ARG)
46919 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
46920 IF(ARG.GT.0D0) THEN
46923 RMSS(12)=-SQRT(-ARG)
46925 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
46926 IF(ARG.GT.0D0) THEN
46929 RMSS(11)=-SQRT(-ARG)
46935 C*********************************************************************
46938 C...Interface to ISASUSY version 7.71.
46939 C...Warning: this interface should not be used with earlier versions
46940 C...of ISASUSY, since common block incompatibilities may then arise.
46941 C...Calls SUGRA (in ISAJET) to perform RGE evolution.
46942 C...Then converts to Gunion-Haber conventions.
46945 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46947 INTEGER PYK,PYCHGE,PYCOMP
46948 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46949 &KEXCIT=4000000,KDIMEN=5000000)
46953 PARAMETER (DOC='01 May 2006')
46955 C...ISASUGRA Input:
46956 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
46957 C...XISAIN contains the MSSMi inputs in natural order.
46958 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
46960 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
46962 C...ISASUGRA Output
46963 CHARACTER*40 ISAVER,VISAJE
46965 COMMON /SSPAR/ SUPER(72)
46966 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
46967 $FBGUT,FTAGUT,FNGUT
46968 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
46969 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46970 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46971 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
46972 $VUMT,VDMT,ASMTP,ASMSS,M3Q
46973 REAL 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,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
46976 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
46978 SAVE /SUGMG/,/SSPAR/
46979 C SUPER: Filled by ISASUGRA.
46980 C SUPER(1) = mass of ~g
46981 C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
46982 C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
46983 C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
46985 C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
46986 C SUPER(29) = Higgsino mass = - mu
46987 C SUPER(30) = ratio v2/v1 of vev's
46988 C SUPER(31:34) = Signed neutralino masses
46989 C SUPER(35:50) = Neutralino mixing matrix
46990 C SUPER(51:52) = Signed chargino masses
46991 C SUPER(53:54) = Chargino left, right mixing angles
46992 C SUPER(55:58) = mass of h0, H0, A0, H+
46993 C SUPER(59) = Higgs mixing angle alpha
46994 C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
46995 C SUPER(66) = Gravitino mass
46996 C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
46997 C SUPER(70) = b-Yukawa at mA scale (not used)
46998 C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
46999 C GSS: Filled by ISASUGRA
47000 C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
47001 C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
47002 C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
47003 C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
47004 C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
47005 C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
47006 C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
47007 C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
47008 C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
47009 C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
47010 C GSS(31) = log(vuq)
47011 C MSS: Filled by ISASUGRA
47012 C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
47013 C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
47014 C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
47015 C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
47016 C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
47017 C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
47018 C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
47019 C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
47020 C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
47021 C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
47022 C MSS(31) = ha0 MSS(32) = h+
47023 C Unification, filled by ISASUGRA if applicable.
47024 C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
47026 C...SPYTHIA Input/Output
47028 DOUBLE PRECISION RMSS
47029 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47030 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47031 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47032 C...SLHA Input/Output
47033 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47034 & AU(3,3),AD(3,3),AE(3,3)
47035 C...PYTHIA common blocks
47036 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47037 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47038 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47040 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
47041 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47044 CHARACTER*20 CHMOD(5)
47047 COMMON /SUGNU/ XNUSUG(18)
47051 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
47052 & 'truly unified SUGRA', 'non-minimal GMSB'/
47054 C...Start by checking for incompatibilities/inconsistencies:
47056 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
47057 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
47058 & ,' option not used by PYSUGI'
47061 C...ISAJET works with REAL numbers.
47062 MZERO=REAL(RMSS(8))
47064 AZERO=REAL(RMSS(16))
47066 SGNMU=REAL(RMSS(4))
47067 MTOP=REAL(PMAS(6,1))
47069 IF (IMSS(1).EQ.12) THEN
47072 ELSEIF(IMSS(1).EQ.13) THEN
47073 C...Read from isajet par file in IMSS(20)
47075 C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
47077 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
47080 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
47081 CMrenna change to allow any susy model
47082 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
47083 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
47084 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
47085 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
47086 & ' gauge couplings:'
47087 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
47089 IF (IMODEL.EQ.4) THEN
47093 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
47094 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
47095 & //' sgn(mu), M_t:'
47096 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
47097 IF (IMODEL.EQ.3) THEN
47099 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
47100 & //' 0 to continue:'
47101 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
47102 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
47103 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
47104 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
47105 & //' generation masses'
47107 & ' NUSUG5 = GUT scale 3rd generation masses'
47109 IF (INUSUG.EQ.0) THEN
47111 ELSEIF (INUSUG.EQ.1) THEN
47112 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
47113 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
47114 IF (XNUSUG(3).LE.0.) THEN
47115 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
47118 ELSEIF (INUSUG.EQ.2) THEN
47119 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
47120 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
47121 ELSEIF (INUSUG.EQ.3) THEN
47122 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
47123 READ(LFN,*) XNUSUG(7),XNUSUG(8)
47124 ELSEIF (INUSUG.EQ.4) THEN
47125 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
47126 & //' M(ur), M(el), M(er):'
47127 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
47128 & XNUSUG(10),XNUSUG(9)
47129 ELSEIF (INUSUG.EQ.5) THEN
47130 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
47131 & //' M(Ll), M(Lr):'
47132 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
47133 & XNUSUG(15),XNUSUG(14)
47137 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
47139 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
47140 & ,' sgn(mu), M_t, C_gv:'
47141 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
47144 C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
47146 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
47147 IF (IMODEL.EQ.5) THEN
47149 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
47150 & ,' masses at M_mes'
47151 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
47152 & ,' shifts at M_mes'
47153 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
47155 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
47157 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
47159 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
47160 $ XGMIN(13),XGMIN(14)
47163 WRITE(MSTU(11),*) 'Invalid model choice.'
47171 C TANB=REAL(RMSS(5))
47172 C SGNMU=REAL(RMSS(4))
47175 C...Initialize MSSM parameter array
47176 130 DO 140 IPAR=1,72
47180 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
47181 C...Check whether ISASUSY thought the model was OK.
47182 IF (NOGOOD.NE.0) THEN
47183 IF (NOGOOD.EQ.1) CALL PYERRM(26
47184 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
47185 IF (NOGOOD.EQ.2) CALL PYERRM(26
47186 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
47187 IF (NOGOOD.EQ.3) CALL PYERRM(26
47188 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
47189 IF (NOGOOD.EQ.4) CALL PYERRM(26
47190 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
47191 IF (NOGOOD.EQ.7) CALL PYERRM(26
47192 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
47193 IF (NOGOOD.EQ.8) CALL PYERRM(26
47194 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
47195 C...Give warning, but don't stop, if LSP not ~chi_10.
47196 IF (NOGOOD.EQ.5) CALL PYERRM(16
47197 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
47199 C...Warn about possible GUT scale tachyons.
47200 IF (ITACHY.NE.0) CALL PYERRM(16,
47201 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
47202 C...Finalize spectrum (last iteration)
47203 C...(Thanks to A. Raklev for pointing this out.)
47204 C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
47205 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
47206 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
47207 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
47208 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
47209 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
47213 RMSS(1)=dble(GSS(7))
47214 RMSS(2)=dble(GSS(8))
47215 RMSS(3)=dble(GSS(9))
47216 RMSOFT(1)=dble(GSS(7))
47217 RMSOFT(2)=dble(GSS(8))
47218 RMSOFT(3)=dble(GSS(9))
47219 C...Mu = - Higgsino mass.
47222 C...Slepton and squark masses. 2 first generations.
47223 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
47224 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
47225 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
47226 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
47227 C...Third generation.
47228 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
47233 C...SLHA: store exact soft spectrum in RMSOFT
47234 RMSOFT(31)=SUPER(18)
47235 RMSOFT(32)=SUPER(20)
47236 RMSOFT(33)=SUPER(22)
47237 RMSOFT(34)=SUPER(19)
47238 RMSOFT(35)=SUPER(21)
47239 RMSOFT(36)=SUPER(23)
47240 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
47241 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
47242 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
47243 RMSOFT(44)=SUPER(3)
47244 RMSOFT(45)=SUPER(9)
47245 RMSOFT(46)=SUPER(15)
47246 RMSOFT(47)=SUPER(5)
47247 RMSOFT(48)=SUPER(7)
47248 RMSOFT(49)=SUPER(11)
47250 C...~b, ~t, and ~tau trilinear couplings and mixing angles.
47257 C...SLHA trilinears
47268 C...Higgs mixing angle alpha (Gunion-Haber convention).
47269 RMSS(18)=-SUPER(59)
47272 C...GUT scale coupling
47274 C...Gravitino mass (for future compatibility)
47275 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
47277 C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
47279 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
47280 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
47281 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
47282 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
47284 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
47285 C...Squarks and Sleptons.
47288 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
47289 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
47290 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
47291 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
47292 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
47293 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
47294 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
47295 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
47296 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
47298 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
47299 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
47300 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
47302 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
47303 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
47304 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
47305 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
47306 C...Signed masses (extra minus from going to G-H convention).
47312 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
47313 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
47314 C...Signed masses (extra minus from going to G-H convention).
47318 C... Neutralino Mixing.
47320 ZMIX(IN,1)= SUPER(38+4*(IN-1))
47321 ZMIX(IN,2)= SUPER(37+4*(IN-1))
47322 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
47323 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
47325 C...Chargino Mixing (PYTHIA same angle as HERWIG).
47328 IF (SUPER(53).GT.0) THX=-1D0
47329 IF (SUPER(54).GT.0) THY=-1D0
47330 UMIX(1,1) = -SIN(SUPER(53))
47331 UMIX(1,2) = -COS(SUPER(53))
47332 UMIX(2,1) = -THX*COS(SUPER(53))
47333 UMIX(2,2) = THX*SIN(SUPER(53))
47334 VMIX(1,1) = -SIN(SUPER(54))
47335 VMIX(1,2) = -COS(SUPER(54))
47336 VMIX(2,1) = -THY*COS(SUPER(54))
47337 VMIX(2,2) = THY*SIN(SUPER(54))
47338 C...Sfermion mixing (PYTHIA same angle as ISAJET)
47339 SFMIX(5,1)=COS(SUPER(63))
47340 SFMIX(5,2)=SIN(SUPER(63))
47341 SFMIX(5,3)=-SIN(SUPER(63))
47342 SFMIX(5,4)=COS(SUPER(63))
47343 SFMIX(6,1)=COS(SUPER(61))
47344 SFMIX(6,2)=SIN(SUPER(61))
47345 SFMIX(6,3)=-SIN(SUPER(61))
47346 SFMIX(6,4)=COS(SUPER(61))
47347 SFMIX(15,1)=COS(SUPER(65))
47348 SFMIX(15,2)=SIN(SUPER(65))
47349 SFMIX(15,3)=-SIN(SUPER(65))
47350 SFMIX(15,4)=COS(SUPER(65))
47352 IF (MSTP(122).NE.0) THEN
47353 C...Print a few lines to make the user know what's happening
47355 WRITE(MSTU(11),5000) DOC, ISAVER
47356 WRITE(MSTU(11),5100)
47357 IF (IMODEL.EQ.1) THEN
47358 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
47360 WRITE(MSTU(11),5300)
47362 WRITE(MSTU(11),5500) 'Pole masses'
47363 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
47364 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
47365 & ,(SUPER(IP),IP=19,25,2)
47366 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
47368 WRITE(MSTU(11),5400)
47369 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
47370 WRITE(MSTU(11),5400)
47371 WRITE(MSTU(11),5500) 'EW scale mixing structure'
47372 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
47373 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
47374 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
47375 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
47376 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
47377 & ),(SFMIX(15,J),J=3,4)
47378 WRITE(MSTU(11),5400)
47379 WRITE(MSTU(11),6450) RMSS(18)
47380 WRITE(MSTU(11),5400)
47381 WRITE(MSTU(11),5500) 'Couplings'
47382 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
47383 WRITE(MSTU(11),5400)
47386 C...Call FeynHiggs to improve Higgs sector if requested
47387 IF (IMSS(4).EQ.3) THEN
47388 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
47389 & ' (PYSUGI:) Now calling FeynHiggs.'
47391 IF (IERR.EQ.0) THEN
47393 IF (MSTP(122).NE.0) THEN
47394 WRITE(MSTU(11),5400)
47395 WRITE(MSTU(11),5500)
47396 & 'Corrected Higgs masses and mixing'
47397 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
47399 WRITE(MSTU(11),6450) RMSS(18)
47400 WRITE(MSTU(11),5400)
47405 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
47407 C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
47408 C...output by ISASUSY.
47409 IMSS(4)=MAX(2,IMSS(4))
47411 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
47412 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
47413 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
47414 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
47415 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
47416 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
47417 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
47418 & ,'----------------')
47419 5400 FORMAT(1x,'*',1x,A)
47420 5500 FORMAT(1x,'*',1x,A,':')
47421 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
47422 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
47423 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
47424 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
47425 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
47427 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
47428 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
47429 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
47431 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
47432 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
47433 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
47434 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47435 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
47436 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47437 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
47438 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
47439 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
47440 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
47441 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
47442 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
47443 & ,1x,F6.3,1x),'|')
47444 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
47445 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
47446 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
47447 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
47448 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
47449 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
47450 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
47451 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
47452 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
47453 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
47454 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
47455 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
47456 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
47457 & ,4x,'Alpha_GUT = ',F8.2)
47458 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
47459 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
47464 C*********************************************************************
47467 C...Interface to FeynHiggs for MSSM Higgs sector.
47468 C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
47471 SUBROUTINE PYFEYN(IERR)
47473 C...Double precision and integer declarations.
47474 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47475 IMPLICIT INTEGER(I-N)
47476 INTEGER PYK,PYCHGE,PYCOMP
47478 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47479 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47481 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47482 C...FeynHiggs variables
47483 DOUBLE PRECISION RMHIGG(4)
47484 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
47485 DOUBLE COMPLEX DMU,
47486 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47488 C...SLHA Common Block
47489 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47490 & AU(3,3),AD(3,3),AE(3,3)
47491 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
47494 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
47495 IF (IERR.NE.0) THEN
47496 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
47497 & //'Will not use FeynHiggs for this run.')
47535 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
47536 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
47537 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
47538 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
47539 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47540 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
47541 IF (IERR.NE.0) THEN
47542 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
47543 & //' Will not use FeynHiggs for this run.')
47546 C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
47548 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
47549 IF (IERR.NE.0) THEN
47550 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
47551 & 'GSCORR. Will not use FeynHiggs for this run.')
47554 ALPHA = ASIN(DBLE(SAEFF))
47556 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
47557 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
47558 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
47559 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
47561 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
47562 & 1.15D0*PMAS(25,1)) THEN
47563 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
47564 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
47565 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
47568 PMAS(25,1)=RMHIGG(1)
47569 PMAS(35,1)=RMHIGG(2)
47570 PMAS(36,1)=RMHIGG(3)
47571 PMAS(37,1)=RMHIGG(4)
47576 C*********************************************************************
47579 C...Determines the running mass of Squarks.
47581 FUNCTION PYRNMQ(ID,DTERM)
47583 C...Double precision and integer declarations.
47584 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47585 IMPLICIT INTEGER(I-N)
47586 INTEGER PYK,PYCHGE,PYCOMP
47588 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47591 C...Local variables.
47592 DOUBLE PRECISION PI,R
47593 DOUBLE PRECISION TOL
47594 DOUBLE PRECISION CI(3)
47596 DOUBLE PRECISION PYALPS
47598 DATA PI,R/3.141592654D0,.61803399D0/
47599 DATA CI/0.47D0,0.07D0,0.02D0/
47603 AG=(0.71D0)**2/4D0/PI
47610 AS=PYALPS(XM02+6D0*XMG2)
47611 CG=8D0/9D0*((AS/AG)**2-1D0)
47612 BX=XM02+(CA+CG)*XMG2+DTERM
47613 AX=MIN(50D0**2,0.5D0*BX)
47614 CX=MAX(2000D0**2,2D0*BX)
47618 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
47626 CG=8D0/9D0*((AS1/AG)**2-1D0)
47627 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
47629 CG=8D0/9D0*((AS2/AG)**2-1D0)
47630 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
47631 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
47638 CG=8D0/9D0*((AS2/AG)**2-1D0)
47639 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
47646 CG=8D0/9D0*((AS1/AG)**2-1D0)
47647 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
47662 C*********************************************************************
47665 C...Calculates the mass eigenstates of the third generation sfermions.
47666 C...Created: 5-31-96
47670 C...Double precision and integer declarations.
47671 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47672 IMPLICIT INTEGER(I-N)
47673 INTEGER PYK,PYCHGE,PYCOMP
47674 C...Parameter statement to help give large particle numbers.
47675 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47676 &KEXCIT=4000000,KDIMEN=5000000)
47678 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47679 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47680 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47681 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47682 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47683 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47685 C...Local variables.
47686 DOUBLE PRECISION BETA
47687 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
47688 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
47689 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
47690 DOUBLE PRECISION ATR,AMQR,AMQL
47691 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
47692 INTEGER IF,I,J,II,JJ,IT,L
47706 COS2B=COS(2D0*BETA)
47708 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
47718 XMQL2=CTT2*XM12+STT2*XM22
47719 XMQR2=STT2*XM12+CTT2*XM22
47720 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
47721 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47723 C......SUBTRACT OUT D-TERM AND FERMION MASS
47724 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
47725 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
47726 IF(XMQL2.GE.0D0) THEN
47727 RMSS(10)=SQRT(XMQL2)
47729 RMSS(10)=-SQRT(-XMQL2)
47731 IF(XMQR2.GE.0D0) THEN
47732 RMSS(12)=SQRT(XMQR2)
47734 RMSS(12)=-SQRT(-XMQR2)
47737 C SAME FOR BOTTOM SQUARK
47743 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
47744 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
47745 IF(ABS(CTT).GE..9999D0) THEN
47748 ELSEIF(ABS(CTT).LE.1D-4) THEN
47752 XM12=(XMQL2-STT2*XM22)/CTT2
47753 XMQR2=STT2*XM12+CTT2*XM22
47754 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47757 C......SUBTRACT OUT D-TERM AND FERMION MASS
47758 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
47759 IF(XMQR2.GE.0D0) THEN
47760 RMSS(11)=SQRT(XMQR2)
47762 RMSS(11)=-SQRT(-XMQR2)
47764 C SAME FOR TAU SLEPTON
47771 XMQL2=CTT2*XM12+STT2*XM22
47772 XMQR2=STT2*XM12+CTT2*XM22
47775 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47777 C......SUBTRACT OUT D-TERM AND FERMION MASS
47778 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
47779 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
47780 IF(XMQL2.GE.0D0) THEN
47781 RMSS(13)=SQRT(XMQL2)
47783 RMSS(13)=-SQRT(-XMQL2)
47785 IF(XMQR2.GE.0D0) THEN
47786 RMSS(14)=SQRT(XMQR2)
47788 RMSS(14)=-SQRT(-XMQR2)
47793 IF(AMQL.LT.0D0) THEN
47800 IF(AMQR.LT.0D0) THEN
47806 XMF=PYMRUN(IF,PMAS(6,1)**2)
47808 AM2(1,1)=XMQL2+XMF2
47809 AM2(2,2)=XMQR2+XMF2
47810 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
47813 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
47814 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
47815 AM2(1,2)=XMF*(ATR+XMU*TANB)
47816 ELSEIF(L.EQ.2) THEN
47817 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
47818 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
47819 AM2(1,2)=XMF*(ATR+XMU/TANB)
47820 ELSEIF(L.EQ.3) THEN
47821 IF(IMSS(8).EQ.1) THEN
47822 AM2(1,1)=RMSS(6)**2
47823 AM2(2,2)=RMSS(7)**2
47828 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
47829 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
47830 AM2(1,2)=XMF*(ATR+XMU*TANB)
47835 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
47836 IF(DETM.LT.0D0) THEN
47837 WRITE(MSTU(11),*) ID2(L),DETM,AM2
47838 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
47840 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
47841 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
47845 IF(XMF22-XMF12.GT.0D0) THEN
47846 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
47848 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
47849 & AM2(1,2)/(XMF22-XMF12))
47865 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
47871 IF(DI(1,1).GT.DI(2,2)) THEN
47872 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
47873 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
47874 WRITE(MSTU(11),*) AM2
47875 WRITE(MSTU(11),*) DI
47876 WRITE(MSTU(11),*) RT
47887 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
47888 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
47889 & ' OFF DIAGONAL ELEMENTS '
47890 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
47891 WRITE(MSTU(11),*) DI
47892 WRITE(MSTU(11),*) ' ROTATION = ',RT
47894 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
47895 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
47896 & ' NEGATIVE MASSES '
47899 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
47900 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
47901 SFMIX(IF,1)=RT(1,1)
47902 SFMIX(IF,2)=RT(1,2)
47903 SFMIX(IF,3)=RT(2,1)
47904 SFMIX(IF,4)=RT(2,2)
47907 C.....TAU SNEUTRINO MASS...L=3
47909 XARG=AM2(1,1)+XMW2*COS2B
47910 IF(XARG.LT.0D0) THEN
47911 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
47912 & ' FROM THE SUM RULE. '
47913 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
47916 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
47921 C*********************************************************************
47924 C...Finds the mass eigenstates and mixing matrices for neutralinos
47929 C...Double precision and integer declarations.
47930 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47931 IMPLICIT INTEGER(I-N)
47933 C...Parameter statement to help give large particle numbers.
47934 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47935 &KEXCIT=4000000,KDIMEN=5000000)
47937 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47938 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47939 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47940 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47941 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47942 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47944 C...Local variables.
47945 DOUBLE PRECISION XMW,XMZ,XM(4)
47946 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
47947 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
47948 DOUBLE PRECISION COSW,SINW
47949 DOUBLE PRECISION XMU
47950 DOUBLE PRECISION TANB,COSB,SINB
47951 DOUBLE PRECISION XM1,XM2,XM3,BETA
47952 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
47953 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
47954 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
47955 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
47956 DOUBLE PRECISION PYALPS,PYALEM
47957 DOUBLE PRECISION PYRNM3
47958 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
47959 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
47960 DATA KFNCHI/1000022,1000023,1000025,1000035/
47963 IF(IMSS(1).EQ.2) THEN
47966 C...M1, M2, AND M3 ARE INDEPENDENT
47971 ELSEIF(IOPT.GE.1) THEN
47975 A1=AEM/(1D0-PARU(102))
47978 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
47980 XM2=XM1*A2/A1*3D0/5D0
47982 ELSEIF(IOPT.EQ.3) THEN
47983 XM1=XM2*5D0/3D0*A1/A2
47988 IF(XM3.LE.0D0) THEN
47989 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
47995 IF(IMSS(3).EQ.1) THEN
47996 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
48001 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48002 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
48003 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
48009 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48010 RM2=PMAS(I,1)**2/XM3**2
48011 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
48012 IF(ARG.GE.0D0) THEN
48013 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
48015 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
48020 ELSEIF(X0.EQ.0D0) THEN
48024 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
48025 & 0.5D0*X0**2*LOG(AX0)
48026 BT=(-1D0-2D0*X0)/4D0
48031 ELSEIF(X1.EQ.0D0) THEN
48035 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
48036 & X1**2*LOG(AX1)+AT
48037 BT=(-1D0-2D0*X1)/4D0+BT
48041 X0=0.5D0*(1D0+RM2-RM1)
48042 Y0=-0.5D0*SQRT(-ARG)
48043 AMGX0=SQRT(X0**2+Y0**2)
48044 AM1X0=SQRT((1D0-X0)**2+Y0**2)
48045 ARGX0=ATAN2(-X0,-Y0)
48046 AR1X0=ATAN2(1D0-X0,Y0)
48051 ARGX1=ATAN2(-X1,-Y1)
48052 AR1X1=ATAN2(1D0-X1,Y1)
48053 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
48054 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
48055 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
48056 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
48057 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
48058 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
48063 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
48064 & /(2D0*PARU(2))*(15D0+AQ))
48067 C...NEUTRALINO MASSES
48073 XMZ=PMAS(23,1)/100D0
48074 XMW=PMAS(24,1)/100D0
48076 SINW=SQRT(PARU(102))
48077 COSW=SQRT(1D0-PARU(102))
48088 C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
48089 C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
48090 AR(1,1) = XM1*COS(RMSS(30))
48091 AI(1,1) = XM1*SIN(RMSS(30))
48092 AR(2,2) = XM2*COS(RMSS(31))
48093 AI(2,2) = XM2*SIN(RMSS(31))
48098 AR(1,3) = -XMZ*SINW*COSB
48100 AR(1,4) = XMZ*SINW*SINB
48102 AR(2,3) = XMZ*COSW*COSB
48104 AR(2,4) = -XMZ*COSW*SINB
48106 AR(3,4) = -XMU*COS(RMSS(33))
48107 AI(3,4) = -XMU*SIN(RMSS(33))
48108 AR(4,3) = -XMU*COS(RMSS(33))
48109 AI(4,3) = -XMU*SIN(RMSS(33))
48110 C CALL PYEIG4(AR,WR,ZR)
48111 CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48112 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48113 & 'PROBLEM WITH PYEICG IN PYINOM ')
48121 IF(XM(K).LT.XM(J)) THEN
48139 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
48142 S=S+ZR(J,K)**2+ZI(J,K)**2
48145 ZMIX(I,J)=ZR(J,K)/SQRT(S)
48146 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
48147 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
48148 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
48152 C...CHARGINO MASSES
48153 C.....Find eigenvectors of X X^*
48162 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
48163 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
48164 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48165 &XMU*COS(RMSS(33))*SINB)
48166 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
48167 &XMU*SIN(RMSS(33))*SINB)
48168 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48169 &XMU*COS(RMSS(33))*SINB)
48170 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
48171 &XMU*SIN(RMSS(33))*SINB)
48172 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48173 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48174 & 'PROBLEM WITH PYEICG IN PYINOM ')
48177 IF(WR(2).LT.WR(1)) THEN
48185 SMW(I)=SQRT(WR(K))*100D0
48188 S=S+ZR(J,K)**2+ZI(J,K)**2
48191 UMIX(I,J)=ZR(J,K)/SQRT(S)
48192 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
48193 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
48194 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
48197 C...Force chargino mass > neutralino mass
48199 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
48200 CALL PYERRM(8,'(PYINOM:) '//
48201 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
48202 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
48205 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
48206 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
48208 C.....Find eigenvectors of X^* X
48219 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
48220 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
48221 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
48222 &XMU*COS(RMSS(33))*COSB)
48223 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
48224 &XMU*SIN(RMSS(33))*COSB)
48225 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
48226 &XMU*COS(RMSS(33))*COSB)
48227 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
48228 &XMU*SIN(RMSS(33))*COSB)
48229 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48230 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48231 & 'PROBLEM WITH PYEICG IN PYINOM ')
48234 IF(WR(2).LT.WR(1)) THEN
48244 S=S+ZR(J,K)**2+ZI(J,K)**2
48245 SIMAG=SIMAG+ZI(J,K)**2
48248 VMIX(I,J)=ZR(J,K)/SQRT(S)
48249 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
48250 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
48251 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
48255 C.....Simplify if no phases
48256 IF(SIMAG.LT.1D-6) THEN
48257 AR(1,1) = XM2*COS(RMSS(31))
48258 AR(2,2) = XMU*COS(RMSS(33))
48259 AR(1,2) = SQRT(2D0)*XMW*SINB
48260 AR(2,1) = SQRT(2D0)*XMW*COSB
48273 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
48278 VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
48279 VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
48280 VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
48281 VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
48282 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
48283 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
48284 ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
48288 C.....Must deal with phases
48290 CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
48291 CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
48292 CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
48293 CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
48299 CAI(I,J)=CMPLX(0D0,0D0)
48307 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
48308 & CMPLX(VMIX(J,L),VMIXI(J,L))
48314 CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
48315 CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
48318 VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
48319 VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
48322 VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
48323 VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
48326 VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
48327 VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
48330 VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
48331 VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
48332 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
48333 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
48334 ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
48335 & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
48343 C*********************************************************************
48346 C...Calculates the running of M3, the SU(3) gluino mass parameter.
48348 FUNCTION PYRNM3(RGUT)
48350 C...Double precision and integer declarations.
48351 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48352 IMPLICIT INTEGER(I-N)
48353 INTEGER PYK,PYCHGE,PYCOMP
48355 C...Local variables.
48357 DOUBLE PRECISION TOL
48359 DOUBLE PRECISION PYALPS
48361 DATA R/0.61803399D0/
48365 BX=RGUT*PYALPS(RGUT**2)
48366 AX=MIN(50D0,BX*0.5D0)
48367 CX=MAX(2000D0,2D0*BX)
48371 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
48379 F1=ABS(X1-RGUT*AS1)
48381 F2=ABS(X2-RGUT*AS2)
48382 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
48389 F2=ABS(X2-RGUT*AS2)
48396 F1=ABS(X1-RGUT*AS1)
48411 C*********************************************************************
48414 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
48415 C...Specific application: mixing in neutralino sector.
48417 SUBROUTINE PYEIG4(A,W,Z)
48419 C...Double precision and integer declarations.
48420 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48421 IMPLICIT INTEGER(I-N)
48422 INTEGER PYK,PYCHGE,PYCOMP
48424 C...Arrays: in call and local.
48425 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
48427 C...Coefficients of fourth-degree equation from matrix.
48428 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
48429 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
48433 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
48442 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
48443 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
48444 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
48445 B0=B0+(-1D0)**(I+1)*A(1,I)*(
48446 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
48447 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
48448 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
48451 C...Coefficients of third-degree equation needed for
48452 C...separation into two second-degree equations.
48453 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
48456 C0=-B1**2-B0*B3**2+4D0*B0*B2
48457 CQ=C1/3D0-C2**2/9D0
48458 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
48461 C...Cases with one or three real roots.
48462 IF(CQR.GE.0D0) THEN
48463 S1=(CR+SQRT(CQR))**(1D0/3D0)
48464 S2=(CR-SQRT(CQR))**(1D0/3D0)
48468 THE=ACOS(CR/SABS**3)/3D0
48473 C...Find and solve two second-degree equations.
48474 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
48475 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
48476 Q1=U/2D0+SQRT(U**2/4D0-B0)
48477 Q2=U/2D0-SQRT(U**2/4D0-B0)
48478 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
48483 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
48484 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
48485 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
48486 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
48488 C...Order eigenvalues in asceding mass.
48491 DO 130 I2=I1-1,1,-1
48492 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
48498 C...Find equation system for eigenvectors.
48501 D(J1,J1)=A(J1,J1)-W(I)
48508 C...Find largest element in matrix.
48512 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
48515 DAMAX=ABS(D(J1,J2))
48519 C...Subtract others by multiple of row selected above.
48521 DO 210 J3=JA+1,JA+3
48523 RL=D(J1,JB)/D(JA,JB)
48525 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
48526 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
48529 DAMAX=ABS(D(J1,J2))
48533 C...Do one more subtraction of a row.
48535 DO 230 J3=JC+1,JC+3
48537 IF(J1.EQ.JA) GOTO 230
48538 RL=D(J1,JD)/D(JC,JD)
48540 IF(J2.EQ.JB) GOTO 220
48541 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
48542 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
48544 DAMAX=ABS(D(J1,J2))
48548 C...Construct unnormalized eigenvector.
48550 JF2=JD+2-4*((JD+1)/4)
48551 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
48552 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
48555 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
48556 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
48559 C...Normalize and fill in final array.
48560 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
48561 SGN=(-1D0)**INT(PYR(0)+0.5D0)
48570 C*********************************************************************
48573 C...Determines the Higgs boson mass spectrum using several inputs.
48575 SUBROUTINE PYHGGM(ALPHA)
48577 C...Double precision and integer declarations.
48578 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48579 IMPLICIT INTEGER(I-N)
48580 INTEGER PYK,PYCHGE,PYCOMP
48581 C...Parameter statement to help give large particle numbers.
48582 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48583 &KEXCIT=4000000,KDIMEN=5000000)
48585 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48586 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48587 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
48588 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48589 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
48591 C...Local variables.
48592 DOUBLE PRECISION AT,AB,XMU,TANB
48593 DOUBLE PRECISION ALPHA
48595 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
48596 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
48597 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
48598 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
48601 IF(IHOPT.EQ.2) THEN
48617 DMC=PMAS(PYCOMP(KSUSY1+37),1)
48624 IF(IHOPT.EQ.0) THEN
48625 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
48626 & DMHCH,DSA,DCA,DTANBA)
48627 ELSEIF(IHOPT.EQ.1) THEN
48628 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
48629 & DMHCH,DSA,DCA,DTANBA)
48630 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
48631 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
48632 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
48638 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
48639 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
48640 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
48641 & PMAS(PYCOMP(1000006),1),DSTOP2
48643 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
48644 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
48645 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
48646 & PMAS(PYCOMP(2000006),1),DSTOP1
48648 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
48649 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
48650 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
48651 & PMAS(PYCOMP(1000005),1),DSBOT2
48653 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
48654 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
48655 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
48656 & PMAS(PYCOMP(2000005),1),DSBOT1
48659 ELSEIF (IHOPT.EQ.3) THEN
48660 c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
48661 C...Currently only available for SLHA spectrum read-in.
48662 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
48663 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
48664 & //' spectrum, change IMSS(1) or IMSS(4) option.')
48680 C*********************************************************************
48683 C...This routine computes the renormalization group improved
48684 C...values of Higgs masses and couplings in the MSSM.
48686 C...Program based on the work by M. Carena, J.R. Espinosa,
48687 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
48689 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
48690 C...All masses in GeV units. MA is the CP-odd Higgs mass,
48691 C...MTOP is the physical top mass, MQ and MUR are the soft
48692 C...supersymmetry breaking mass parameters of left handed
48693 C...and right handed stops respectively, AU and AD are the
48694 C...stop and sbottom trilinear soft breaking terms,
48695 C...respectively, and MU is the supersymmetric
48696 C...Higgs mass parameter. We use the conventions from
48697 C...the physics report of Haber and Kane: left right
48698 C...stop mixing term proportional to (AU - MU/TANB)
48699 C...We use as input TANB defined at the scale MTOP
48701 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
48702 C...where MH and HM are the lightest and heaviest CP-even
48703 C...Higgs masses, MHCH is the charged Higgs mass and
48704 C...ALPHA is the Higgs mixing angle
48705 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
48707 C...Range of validity:
48708 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
48709 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
48710 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
48711 C...are the sbottom mass eigenvalues, respectively. This
48712 C...range automatically excludes the existence of tachyons.
48713 C...For the charged Higgs mass computation, the method is
48715 C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
48716 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
48717 C...where M_SUSY**2 is the average of the squared stop mass
48718 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
48719 C...masses have been assumed to be of order of the stop ones
48720 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
48722 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
48723 &XMHCH,SA,CA,TANBA)
48725 C...Double precision and integer declarations.
48726 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48727 IMPLICIT INTEGER(I-N)
48728 INTEGER PYK,PYCHGE,PYCOMP
48729 C...Parameter statement to help give large particle numbers.
48730 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48731 &KEXCIT=4000000,KDIMEN=5000000)
48733 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48734 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48735 COMMON/PYHTRI/HHH(7)
48736 SAVE /PYDAT1/,/PYDAT2/
48738 C...Local variables.
48739 DOUBLE PRECISION PYALEM,PYALPS
48740 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
48741 DOUBLE PRECISION XMHCH,SA,CA
48742 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
48743 DOUBLE PRECISION Q02
48744 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
48745 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
48746 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
48747 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
48748 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
48749 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
48750 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
48751 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
48756 ALP1=AEM/(1D0-PARU(102))
48769 C...MBOTTOM(MTOP) = 3. GEV
48770 XMB = PYMRUN(5,XMTOP**2)
48771 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
48772 &LOG(XMTOP**2/XMZ**2))
48774 C...RMTOP= RUNNING TOP QUARK MASS
48775 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
48776 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
48777 T = LOG(XMS**2/XMTOP**2)
48778 SINB = TANB/((1D0 + TANB**2)**0.5D0)
48780 C...IF(MA.LE.XMTOP) TANBA = TANBT
48782 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
48783 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
48784 &LOG(XMA**2/XMTOP**2))
48786 SINBT = TANBT/SQRT(1D0 + TANBT**2)
48787 COSBT = 1D0/SQRT(1D0 + TANBT**2)
48788 C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
48789 G1 = SQRT(ALP1*4D0*PI)
48790 G2 = SQRT(ALP2*4D0*PI)
48791 G3 = SQRT(ALP3*4D0*PI)
48806 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
48807 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
48808 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
48809 &+ 3D0*(AU + AD)**2/XMS2)/6D0
48810 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
48811 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
48812 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
48813 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
48814 &- 16D0*G3**2) *T/16D0/PI2)
48815 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
48816 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
48817 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
48818 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
48819 &- 16D0*G3**2) *T/16D0/PI2)
48820 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
48821 &(HU2 + HD2)*T/16D0/PI2)
48822 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
48823 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
48824 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
48825 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
48826 &- 16D0*G3**2) *T/16D0/PI2)
48827 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
48828 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
48829 &- 16D0*G3**2) *T/16D0/PI2)
48830 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
48831 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
48832 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
48833 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
48835 &(1+ (6D0*HU2 -2D0* HD2
48836 &- 16D0*G3**2) *T/16D0/PI2)
48837 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
48839 &(1+ (6D0*HD2 -2D0* HU2/2D0
48840 &- 16D0*G3**2) *T/16D0/PI2)
48841 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
48842 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
48843 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
48844 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
48845 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
48846 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48847 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
48848 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48849 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
48850 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48851 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
48852 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48860 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
48861 &2D0* XLAM6*SINBT*COSBT
48862 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
48864 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
48866 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
48867 &2D0* XLAM6* COSBT*SINBT
48868 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48869 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
48870 &((XLAM1* COSBT**2 +2D0*
48871 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
48872 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
48874 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
48875 &+ XLAM4) + XLAM6*COSBT**2
48876 &+ XLAM7* SINBT**2))
48878 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
48879 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
48882 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
48883 XMHCH = SQRT(XMHCH2)
48885 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
48886 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
48887 &XLAM6* COSBT*SINBT
48888 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
48889 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48890 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
48891 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
48893 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
48894 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
48895 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
48896 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
48897 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
48898 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
48899 &XLAM6* COSBT*SINBT
48900 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
48901 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48902 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
48912 C*********************************************************************
48915 C...This subroutine computes the CP-even higgs and CP-odd pole
48916 c...Higgs masses and mixing angles.
48918 C...Program based on the work by M. Carena, M. Quiros
48919 C...and C.E.M. Wagner, "Effective potential methods and
48920 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
48922 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
48924 C...where MCHI is the largest chargino mass, MA is the running
48925 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
48926 C...expectaion values at the scale MTOP, MQ is the third generation
48927 C...left handed squark mass parameter, MUR is the third generation
48928 C...right handed stop mass parameter, MDR is the third generation
48929 C...right handed sbottom mass parameter, MTOP is the pole top quark
48930 C...mass; AT,AB are the soft supersymmetry breaking trilinear
48931 C...couplings of the stop and sbottoms, respectively, and MU is the
48932 C...supersymmetric mass parameter
48934 C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
48935 C...Higgses whose pole mass is computed. If IHIGGS=0 only running
48936 C...masses are given, what makes the running of the program
48937 c...much faster and it is quite generally a good approximation
48938 c...(for a theoretical discussion see ref. above). If IHIGGS=1,
48939 C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
48940 c...and if IHIGGS=3, then h,H,A polarizations are computed
48942 C...Output: MH and MHP which are the lightest CP-even Higgs running
48943 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
48944 C...Higgs running and pole masses, repectively; SA and CA are the
48945 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
48946 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
48947 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
48948 C...the value of TANB at the CP-odd Higgs mass scale
48950 C...This subroutine makes use of CERN library subroutine
48951 C...integration package, which makes the computation of the
48952 C...pole Higgs masses somewhat faster. We thank P. Janot for this
48953 C...improvement. Those who are not able to call the CERN
48954 C...libraries, please use the subroutine SUBHPOLE2.F, which
48955 C...although somewhat slower, gives identical results
48957 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
48958 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
48960 C...Double precision and integer declarations.
48961 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48962 IMPLICIT INTEGER(I-N)
48965 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48967 INTEGER PYK,PYCHGE,PYCOMP
48969 C...Local variables.
48970 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
48971 &SSBOT2(2),B(2,2),COUPB(2,2),
48972 &HCOUPT(2,2),HCOUPB(2,2),
48973 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
48982 RXMT=PYMRUN(6,XMT**2)
48983 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
48984 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
48986 SINB = TANB/(TANB**2+1D0)**0.5D0
48987 COSB = 1D0/(TANB**2+1D0)**0.5D0
48988 COS2B = SINB**2 - COSB**2
48989 SINBPA = SINB*CA + COSB*SA
48990 COSBPA = COSB*CA - SINB*SA
48991 RMBOT = PYMRUN(5,XMT**2)
48994 IF(XMUR.LT.0D0) XMUR2=-XMUR2
48996 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
48997 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
48998 IF(XMST11.LT.0D0) GOTO 500
48999 IF(XMST22.LT.0D0) GOTO 500
49000 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
49001 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
49002 IF(XMSB11.LT.0D0) GOTO 500
49003 IF(XMSB22.LT.0D0) GOTO 500
49004 C WMST11 = RXMT**2 + XMQ2
49005 C WMST22 = RXMT**2 + XMUR2
49006 XMST12 = RXMT*(AT - XMU/TANB)
49007 XMSB12 = RMBOT*(AB - XMU*TANB)
49009 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49010 C...STOP EIGENVALUES CALCULATION
49011 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49013 STOP12 = 0.5D0*(XMST11+XMST22) +
49014 &0.5D0*((XMST11+XMST22)**2 -
49015 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
49016 STOP22 = 0.5D0*(XMST11+XMST22) -
49017 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
49018 &XMST12**2))**0.5D0
49020 IF(STOP22.LT.0D0) GOTO 500
49023 STOP1 = STOP12**0.5D0
49024 STOP2 = STOP22**0.5D0
49028 IF(XMST12.EQ.0D0) XST11 = 1D0
49029 IF(XMST12.EQ.0D0) XST12 = 0D0
49030 IF(XMST12.EQ.0D0) XST21 = 0D0
49031 IF(XMST12.EQ.0D0) XST22 = 1D0
49033 IF(XMST12.EQ.0D0) GOTO 110
49035 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49036 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49037 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49038 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49045 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
49046 &0.5D0*((XMSB11+XMSB22)**2 -
49047 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
49048 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
49049 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
49050 &XMSB12**2))**0.5D0
49051 IF(SBOT22.LT.0D0) GOTO 500
49052 SBOT1 = SBOT12**0.5D0
49053 SBOT2 = SBOT22**0.5D0
49058 IF(XMSB12.EQ.0D0) XSB11 = 1D0
49059 IF(XMSB12.EQ.0D0) XSB12 = 0D0
49060 IF(XMSB12.EQ.0D0) XSB21 = 0D0
49061 IF(XMSB12.EQ.0D0) XSB22 = 1D0
49063 IF(XMSB12.EQ.0D0) GOTO 130
49065 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49066 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49067 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49068 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49080 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49081 C...STARTING OF LIGHT HIGGS
49082 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49084 IF(IHIGGS.EQ.0) GOTO 490
49089 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
49090 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49091 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
49092 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
49101 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
49102 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49103 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
49104 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
49112 180 ITER = ITER + 1
49115 PR(I3)=PRUN+(I3-2)*EPS/2
49120 POLT = POLT + COUPT(I,J)**2*3D0*
49121 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49128 POLB = POLB + COUPB(I,J)**2*3D0*
49129 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49136 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49138 & (-2D0*XMT**2+0.5D0*P2)*
49139 & PYFINT(P2,XMT2,XMT2)
49141 POL = POLT + POLB + POLTT
49142 POLAR(I3) = P2 - XMH**2 - POL
49144 DERIV = (POLAR(3)-POLAR(1))/EPS
49145 DRUN = - POLAR(2)/DERIV
49148 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
49154 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49155 C...END OF LIGHT HIGGS
49156 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49158 250 IF(IHIGGS.EQ.1) GOTO 490
49160 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49161 C... STARTING OF HEAVY HIGGS
49162 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49167 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
49168 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49169 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
49170 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
49178 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
49179 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49180 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
49181 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
49190 300 ITER = ITER + 1
49192 PR(I3)=PRUN+(I3-2)*EPS/2
49198 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
49199 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49206 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
49207 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49215 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49217 & (-2D0*XMT**2+0.5D0*HP2)*
49218 & PYFINT(HP2,XMT2,XMT2)
49220 HPOL = HPOLT + HPOLB + HPOLTT
49221 POLAR(I3) =HP2-HM**2-HPOL
49223 DERIV = (POLAR(3)-POLAR(1))/EPS
49224 DRUN = - POLAR(2)/DERIV
49227 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
49235 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49236 C... END OF HEAVY HIGGS
49237 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49239 IF(IHIGGS.EQ.2) GOTO 490
49241 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49242 C...BEGINNING OF PSEUDOSCALAR HIGGS
49243 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49248 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
49249 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
49255 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
49256 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
49263 420 ITER = ITER + 1
49265 PR(I3)=PRUN+(I3-2)*EPS/2
49270 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
49271 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49277 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
49278 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49284 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49285 & COSB**2/SINB**2 *
49287 & PYFINT(AP2,XMT2,XMT2)
49288 APOL = APOLT + APOLB + APOLTT
49289 POLAR(I3) = AP2 - XMA**2 -APOL
49291 DERIV = (POLAR(3)-POLAR(1))/EPS
49292 DRUN = - POLAR(2)/DERIV
49295 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
49301 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49302 C...END OF PSEUDOSCALAR HIGGS
49303 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49305 IF(IHIGGS.EQ.3) GOTO 490
49310 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
49311 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
49312 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
49313 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
49317 C*********************************************************************
49320 C...Auxiliary to PYPOLE.
49322 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
49323 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
49324 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
49325 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
49328 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49339 C MBOTTOM(MTOP) = 3. GEV
49340 MB = PYMRUN(5,MTOP**2)
49341 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
49342 *LOG(MTOP**2/MZ**2))
49343 C RMTOP= RUNNING TOP QUARK MASS
49344 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
49345 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
49346 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
49347 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
49348 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49350 C NEW DEFINITION, TGLU.
49352 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49353 TGLU = LOG(MGLU**2/MTOP**2)
49354 SINB = TANB/DSQRT(1D0 + TANB**2)
49357 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
49358 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
49359 *LOG(MA**2/MTOP**2))
49360 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
49361 SINB = TANBT/SQRT(1D0 + TANBT**2)
49362 COSB = 1D0/DSQRT(1D0 + TANBT**2)
49363 G1 = SQRT(ALPHA1*4D0*PI)
49364 G2 = SQRT(ALPHA2*4D0*PI)
49365 G3 = SQRT(ALPHA3*4D0*PI)
49368 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
49369 *SBOT1,SBOT2,DELTAMT,DELTAMB)
49370 IF(MQ.GT.MUR) TP = TQ - TU
49371 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
49372 IF(MQ.GT.MUR) TDP = TU
49373 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
49374 IF(MQ.GT.MD) TPD = TQ - TD
49375 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
49376 IF(MQ.GT.MD) TDPD = TD
49377 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
49379 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
49380 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
49381 * HD**2*(G1**2/3D0+G2**2)*TPD
49383 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
49384 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
49385 * HU**2*(-G1**2/3D0+G2**2)*TP
49387 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49389 C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
49390 C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
49391 C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
49395 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49398 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
49399 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
49400 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
49403 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
49404 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
49407 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
49408 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
49411 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
49412 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
49415 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
49416 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
49419 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
49420 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
49425 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
49426 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
49427 *(G2**2-G1**2/3D0)*TPD
49428 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
49429 *1D0/16D0/PI**2*G1**2*HU**2*TP
49430 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
49431 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
49432 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
49433 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
49435 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
49436 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
49437 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
49438 *+ (3D0*HD**2/2D0 + HU**2/2D0
49439 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
49440 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
49441 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
49442 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
49443 *(TP + TDP)/8D0/PI**2)
49444 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
49445 *+ (3D0*HU**2/2D0 + HD**2/2D0
49446 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
49447 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
49448 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
49449 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
49450 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
49451 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
49452 LAMBDA4 = (- G2**2/2D0)*(1D0
49453 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
49454 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
49460 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
49461 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
49463 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
49464 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
49465 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
49466 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
49469 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49470 CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
49471 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49473 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
49475 IF(MCHI.GT.MSSUSY) GOTO 100
49476 IF(MCHI.LT.MTOP) MCHI=MTOP
49478 TCHAR=LOG(MSSUSY**2/MCHI**2)
49480 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
49481 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
49482 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
49484 DELTAM112=2D0*DELTAL12*V**2*COSB**2
49485 DELTAM222=2D0*DELTAL12*V**2*SINB**2
49486 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
49488 M2(1,1)=M2(1,1)+DELTAM112
49489 M2(2,2)=M2(2,2)+DELTAM222
49490 M2(1,2)=M2(1,2)+DELTAM122
49491 M2(2,1)=M2(2,1)+DELTAM122
49495 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49496 CCC END OF CHARGINOS/NEUTRALINOS
49497 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49501 M2P(I,J) = M2(I,J) + VH(I,J)
49504 TRM2P = M2P(1,1) + M2P(2,2)
49505 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
49506 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
49507 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
49509 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
49511 IF(MH2P.LT.0.) GOTO 130
49513 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
49514 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
49515 IF(COS2ALPHA.GE.0.) THEN
49516 ALPHA = ASIN(SIN2ALPHA)/2D0
49518 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
49522 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49524 C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
49525 C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
49526 C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
49529 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49530 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
49531 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
49536 C*********************************************************************
49539 C...Auxiliary to PYRGHM.
49541 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
49542 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
49543 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
49544 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
49546 INTEGER MSTU,MSTJ,KCHG
49547 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49548 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49549 SAVE /PYDAT1/,/PYDAT2/
49551 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
49553 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
49554 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
49556 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
49561 SINBA = TANBA/DSQRT(TANBA**2+1D0)
49562 COSBA = SINBA/TANBA
49564 SINB = TANB/DSQRT(TANB**2+1D0)
49570 SW = 1D0-MW**2/MZ**2
49573 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
49574 G2 = DSQRT(0.0336D0*4D0*PI)
49575 G1 = DSQRT(0.0101D0*4D0*PI)
49577 IF(MQ.GT.MUR) MST = MQ
49578 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
49580 MSUSYT = DSQRT(MST**2 + MTOP**2)
49582 IF(MQ.GT.MD) MSB = MQ
49583 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
49585 MB = PYMRUN(5,MSB**2)
49586 MSUSYB = DSQRT(MSB**2 + MB**2)
49587 TT = LOG(MSUSYT**2/MTOP**2)
49588 TB = LOG(MSUSYB**2/MTOP**2)
49590 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
49591 HT = RMTOP/(V*SINB)
49594 G32 = ALPHA3*4D0*PI
49595 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
49596 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
49597 AL2 = 3D0/8D0/PI**2*HT**2
49598 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
49599 C ALST = 3./8./PI**2*HTST**2
49600 AL1 = 3D0/8D0/PI**2*HB**2
49603 AL(1,2) = (AL2+AL1)/2D0
49604 AL(2,1) = (AL2+AL1)/2D0
49607 IF(MA.GT.MTOP) THEN
49608 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
49609 * LOG(MTOP**2/MA**2))
49612 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
49613 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
49614 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
49615 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
49620 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
49621 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
49622 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
49623 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
49627 SINBT = TANBST/DSQRT(1D0+TANBST**2)
49630 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
49631 COSBB = SINBB/TANBSB
49636 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
49637 MTOP2 = DSQRT(MTOP4)
49638 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
49639 * /(1D0+DELTAMB)**4
49640 MBOT2 = DSQRT(MBOT4)
49642 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
49643 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49644 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49645 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
49646 STOP22 = (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
49650 * + MTOP2*(AT-XMU/TANBST)**2)
49651 IF(STOP22.LT.0.) GOTO 120
49652 SBOT12 = (MQ2 + MD2)*.5D0
49653 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49654 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49655 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49656 SBOT22 = (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 IF(SBOT22.LT.0.) SBOT22 = 10000D0
49662 STOP1 = DSQRT(STOP12)
49663 STOP2 = DSQRT(STOP22)
49664 SBOT1 = DSQRT(SBOT12)
49665 SBOT2 = DSQRT(SBOT22)
49667 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49669 C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
49670 C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
49671 C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
49672 C INDUCED CORRECTIONS.
49674 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49679 IF(X.EQ.Y) X = X - 0.00001D0
49680 IF(X.EQ.Z) X = X - 0.00002D0
49681 IF(Y.EQ.Z) Y = Y - 0.00003D0
49687 IF(X.EQ.Y) X = X - 0.00001D0
49688 IF(X.EQ.Z) X = X - 0.00002D0
49689 IF(Y.EQ.Z) Y = Y - 0.00003D0
49691 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
49692 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
49696 IF(X.EQ.Y) X = X - 0.00001D0
49697 IF(X.EQ.Z) X = X - 0.00002D0
49698 IF(Y.EQ.Z) Y = Y - 0.00003D0
49700 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
49702 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49704 C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
49705 C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
49706 C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
49707 C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
49708 C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
49709 C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
49710 C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
49711 C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
49712 C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
49713 C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
49714 C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
49717 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49719 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
49720 MTOP2 = DSQRT(MTOP4)
49721 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
49722 * /(1D0+DELTAMB)**4
49723 MBOT2 = DSQRT(MBOT4)
49725 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
49726 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49727 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49728 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
49729 STOP22 = (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
49733 * + MTOP2*(AT-XMU/TANBST)**2)
49735 IF(STOP22.LT.0.) GOTO 120
49736 SBOT12 = (MQ2 + MD2)*.5D0
49737 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49738 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49739 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49740 SBOT22 = (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 IF(SBOT22.LT.0.) GOTO 120
49747 STOP1 = DSQRT(STOP12)
49748 STOP2 = DSQRT(STOP22)
49749 SBOT1 = DSQRT(SBOT12)
49750 SBOT2 = DSQRT(SBOT22)
49752 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49754 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49757 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
49759 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
49760 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
49762 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
49764 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
49765 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
49767 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
49768 * (-.5D0*LOG(STOP12/STOP22)
49769 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
49770 * G(STOP12,STOP22))
49772 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
49773 * (.5D0*LOG(SBOT12/SBOT22)
49774 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
49775 * G(SBOT12,SBOT22))
49777 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
49778 * (MQ2+MBOT2)/(MD2+MBOT2))
49779 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
49780 * LOG(SBOT1**2/SBOT2**2)) +
49781 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
49782 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
49785 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
49786 * -STOP2**2))**2*G(STOP12,STOP22)
49788 VH3B(1,1)=VH3B(1,1)+
49789 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
49791 VH3T(1,1) = VH3T(1,1) +
49792 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
49794 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
49795 * (MQ2+MTOP2)/(MUR2+MTOP2))
49796 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
49797 * LOG(STOP1**2/STOP2**2)) +
49798 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
49799 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
49802 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
49803 * -SBOT2**2))**2*G(SBOT12,SBOT22)
49805 VH3T(2,2)=VH3T(2,2)+
49806 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
49807 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
49809 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
49810 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
49811 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
49814 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
49815 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
49816 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
49819 VH3T(1,2)=VH3T(1,2) +
49820 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
49822 VH3B(1,2)=VH3B(1,2) +
49823 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
49825 VH3T(2,1) = VH3T(1,2)
49826 VH3B(2,1) = VH3B(1,2)
49828 C TQ = LOG((MQ2 + MTOP2)/MTOP2)
49829 C TU = LOG((MUR2+MTOP2)/MTOP2)
49830 C TQD = LOG((MQ2 + MB**2)/MB**2)
49831 C TD = LOG((MD2+MB**2)/MB**2)
49836 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
49837 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
49838 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
49839 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
49858 C*********************************************************************
49861 C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
49863 FUNCTION PYFINT(A,B,C)
49865 C...Double precision and integer declarations.
49866 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49867 IMPLICIT INTEGER(I-N)
49868 INTEGER PYK,PYCHGE,PYCOMP
49870 COMMON/PYINTS/XXM(20)
49873 C...Local variables.
49875 DOUBLE PRECISION PYFISB
49882 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
49887 C*********************************************************************
49890 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
49894 C...Double precision and integer declarations.
49895 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49896 IMPLICIT INTEGER(I-N)
49897 INTEGER PYK,PYCHGE,PYCOMP
49899 COMMON/PYINTS/XXM(20)
49902 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
49903 &(X*(XXM(2)-XXM(3))+XXM(3)))
49908 C*********************************************************************
49911 C...Calculates decays of sfermions.
49913 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
49915 C...Double precision and integer declarations.
49916 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49917 IMPLICIT INTEGER(I-N)
49918 INTEGER PYK,PYCHGE,PYCOMP
49919 C...Parameter statement to help give large particle numbers.
49920 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49921 &KEXCIT=4000000,KDIMEN=5000000)
49923 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49924 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49925 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49926 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49927 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49928 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
49930 C...Local variables.
49931 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
49932 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
49934 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
49935 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
49936 DOUBLE PRECISION PYLAMF,XL
49937 DOUBLE PRECISION TANW,XW,AEM,C1,AS
49938 DOUBLE PRECISION AL,AR,BL,BR
49939 DOUBLE PRECISION CH1,CH2,CH3,CH4
49940 DOUBLE PRECISION XMBOT,XMTOP
49941 DOUBLE PRECISION XLAM(0:400)
49942 INTEGER IDLAM(400,3)
49943 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
49944 DOUBLE PRECISION SR2
49945 DOUBLE PRECISION CBETA,SBETA
49946 DOUBLE PRECISION CW
49947 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
49948 DOUBLE PRECISION COSA,SINA,TANB
49949 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
49950 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
49952 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
49953 DATA IGG/23,25,35,36/
49954 DATA PI/3.141592654D0/
49955 DATA SR2/1.4142136D0/
49956 DATA KFNCHI/1000022,1000023,1000025,1000035/
49957 DATA KFCCHI/1000024,1000037/
49959 C...COUNT THE NUMBER OF DECAY MODES
49963 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
49964 &KFIN.EQ.KSUSY2+16) RETURN
49970 TANW = SQRT(XW/(1D0-XW))
49975 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
49980 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
49981 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
49987 C...ILR is 1 for left and 2 for right.
49989 C...IFL is matching non-SUSY flavour.
49990 IFL=MOD(KFIN,KSUSY1)
49991 C...IDU is weak isospin, 1 for down and 2 for up.
50002 XMBOT=PYMRUN(5,XMI2)
50003 XMTOP=PYMRUN(6,XMI2)
50017 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
50019 IF(IMSS(11).EQ.1) THEN
50022 XMGR=PMAS(PYCOMP(IDG),1)
50023 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
50026 ELSEIF(IFL.EQ.6) THEN
50031 IF(XMI.GT.XMGR+XMF) THEN
50036 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
50040 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
50042 C...CHARGED DECAYS:
50044 C...DI -> U CHI1-,CHI2-
50048 C...UI -> D CHI1+,CHI2+
50055 IF(XMI.GE.AXMJ+XMFP) THEN
50062 ELSEIF(IFL.LT.6) THEN
50067 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
50068 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
50074 ELSEIF(IFL.LT.5) THEN
50079 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
50080 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
50084 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50085 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50086 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50087 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50103 XL=PYLAMF(XMI2,XMA2,XMB2)
50104 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50105 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50106 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
50109 IDLAM(LKNT,1)=-KFCCHI(IX)
50110 IDLAM(LKNT,2)=IFL+1
50112 IDLAM(LKNT,1)=KFCCHI(IX)
50113 IDLAM(LKNT,2)=IFL-1
50124 IF(XMI.GE.AXMJ+XMF) THEN
50130 ELSEIF(IFL.LT.5) THEN
50133 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
50134 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
50135 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50140 ELSEIF(IFL.LT.5) THEN
50143 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
50144 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
50145 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50149 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50150 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50151 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50152 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50168 XL=PYLAMF(XMI2,XMA2,XMB2)
50169 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50170 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50171 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
50172 IDLAM(LKNT,1)=KFNCHI(IX)
50178 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
50182 IF(ILR.EQ.1) GOTO 160
50184 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
50185 IF(XMI.LT.XMSF1+XMB) GOTO 160
50187 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
50190 ELSEIF(IG.EQ.25) THEN
50193 ELSEIF(IFL.EQ.6) THEN
50195 ELSEIF(IFL.LT.5) THEN
50201 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
50202 & XMF**2/XMW*COSA/SBETA
50203 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
50204 & XMF**2/XMW*COSA/SBETA
50206 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
50207 & XMF**2/XMW*(-SINA)/CBETA
50208 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
50209 & XMF**2/XMW*(-SINA)/CBETA
50213 ELSEIF(IFL.EQ.6) THEN
50215 ELSEIF(IFL.EQ.15) THEN
50220 C.........need to complexify
50222 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
50225 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
50231 ELSEIF(IG.EQ.35) THEN
50234 ELSEIF(IFL.EQ.6) THEN
50236 ELSEIF(IFL.LT.5) THEN
50242 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
50243 & XMF**2/XMW*SINA/SBETA
50244 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
50245 & XMF**2/XMW*SINA/SBETA
50247 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
50248 & XMF**2/XMW*COSA/CBETA
50249 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
50250 & XMF**2/XMW*COSA/CBETA
50254 ELSEIF(IFL.EQ.6) THEN
50256 ELSEIF(IFL.EQ.15) THEN
50261 C.........Need to complexify
50263 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
50266 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
50272 ELSEIF(IG.EQ.36) THEN
50277 ELSEIF(IFL.EQ.6) THEN
50279 ELSEIF(IFL.LT.5) THEN
50286 ELSEIF(IFL.EQ.6) THEN
50288 ELSEIF(IFL.EQ.15) THEN
50293 C.........Need to complexify
50295 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
50297 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
50303 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
50304 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
50305 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
50306 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50309 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50311 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
50314 IDLAM(LKNT,1)=KFIN-KSUSY1
50320 IF(MOD(IFL,2).EQ.0) THEN
50326 XMSF1=PMAS(PYCOMP(KF1),1)
50327 XMSF2=PMAS(PYCOMP(KF2),1)
50328 IF(XMI.GT.XMB+XMSF1) THEN
50329 IF(MOD(IFL,2).EQ.0) THEN
50331 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
50333 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
50337 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
50339 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
50342 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50344 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50347 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
50349 IF(XMI.GT.XMB+XMSF2) THEN
50350 IF(MOD(IFL,2).EQ.0) THEN
50352 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
50354 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
50358 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
50360 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
50363 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
50365 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50368 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
50373 IF(MOD(IFL,2).EQ.0) THEN
50379 XMSF1=PMAS(PYCOMP(KF1),1)
50380 XMSF2=PMAS(PYCOMP(KF2),1)
50381 IF(XMI.GT.XMB+XMSF1) THEN
50386 IF(MOD(IFL,2).EQ.0) THEN
50389 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
50390 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
50391 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
50392 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
50395 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
50396 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
50397 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
50398 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
50409 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
50410 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
50411 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
50412 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
50415 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
50416 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
50417 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
50418 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
50427 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50429 C.......Need to complexify
50430 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
50431 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
50432 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
50433 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
50436 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
50438 IF(XMI.GT.XMB+XMSF2) THEN
50443 IF(MOD(IFL,2).EQ.0) THEN
50446 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
50447 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
50448 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
50449 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
50452 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
50453 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
50454 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
50455 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
50466 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
50467 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
50468 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
50469 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
50472 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
50473 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
50474 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
50475 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
50484 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50486 C.......Need to complexify
50487 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
50488 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
50489 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
50490 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
50493 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
50496 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
50501 IF(IFL.EQ.6) XMF=PMAS(6,1)
50502 IF(IFL.EQ.5) XMF=PMAS(5,1)
50503 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
50505 IF(XMI.GE.AXMJ+XMF) THEN
50522 XL=PYLAMF(XMI2,XMA2,XMB2)
50523 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50524 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
50525 IDLAM(LKNT,1)=KSUSY1+21
50531 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
50532 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
50533 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
50534 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
50535 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
50536 C...M*M = C1**2 * G**2/(16PI**2)
50537 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
50539 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
50540 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
50541 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
50542 IDLAM(LKNT,1)=KSUSY1+22
50547 C...R-violating sfermion decays (SKANDS).
50548 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
50553 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50554 XLAM(0)=XLAM(0)+XLAM(I)
50556 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
50561 C*********************************************************************
50564 C...Calculates gluino decay modes.
50566 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
50568 C...Double precision and integer declarations.
50569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50570 IMPLICIT INTEGER(I-N)
50571 INTEGER PYK,PYCHGE,PYCOMP
50572 C...Parameter statement to help give large particle numbers.
50573 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50574 &KEXCIT=4000000,KDIMEN=5000000)
50576 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50577 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50578 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50579 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50580 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50582 C COMMON/PYINTS/XXM(20)
50584 COMMON/PYINTC/XXC(10),CXC(8)
50585 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50587 C...Local variables
50588 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
50589 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
50590 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
50591 DOUBLE PRECISION PYLAMF,XL
50592 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
50593 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
50594 DOUBLE PRECISION XLAM(0:400)
50595 INTEGER IDLAM(400,3)
50596 INTEGER LKNT,IX,ILR,I,IKNT,IFL
50597 DOUBLE PRECISION SR2
50598 DOUBLE PRECISION GAM
50599 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
50600 EXTERNAL PYGAUS,PYXXZ6
50601 DOUBLE PRECISION PYGAUS,PYXXZ6
50602 DOUBLE PRECISION PREC
50603 INTEGER KFNCHI(4),KFCCHI(2)
50604 DATA PI/3.141592654D0/
50605 DATA SR2/1.4142136D0/
50607 DATA KFNCHI/1000022,1000023,1000025,1000035/
50608 DATA KFCCHI/1000024,1000037/
50610 C...COUNT THE NUMBER OF DECAY MODES
50612 IF(KFIN.NE.KSUSY1+21) RETURN
50616 TANW = SQRT(XW/(1D0-XW))
50626 XMI=SIGN(XMI,RMSS(3))
50628 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
50630 IF(IMSS(11).EQ.1) THEN
50633 XMGR=PMAS(PYCOMP(IDG),1)
50634 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
50635 IF(AXMI.GT.XMGR) THEN
50644 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
50648 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
50651 IF(AXMI.GE.AXMJ+XMF) THEN
50652 C...Minus sign difference from gluino-quark-squark feynman rules
50669 XL=PYLAMF(XMI2,XMA2,XMB2)
50670 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
50671 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
50672 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
50676 XLAM(LKNT)=XLAM(LKNT-1)
50677 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50678 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50684 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
50685 C...GLUINO -> NI Q QBAR
50689 IF(AXMI.GE.AXMJ) THEN
50691 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
50693 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
50700 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
50701 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
50707 T3I=SIGN(1D0,EI+1D-6)/2D0
50708 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50709 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50713 CXC(4)=DCONJG(GLIJ)
50717 CXC(8)=-DCONJG(GRIJ)
50719 S12MAX=(AXMI-AXMJ)**2
50720 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
50721 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50723 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
50724 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
50725 IDLAM(LKNT,1)=KFNCHI(IX)
50729 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50731 XLAM(LKNT)=XLAM(LKNT-1)
50732 IDLAM(LKNT,1)=KFNCHI(IX)
50737 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50738 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
50739 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
50741 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
50742 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
50744 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
50747 IDLAM(LKNT,1)=KFNCHI(IX)
50750 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
50755 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
50756 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
50757 C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
50761 T3I=SIGN(1D0,EI+1D-6)/2D0
50762 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50763 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50765 CXC(4)=DCONJG(GLIJ)
50767 CXC(8)=-DCONJG(GRIJ)
50768 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
50769 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50771 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
50772 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
50773 IDLAM(LKNT,1)=KFNCHI(IX)
50777 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50779 XLAM(LKNT)=XLAM(LKNT-1)
50780 IDLAM(LKNT,1)=KFNCHI(IX)
50785 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
50786 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
50788 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
50789 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
50790 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
50792 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
50793 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
50795 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
50798 IDLAM(LKNT,1)=KFNCHI(IX)
50801 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
50807 C...GLUINO -> CI Q QBAR'
50811 IF(AXMI.GE.AXMJ) THEN
50813 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
50814 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
50817 S12MAX=(AXMI-AXMJ)**2
50822 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
50823 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
50826 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
50828 CXC(1)=DCMPLX(0D0,0D0)
50829 CXC(3)=DCMPLX(0D0,0D0)
50830 CXC(5)=DCMPLX(0D0,0D0)
50831 CXC(7)=DCMPLX(0D0,0D0)
50832 CXC(2)=UMIXC(IX,1)*OLPP/SR2
50833 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
50834 CXC(6)=DCMPLX(0D0,0D0)
50835 CXC(8)=DCMPLX(0D0,0D0)
50836 IF(XXC(5).LT.AXMI) THEN
50838 ELSEIF(XXC(6).LT.AXMI) THEN
50843 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
50844 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
50846 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
50847 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50848 IDLAM(LKNT,1)=KFCCHI(IX)
50852 XLAM(LKNT)=XLAM(LKNT-1)
50853 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50854 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50855 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50857 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
50859 XLAM(LKNT)=XLAM(LKNT-1)
50860 IDLAM(LKNT,1)=KFCCHI(IX)
50864 XLAM(LKNT)=XLAM(LKNT-1)
50865 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50866 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50867 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50873 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
50874 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
50875 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
50876 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
50877 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
50878 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
50879 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
50880 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
50881 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
50882 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
50883 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
50884 CALL PYTBBC(IX,100,XMI,GAM)
50887 IDLAM(LKNT,1)=KFCCHI(IX)
50891 XLAM(LKNT)=XLAM(LKNT-1)
50892 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50893 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50894 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50895 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
50896 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
50897 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
50898 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
50904 C...R-parity violating (3-body) decays.
50905 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
50910 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50911 XLAM(0)=XLAM(0)+XLAM(I)
50913 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
50919 C*********************************************************************
50922 C...Calculates the three-body decay of gluinos into
50923 C...neutralinos and third generation fermions.
50925 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
50927 C...Double precision and integer declarations.
50928 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50929 IMPLICIT INTEGER(I-N)
50930 INTEGER PYK,PYCHGE,PYCOMP
50931 C...Parameter statement to help give large particle numbers.
50932 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50933 &KEXCIT=4000000,KDIMEN=5000000)
50935 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50936 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50937 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50938 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50939 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50940 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50942 C...Local variables.
50943 EXTERNAL PYSIMP,PYLAMF
50944 DOUBLE PRECISION PYSIMP,PYLAMF
50946 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
50947 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
50948 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
50949 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
50950 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
50951 DOUBLE PRECISION XLN1,XLN2,B1,B2
50952 DOUBLE PRECISION E,XMGLU,GAM
50953 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
50954 SAVE HRB,HLB,FLB,FRB
50955 DOUBLE PRECISION ALPHAW,ALPHAS
50956 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
50957 SAVE HLT,HRT,FLT,FRT
50958 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
50960 DOUBLE PRECISION AMBOT,SINC,COSC
50961 DOUBLE PRECISION AMTOP,SINA,COSA
50962 DOUBLE PRECISION SINW,COSW,TANW
50963 DOUBLE PRECISION ROT1(4,4)
50966 DATA IFIRST/.TRUE./
50969 SINB=TANB/SQRT(1D0+TANB**2)
50980 AMBOT=PYMRUN(5,XMGLU**2)
50981 AMTOP=PYMRUN(6,XMGLU**2)
50983 FAKT1=AMBOT/W2/AMW/COSB
50984 FAKT2=AMTOP/W2/AMW/SINB
50995 ROT1(2,1)=-ROT1(1,2)
50996 ROT1(2,2)=ROT1(1,1)
50999 ROT1(4,3)=-ROT1(3,4)
51000 ROT1(4,4)=ROT1(3,3)
51004 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
51009 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
51010 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51011 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
51013 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
51014 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
51015 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
51016 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
51019 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
51020 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51021 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
51022 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
51023 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
51024 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
51025 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
51029 C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51030 C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51031 C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51032 C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51036 IF(NINT(3D0*E).EQ.2) THEN
51043 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
51044 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
51053 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
51054 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
51060 SIN2D=SIND*COSD*2D0
51074 ALPHAW=PYALEM(XMG2)
51075 ALPHAS=PYALPS(XMG2)
51079 XM24=(XMG2+XM2)*(XM2+XMR2)
51081 SMAX=(XMG-ABS(XMR))**2
51082 XMQA=XMG2+2D0*XM2+XMR2
51084 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51086 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
51088 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
51089 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
51090 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
51091 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
51092 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
51093 & +2D0*(FF*SIND2-HH*COSD2))*W
51094 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
51095 & +4D0*HFL*XM*XMR)*XLN1
51096 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
51097 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
51098 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
51099 & +8D0*HFL*XMQ4*SIN2D)*B1
51100 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
51101 & +4D0*HFR*XMR*XM)*XLN2
51102 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
51103 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
51104 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
51105 & -8D0*HFR*XMQ4*SIN2D)*B2
51106 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
51107 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
51108 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
51109 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
51110 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
51111 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
51112 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
51113 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
51114 G(5)=(2D0*(HH*COSD2-FF*SIND2)
51115 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
51116 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
51117 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
51118 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
51119 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
51120 & +COS2D*XM*(SBAR+XMG2-XMR2))
51121 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
51122 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
51123 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
51124 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
51125 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
51126 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
51127 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
51130 SUMME(LIN)=SUMME(LIN)+G(J)
51135 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51136 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51141 C*********************************************************************
51144 C...Calculates the three-body decay of gluinos into
51145 C...charginos and third generation fermions.
51147 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
51149 C...Double precision and integer declarations.
51150 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51151 IMPLICIT INTEGER(I-N)
51152 INTEGER PYK,PYCHGE,PYCOMP
51153 C...Parameter statement to help give large particle numbers.
51154 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51155 &KEXCIT=4000000,KDIMEN=5000000)
51157 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51158 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51159 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51160 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51161 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51162 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
51164 C...Local variables.
51165 EXTERNAL PYSIMP,PYLAMF
51166 DOUBLE PRECISION PYSIMP,PYLAMF
51168 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
51169 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
51170 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
51171 DOUBLE PRECISION SUMME(0:100),A(4,8)
51172 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
51173 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
51174 DOUBLE PRECISION XMGLU,GAM
51175 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
51176 &DDD(2),EEE(2),FFF(2)
51177 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
51178 DOUBLE PRECISION ALPHAW,ALPHAS
51179 DOUBLE PRECISION AMC(2)
51181 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
51182 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
51186 DATA IFIRST/.TRUE./
51189 SINB=TANB/SQRT(1D0+TANB**2)
51197 AMBOT=PYMRUN(5,XMGLU**2)
51198 AMTOP=PYMRUN(6,XMGLU**2)
51201 FAKT1=AMBOT/W2/AMW/COSB
51202 FAKT2=AMTOP/W2/AMW/SINB
51207 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
51208 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
51209 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
51210 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
51211 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
51212 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
51213 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
51214 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
51216 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51217 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51218 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51219 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51223 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
51224 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
51225 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
51226 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
51228 COS2A=COSA**2-SINA**2
51229 SIN2A=SINA*COSA*2D0
51230 COS2C=COSC**2-SINC**2
51231 SIN2C=SINC*COSC*2D0
51238 ALPHAW=PYALEM(XMG2)
51239 ALPHAS=PYALPS(XMG2)
51243 XMQ2=XMG2+XMT2+XMB2+XMR2
51244 XMQ4=XMG*XMT*XMB*XMR
51245 XMQ3=XMG2*XMR2+XMT2*XMB2
51246 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
51247 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
51249 XMST(1)=AMST(1)*AMST(1)
51250 XMST(2)=AMST(1)*AMST(1)
51251 XMST(3)=AMST(2)*AMST(2)
51252 XMST(4)=AMST(2)*AMST(2)
51253 XMSB(1)=AMSB(1)*AMSB(1)
51254 XMSB(2)=AMSB(2)*AMSB(2)
51255 XMSB(3)=AMSB(1)*AMSB(1)
51256 XMSB(4)=AMSB(2)*AMSB(2)
51258 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
51259 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
51260 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
51261 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
51262 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
51263 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
51264 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
51265 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
51267 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
51268 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
51269 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
51270 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
51271 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
51272 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
51273 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
51274 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
51276 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
51277 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
51278 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
51279 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
51280 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
51281 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
51282 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
51283 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
51285 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
51286 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
51287 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
51288 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
51289 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
51290 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
51291 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
51292 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
51294 SMAX=(XMG-ABS(XMR))**2
51295 SMIN=(XMB+XMT)**2+0.1D0
51298 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51299 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
51301 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
51302 W=DSQRT(W)/2D0/SBAR
51303 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
51304 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
51305 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
51306 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
51307 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
51308 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
51309 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
51310 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
51311 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
51312 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
51313 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
51314 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
51315 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
51316 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
51317 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
51318 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
51319 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
51320 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
51321 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
51322 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
51323 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
51324 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
51325 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
51326 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
51327 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
51328 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
51329 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
51330 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
51331 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
51332 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
51333 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
51334 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
51335 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
51336 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
51337 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
51338 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
51339 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
51340 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
51341 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
51342 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
51343 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
51344 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
51345 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
51347 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
51348 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
51349 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
51350 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
51351 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
51352 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
51353 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
51354 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
51355 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
51356 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
51357 & -A(J,6)*(XMG2+XMR2-SBAR)
51358 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
51359 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
51360 & /(GRS+XMSB(J)+XMST(J))
51364 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51365 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51370 C*********************************************************************
51373 C...Calculates decay widths for the neutralinos (admixtures of
51374 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
51376 C...Input: KCIN = KF code for particle
51377 C...Output: XLAM = widths
51378 C... IDLAM = KF codes for decay particles
51379 C... IKNT = number of decay channels defined
51380 C...AUTHOR: STEPHEN MRENNA
51382 C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
51383 C...when CHIGAMMA .NE. 0
51384 C...10 FEB 96: Calculate this decay for small tan(beta)
51386 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
51388 C...Double precision and integer declarations.
51389 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51390 IMPLICIT INTEGER(I-N)
51391 INTEGER PYK,PYCHGE,PYCOMP
51392 C...Parameter statement to help give large particle numbers.
51393 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51394 &KEXCIT=4000000,KDIMEN=5000000)
51396 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51397 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51398 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51399 c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51401 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51402 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51403 C COMMON/PYINTS/XXM(20)
51405 COMMON/PYINTC/XXC(10),CXC(8)
51406 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51408 C...Local variables.
51409 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
51410 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
51412 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
51413 &XMZ,XMZ2,AXMJ,AXMI
51414 DOUBLE PRECISION S12MIN,S12MAX
51415 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
51416 DOUBLE PRECISION PYLAMF,XL
51417 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
51418 DOUBLE PRECISION PYX2XH,PYX2XG
51419 DOUBLE PRECISION XLAM(0:400)
51420 INTEGER IDLAM(400,3)
51421 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
51422 INTEGER ITH(3),KF1,KF2
51424 DOUBLE PRECISION DH(3),EH(3)
51425 DOUBLE PRECISION SR2
51426 DOUBLE PRECISION CBETA,SBETA
51427 DOUBLE PRECISION GAMCON,XMT1,XMT2
51428 DOUBLE PRECISION PYALEM,PI,PYALPS
51429 DOUBLE PRECISION RAT1,RAT2
51430 DOUBLE PRECISION T3T,FCOL
51431 DOUBLE PRECISION ALFA,BETA,TANB
51432 DOUBLE PRECISION PYXXGA
51433 EXTERNAL PYGAUS,PYXXZ6
51434 DOUBLE PRECISION PYGAUS,PYXXZ6
51435 DOUBLE PRECISION PREC
51436 INTEGER KFNCHI(4),KFCCHI(2)
51440 DATA PI/3.141592654D0/
51441 DATA SR2/1.4142136D0/
51442 DATA KFNCHI/1000022,1000023,1000025,1000035/
51443 DATA KFCCHI/1000024,1000037/
51445 C...COUNT THE NUMBER OF DECAY MODES
51454 TANW = SQRT(XW/XW1)
51456 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
51458 IF(KFIN.EQ.KFNCHI(2)) IX=2
51459 IF(KFIN.EQ.KFNCHI(3)) IX=3
51460 IF(KFIN.EQ.KFNCHI(4)) IX=4
51480 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
51485 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
51486 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
51490 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51491 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
51493 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
51494 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
51498 GAMCON=AEM**3/8D0/PI/XMW2/XW
51499 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
51500 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
51501 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
51502 IDLAM(LKNT,1)=KSUSY1+22
51505 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
51509 C...GRAVITINO DECAY MODES
51511 IF(IMSS(11).EQ.1) THEN
51514 XMGR=PMAS(PYCOMP(IDG),1)
51517 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51518 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
51523 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
51525 IF(AXMI.GT.XMGR+XMZ) THEN
51530 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
51531 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
51532 & (1D0-XMZ2/XMI2)**4
51534 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
51539 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
51540 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
51542 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
51547 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
51548 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
51550 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
51555 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
51556 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
51558 IF(IX.EQ.1) GOTO 300
51566 C...CHI0_I -> CHI0_J + GAMMA
51567 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
51568 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
51569 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
51570 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
51571 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
51572 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
51573 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
51575 IDLAM(LKNT,1)=KFNCHI(IJ)
51578 GAMCON=AEM**3/8D0/PI/XMW2/XW
51579 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
51580 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
51581 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
51585 C...CHI0_I -> CHI0_J + Z0
51586 IF(AXMI.GE.AXMJ+XMZ) THEN
51588 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
51589 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
51591 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51592 GLR=DBLE(OLPP*DCONJG(ORPP))
51593 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
51594 IDLAM(LKNT,1)=KFNCHI(IJ)
51597 ELSEIF(AXMI.GE.AXMJ) THEN
51604 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
51605 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
51607 C...CHARGED LEPTONS
51609 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51610 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51612 T3I=SIGN(1D0,EI+1D-6)/2D0
51613 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51614 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51615 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51616 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51618 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51619 CXC(4)=DCONJG(GLIJ)
51620 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51622 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51623 CXC(8)=-DCONJG(GRIJ)
51625 S12MAX=(AXMI-AXMJ)**2
51626 IF( XXC(5).LT.AXMI ) THEN
51629 IF(XXC(6).LT.AXMI ) THEN
51635 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
51637 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51638 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51639 IDLAM(LKNT,1)=KFNCHI(IJ)
51642 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
51644 XLAM(LKNT)=XLAM(LKNT-1)
51645 IDLAM(LKNT,1)=KFNCHI(IJ)
51651 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51652 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51653 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
51655 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
51656 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51658 IF( XXC(5).LT.AXMI ) THEN
51661 IF(XXC(6).LT.AXMI ) THEN
51667 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
51669 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51670 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51671 IDLAM(LKNT,1)=KFNCHI(IJ)
51679 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51680 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51682 T3I=SIGN(1D0,EI+1D-6)/2D0
51683 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51684 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51685 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51686 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51688 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51689 CXC(4)=DCONJG(GLIJ)
51690 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51692 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51693 CXC(8)=-DCONJG(GRIJ)
51695 S12MAX=(AXMI-AXMJ)**2
51696 IF( XXC(5).LT.AXMI ) THEN
51699 IF( XXC(6).LT.AXMI ) THEN
51706 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51707 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51708 IDLAM(LKNT,1)=KFNCHI(IJ)
51712 XLAM(LKNT)=XLAM(LKNT-1)
51713 IDLAM(LKNT,1)=KFNCHI(IJ)
51718 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
51720 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
51721 IF( XXC(5).LT.AXMI ) THEN
51726 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51727 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51730 XLAM(LKNT)=XLAM(LKNT-1)
51732 IDLAM(LKNT,1)=KFNCHI(IJ)
51738 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51739 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51741 T3I=SIGN(1D0,EI+1D-6)/2D0
51742 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51743 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51744 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51745 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51747 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51748 CXC(4)=DCONJG(GLIJ)
51749 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51751 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51752 CXC(8)=-DCONJG(GRIJ)
51754 S12MAX=(AXMI-AXMJ)**2
51755 IF( XXC(5).LT.AXMI ) THEN
51758 IF( XXC(6).LT.AXMI ) THEN
51764 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51766 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51767 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51768 IDLAM(LKNT,1)=KFNCHI(IJ)
51771 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51773 XLAM(LKNT)=XLAM(LKNT-1)
51774 IDLAM(LKNT,1)=KFNCHI(IJ)
51780 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51781 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51782 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
51784 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
51785 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51787 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
51788 IF(XXC(5).LT.AXMI) THEN
51790 ELSEIF(XXC(6).LT.AXMI) THEN
51795 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51797 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51798 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51799 IDLAM(LKNT,1)=KFNCHI(IJ)
51807 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51808 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51810 T3I=SIGN(1D0,EI+1D-6)/2D0
51811 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51812 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51813 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51814 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51816 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51817 CXC(4)=DCONJG(GLIJ)
51818 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51820 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51821 CXC(8)=-DCONJG(GRIJ)
51823 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
51824 IF(XXC(5).LT.AXMI) THEN
51826 ELSEIF(XXC(6).LT.AXMI) THEN
51832 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51834 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51835 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51836 IDLAM(LKNT,1)=KFNCHI(IJ)
51839 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51841 XLAM(LKNT)=XLAM(LKNT-1)
51842 IDLAM(LKNT,1)=KFNCHI(IJ)
51850 C...CHI0_I -> CHI0_J + H0_K
51857 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
51858 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
51859 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
51860 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
51861 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
51862 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
51863 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
51864 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
51866 XMH=PMAS(ITH(IH),1)
51868 IF(AXMI.GE.AXMJ+XMH) THEN
51870 XL=PYLAMF(XMI2,XMJ2,XMH2)
51871 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
51873 C...SIGN OF MASSES I,J
51875 IF(IH.EQ.3) XMK=-XMK
51876 GX2=ABS(F21K)**2+ABS(F12K)**2
51877 GLR=DBLE(F21K*DCONJG(F12K))
51878 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
51879 IDLAM(LKNT,1)=KFNCHI(IJ)
51880 IDLAM(LKNT,2)=ITH(IH)
51886 C...CHI0_I -> CHI+_J + W-
51891 IF(AXMI.GE.AXMJ+XMW) THEN
51893 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
51894 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
51895 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
51896 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
51897 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
51898 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
51899 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
51900 IDLAM(LKNT,1)=KFCCHI(IJ)
51904 XLAM(LKNT)=XLAM(LKNT-1)
51905 IDLAM(LKNT,1)=-KFCCHI(IJ)
51908 ELSEIF(AXMI.GE.AXMJ) THEN
51910 S12MAX=(AXMI-AXMJ)**2
51911 RT2I = 1D0/SQRT(2D0)
51912 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
51913 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
51914 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
51915 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
51916 CXC(5)=DCMPLX(0D0,0D0)
51917 CXC(7)=DCMPLX(0D0,0D0)
51921 T3I=SIGN(1D0,EI+1D-6)/2D0
51923 T3J=SIGN(1D0,EJ+1D-6)/2D0
51924 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
51925 & TANW+ZMIXC(IX,2)*T3J)*RT2I
51926 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
51927 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
51928 CXC(6)=DCMPLX(0D0,0D0)
51929 CXC(8)=DCMPLX(0D0,0D0)
51934 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51935 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51938 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
51939 IF(XXC(5).LT.AXMI) THEN
51941 ELSEIF(XXC(6).LT.AXMI) THEN
51946 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
51948 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51949 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51950 IDLAM(LKNT,1)=KFCCHI(IJ)
51954 XLAM(LKNT)=XLAM(LKNT-1)
51955 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51956 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51957 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51958 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
51960 XLAM(LKNT)=XLAM(LKNT-1)
51961 IDLAM(LKNT,1)=KFCCHI(IJ)
51965 XLAM(LKNT)=XLAM(LKNT-1)
51966 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51967 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51968 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51972 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51973 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51974 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51976 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51977 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51979 IF(XXC(5).LT.AXMI) THEN
51982 IF(XXC(6).LT.AXMI) THEN
51987 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51989 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51990 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51991 XLAM(LKNT)=XLAM(LKNT-1)
51992 IDLAM(LKNT,1)=KFCCHI(IJ)
51996 XLAM(LKNT)=XLAM(LKNT-1)
51997 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51998 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51999 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52002 C...NOW, DO THE QUARKS
52007 T3I=SIGN(1D0,EI+1D-6)/2D0
52009 T3J=SIGN(1D0,EJ+1D-6)/2D0
52010 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
52011 & TANW+ZMIXC(IX,2)*T3J)
52012 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
52013 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
52014 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
52015 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
52016 IF(XXC(5).LT.AXMI) THEN
52019 IF(XXC(6).LT.AXMI) THEN
52024 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
52026 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52027 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52028 IDLAM(LKNT,1)=KFCCHI(IJ)
52032 XLAM(LKNT)=XLAM(LKNT-1)
52033 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52034 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52035 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52036 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52038 XLAM(LKNT)=XLAM(LKNT-1)
52039 IDLAM(LKNT,1)=KFCCHI(IJ)
52043 XLAM(LKNT)=XLAM(LKNT-1)
52044 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52045 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52046 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52054 C...CHI0_I -> CHI+_I + H-
52060 IF(AXMI.GE.AXMJ+XMHP) THEN
52062 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
52063 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
52064 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
52065 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
52067 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52068 GLR=DBLE(OLPP*DCONJG(ORPP))
52069 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52070 IDLAM(LKNT,1)=KFCCHI(IJ)
52071 IDLAM(LKNT,2)=-ITHC
52074 XLAM(LKNT)=XLAM(LKNT-1)
52075 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52076 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52077 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52083 C...2-BODY DECAYS TO FERMION SFERMION
52085 IF(J.GE.7.AND.J.LE.10) GOTO 290
52088 XMSF1=PMAS(PYCOMP(KF1),1)
52089 XMSF2=PMAS(PYCOMP(KF2),1)
52099 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
52100 IF(MOD(J,2).EQ.0) THEN
52101 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52102 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
52103 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52106 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52107 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
52108 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52113 IF(AXMI.GE.XMF+XMSF1) THEN
52117 XL=PYLAMF(XMI2,XMA2,XMB2)
52118 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
52119 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
52120 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52121 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52126 XLAM(LKNT)=XLAM(LKNT-1)
52127 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52128 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52133 IF(AXMI.GE.XMF+XMSF2) THEN
52137 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
52138 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
52139 XL=PYLAMF(XMI2,XMA2,XMB2)
52140 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52141 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52146 XLAM(LKNT)=XLAM(LKNT-1)
52147 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52148 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52153 C...3-BODY DECAY TO Q Q~ GLUINO
52154 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52155 IF(AXMI.GE.XMJ) THEN
52156 RT2I = 1D0/SQRT(2D0)
52157 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
52165 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52166 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52172 T3I=SIGN(1D0,EI+1D-6)/2D0
52173 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52174 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52178 CXC(4)=DCONJG(GLIJ)
52182 CXC(8)=-DCONJG(GRIJ)
52184 S12MAX=(AXMI-AXMJ)**2
52185 CMRENNA.This statement must be here to define S12MAX
52186 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
52187 C...ALL QUARKS BUT T
52188 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52190 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
52191 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52192 IDLAM(LKNT,1)=KSUSY1+21
52195 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52197 XLAM(LKNT)=XLAM(LKNT-1)
52198 IDLAM(LKNT,1)=KSUSY1+21
52204 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52205 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52206 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
52208 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
52209 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52211 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
52214 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52216 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
52217 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52218 IDLAM(LKNT,1)=KSUSY1+21
52225 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52226 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52227 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
52231 T3I=SIGN(1D0,EI+1D-6)/2D0
52232 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52233 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52235 CXC(4)=DCONJG(GLIJ)
52237 CXC(8)=-DCONJG(GRIJ)
52238 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52240 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
52241 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52242 IDLAM(LKNT,1)=KSUSY1+21
52245 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52247 XLAM(LKNT)=XLAM(LKNT-1)
52248 IDLAM(LKNT,1)=KSUSY1+21
52256 C...R-violating decay modes (SKANDS).
52257 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
52262 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
52263 XLAM(0)=XLAM(0)+XLAM(I)
52265 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
52270 C*********************************************************************
52273 C...Calculate decay widths for the charginos (admixtures of
52274 C...charged Wino and charged Higgsino.
52276 C...Input: KCIN = KF code for particle
52277 C...Output: XLAM = widths
52278 C... IDLAM = KF codes for decay particles
52279 C... IKNT = number of decay channels defined
52280 C...AUTHOR: STEPHEN MRENNA
52282 C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
52283 C...when CHIENU .NE. 0
52285 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
52287 C...Double precision and integer declarations.
52288 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52289 IMPLICIT INTEGER(I-N)
52290 INTEGER PYK,PYCHGE,PYCOMP
52291 C...Parameter statement to help give large particle numbers.
52292 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52293 &KEXCIT=4000000,KDIMEN=5000000)
52295 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52296 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52297 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52298 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52299 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52301 C COMMON/PYINTS/XXM(20)
52303 COMMON/PYINTC/XXC(10),CXC(8)
52304 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
52306 C...Local variables
52307 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
52308 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
52310 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
52311 &XMZ,XMZ2,AXMJ,AXMI
52312 DOUBLE PRECISION S12MIN,S12MAX
52313 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
52314 DOUBLE PRECISION PYLAMF,XL
52315 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
52316 DOUBLE PRECISION PYX2XH,PYX2XG
52317 DOUBLE PRECISION XLAM(0:400)
52318 INTEGER IDLAM(400,3)
52319 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
52322 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
52323 DOUBLE PRECISION SR2
52324 DOUBLE PRECISION CBETA,SBETA,TANB
52326 DOUBLE PRECISION PYALEM,PI,PYALPS
52327 DOUBLE PRECISION FCOL
52328 INTEGER KF1,KF2,ISF
52329 INTEGER KFNCHI(4),KFCCHI(2)
52331 DOUBLE PRECISION TEMP
52332 EXTERNAL PYGAUS,PYXXZ6
52333 DOUBLE PRECISION PYGAUS,PYXXZ6
52334 DOUBLE PRECISION PREC
52337 DATA ETAH/1D0,1D0,-1D0/
52338 DATA SR2/1.4142136D0/
52339 DATA PI/3.141592654D0/
52341 DATA KFNCHI/1000022,1000023,1000025,1000035/
52342 DATA KFCCHI/1000024,1000037/
52344 C...COUNT THE NUMBER OF DECAY MODES
52352 TANW = SQRT(XW/XW1)
52354 C...1 OR 2 DEPENDING ON CHARGINO TYPE
52356 IF(KFIN.EQ.KFCCHI(2)) IX=2
52374 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52375 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52379 C...GRAVITINO DECAY MODES
52381 IF(IMSS(11).EQ.1) THEN
52384 XMGR=PMAS(PYCOMP(IDG),1)
52386 C COSW=SQRT(1D0-XW)
52387 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
52388 IF(AXMI.GT.XMGR+XMW) THEN
52394 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
52395 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
52396 & (1D0-XMW2/XMI2)**4
52398 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
52403 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
52404 & (ABS(UMIXC(IX,2))*SBETA)**2))
52405 & *(1D0-PMAS(37,1)**2/XMI2)**4
52409 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52410 IF(IX.EQ.1) GOTO 170
52415 C...CHI_2+ -> CHI_1+ + Z0
52416 IF(AXMI.GE.AXMJ+XMZ) THEN
52419 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
52420 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
52421 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
52422 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
52423 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52424 GLR=DBLE(OLPP*DCONJG(ORPP))
52425 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
52426 IDLAM(LKNT,1)=KFCCHI(1)
52430 C...CHARGED LEPTONS
52431 ELSEIF(AXMI.GE.AXMJ) THEN
52433 S12MAX=(AXMI-AXMJ)**2
52436 EI=KCHG(IABS(IA),1)/3D0
52437 T3I=SIGN(1D0,EI+1D-6)/2D0
52442 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52447 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
52448 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
52449 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
52450 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
52451 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52452 CXC(2)=DCMPLX(0D0,0D0)
52453 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52454 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
52455 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52456 CXC(6)=DCMPLX(0D0,0D0)
52457 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52458 CXC(8)=DCMPLX(0D0,0D0)
52459 IF( XXC(5).LT.AXMI ) THEN
52464 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
52466 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52467 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52468 IDLAM(LKNT,1)=KFCCHI(1)
52471 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
52473 XLAM(LKNT)=XLAM(LKNT-1)
52474 IDLAM(LKNT,1)=KFCCHI(1)
52478 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
52480 XLAM(LKNT)=XLAM(LKNT-1)
52481 IDLAM(LKNT,1)=KFCCHI(1)
52491 EI=KCHG(IABS(IA),1)/3D0
52492 T3I=SIGN(1D0,EI+1D-6)/2D0
52493 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52495 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52496 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52497 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
52498 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52499 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52500 IF( XXC(5).LT.AXMI ) THEN
52505 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
52507 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52508 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52509 IDLAM(LKNT,1)=KFCCHI(1)
52513 XLAM(LKNT)=XLAM(LKNT-1)
52514 IDLAM(LKNT,1)=KFCCHI(1)
52518 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
52519 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52520 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
52522 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
52524 IF( XXC(5).LT.AXMI ) THEN
52529 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52530 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52531 IDLAM(LKNT,1)=KFCCHI(1)
52540 EI=KCHG(IABS(IA),1)/3D0
52541 T3I=SIGN(1D0,EI+1D-6)/2D0
52542 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52544 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52545 CXC(2)=DCMPLX(0D0,0D0)
52546 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52547 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
52548 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52549 CXC(6)=DCMPLX(0D0,0D0)
52550 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52551 CXC(8)=DCMPLX(0D0,0D0)
52552 IF( XXC(5).LT.AXMI ) THEN
52557 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52559 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52560 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52561 IDLAM(LKNT,1)=KFCCHI(1)
52564 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52566 XLAM(LKNT)=XLAM(LKNT-1)
52567 IDLAM(LKNT,1)=KFCCHI(1)
52572 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52573 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52574 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52576 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52578 IF( XXC(5).LT.AXMI ) THEN
52583 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52584 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52585 IDLAM(LKNT,1)=KFCCHI(1)
52594 EI=KCHG(IABS(IA),1)/3D0
52595 T3I=SIGN(1D0,EI+1D-6)/2D0
52596 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52598 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52599 CXC(2)=DCMPLX(0D0,0D0)
52600 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52601 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
52602 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52603 CXC(6)=DCMPLX(0D0,0D0)
52604 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52605 CXC(8)=DCMPLX(0D0,0D0)
52606 IF( XXC(5).LT.AXMI ) THEN
52611 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52613 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52614 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52615 IDLAM(LKNT,1)=KFCCHI(1)
52618 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52620 XLAM(LKNT)=XLAM(LKNT-1)
52621 IDLAM(LKNT,1)=KFCCHI(1)
52629 C...CHI_2+ -> CHI_1+ + H0_K
52637 XMH=PMAS(ITH(IH),1)
52639 C...NO 3-BODY OPTION
52640 IF(AXMI.GE.AXMJ+XMH) THEN
52642 XL=PYLAMF(XMI2,XMJ2,XMH2)
52643 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
52644 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
52645 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
52646 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
52648 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52649 GLR=DBLE(OLPP*DCONJG(ORPP))
52650 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
52651 IDLAM(LKNT,1)=KFCCHI(1)
52652 IDLAM(LKNT,2)=ITH(IH)
52657 C...CHI1 JUMPS TO HERE
52660 C...CHI+_I -> CHI0_J + W+
52665 IF(AXMI.GE.AXMJ+XMW) THEN
52668 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
52670 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
52671 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
52672 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
52673 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
52674 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
52675 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
52676 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
52677 IDLAM(LKNT,1)=KFNCHI(IJ)
52681 ELSEIF(AXMI.GE.AXMJ) THEN
52683 S12MAX=(AXMI-AXMJ)**2
52685 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
52687 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
52688 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
52689 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
52690 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
52691 CXC(5)=DCMPLX(0D0,0D0)
52692 CXC(7)=DCMPLX(0D0,0D0)
52696 T3I=SIGN(1D0,EI+1D-6)/2D0
52698 T3J=SIGN(1D0,EJ+1D-6)/2D0
52699 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
52700 & TANW+ZMIXC(IJ,2)*T3J)/SR2
52701 CXC(4)=-DCONJG(UMIXC(IX,1))*(
52702 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
52703 CXC(6)=DCMPLX(0D0,0D0)
52704 CXC(8)=DCMPLX(0D0,0D0)
52709 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52710 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52713 CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
52714 IF(XXC(5).LT.AXMI) THEN
52716 ELSEIF(XXC(6).LT.AXMI) THEN
52721 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
52722 C...--> 1/(16PI)/M**3*(AEM/XW)**2
52723 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
52725 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52726 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
52727 IDLAM(LKNT,1)=KFNCHI(IJ)
52730 C...ONLY DECAY CHI+1 -> E+ NU_E
52731 IF( IMSS(12).NE. 0 ) GOTO 260
52732 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
52734 XLAM(LKNT)=XLAM(LKNT-1)
52735 IDLAM(LKNT,1)=KFNCHI(IJ)
52740 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
52742 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52743 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
52745 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
52747 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
52748 IF(XXC(5).LT.AXMI) THEN
52750 ELSEIF(XXC(6).LT.AXMI) THEN
52755 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52756 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
52757 IDLAM(LKNT,1)=KFNCHI(IJ)
52762 C...NOW, DO THE QUARKS
52767 T3I=SIGN(1D0,EI+1D-6)/2D0
52769 T3J=SIGN(1D0,EJ+1D-6)/2D0
52770 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
52771 & TANW+ZMIXC(IJ,2)*T3J)
52772 CXC(4)=-DCONJG(UMIXC(IX,1))*(
52773 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
52774 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52775 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52776 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
52777 IF(XXC(5).LT.AXMI) THEN
52780 IF(XXC(6).LT.AXMI) THEN
52785 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
52787 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52788 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52789 IDLAM(LKNT,1)=KFNCHI(IJ)
52792 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52794 XLAM(LKNT)=XLAM(LKNT-1)
52795 IDLAM(LKNT,1)=KFNCHI(IJ)
52804 C...CHI+_I -> CHI0_J + H+
52810 IF(AXMI.GE.AXMJ+XMHP) THEN
52812 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
52813 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
52814 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
52815 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
52817 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52818 GLR=DBLE(OLPP*DCONJG(ORPP))
52819 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52820 IDLAM(LKNT,1)=KFNCHI(IJ)
52828 C...2-BODY DECAYS TO FERMION SFERMION
52830 IF(J.GE.7.AND.J.LE.10) GOTO 240
52831 IF(MOD(J,2).EQ.0) THEN
52837 XMSF1=PMAS(PYCOMP(KF1),1)
52838 XMSF2=PMAS(PYCOMP(KF2),1)
52847 IF(MOD(J,2).EQ.0) THEN
52850 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
52851 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
52857 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
52859 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
52864 IF(AXMI.GE.XMF+XMSF1) THEN
52868 XL=PYLAMF(XMI2,XMA2,XMB2)
52869 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
52870 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
52871 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52872 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52874 IF(MOD(J,2).EQ.0) THEN
52884 IF(AXMI.GE.XMF+XMSF2) THEN
52888 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
52889 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
52890 XL=PYLAMF(XMI2,XMA2,XMB2)
52891 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52892 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52894 IF(MOD(J,2).EQ.0) THEN
52904 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
52905 C...A 2-BODY -- 2-BODY CHAIN
52906 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52907 IF(AXMI.GE.XMJ) THEN
52910 S12MAX=(AXMI-AXMJ)**2
52915 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
52916 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
52919 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
52921 CXC(1)=DCMPLX(0D0,0D0)
52922 CXC(3)=DCMPLX(0D0,0D0)
52923 CXC(5)=DCMPLX(0D0,0D0)
52924 CXC(7)=DCMPLX(0D0,0D0)
52925 CXC(2)=UMIXC(IX,1)*OLPP/SR2
52926 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
52927 CXC(6)=DCMPLX(0D0,0D0)
52928 CXC(8)=DCMPLX(0D0,0D0)
52929 IF(XXC(5).LT.AXMI) THEN
52931 ELSEIF(XXC(6).LT.AXMI) THEN
52936 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
52937 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
52939 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
52940 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52941 IDLAM(LKNT,1)=KSUSY1+21
52944 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52946 XLAM(LKNT)=XLAM(LKNT-1)
52947 IDLAM(LKNT,1)=KSUSY1+21
52955 C...R-violating decay modes (SKANDS).
52956 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
52961 XLAM(0)=XLAM(0)+XLAM(I)
52962 IF(XLAM(I).LT.0D0) THEN
52963 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
52964 & (IDLAM(I,J),J=1,3)
52968 IF(XLAM(0).EQ.0D0) THEN
52970 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
52971 WRITE(MSTU(11),*) LKNT
52972 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
52978 C*********************************************************************
52981 C...Used in the calculation of inoi -> inoj + f + ~f.
52985 C...Double precision and integer declarations.
52986 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52987 IMPLICIT INTEGER(I-N)
52988 INTEGER PYK,PYCHGE,PYCOMP
52989 C...Parameter statement to help give large particle numbers.
52990 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52991 &KEXCIT=4000000,KDIMEN=5000000)
52993 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52994 C COMMON/PYINTS/XXM(20)
52996 COMMON/PYINTC/XXC(10),CXC(8)
52997 SAVE /PYDAT1/,/PYINTC/
52999 C...Local variables.
53000 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
53001 DOUBLE PRECISION PYXXZ6,X
53002 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
53003 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
53004 DOUBLE PRECISION SIJ
53005 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
53006 DOUBLE PRECISION OL2
53007 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
53010 C...Statement functions.
53011 C...Integral from x to y of (t-a)(b-t) dt.
53012 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
53013 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
53014 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
53015 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
53016 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
53017 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
53018 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
53019 C...Integral from x to y of (t-a)/(b-t) dt.
53020 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
53021 C...Integral from x to y of 1/(t-a) dt.
53022 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
53030 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
53031 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
53032 &( (X-XM22-S)**2 -4D0*XM22*S ) )
53034 S23MIN=(S23AVE-S23DEL)
53035 S23MAX=(S23AVE+S23DEL)
53052 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
53053 SIJ=2D0*XXC(2)*XXC(4)*S13
53054 IF(XMV.LE.1000D0) THEN
53055 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
53056 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
53057 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
53058 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
53059 IF(XXC(5).LE.10000D0) THEN
53060 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
53061 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
53062 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
53063 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
53064 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
53065 & *(S13-XMV**2)/WPROP2
53070 IF(XXC(6).LE.10000D0) THEN
53071 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
53072 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
53073 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
53074 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
53075 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
53076 & *(S13-XMV**2)/WPROP2
53085 IF(XXC(5).LE.10000D0) THEN
53086 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
53087 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
53088 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
53089 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
53093 IF(XXC(6).LE.10000D0) THEN
53094 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
53095 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
53096 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
53097 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
53102 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
53104 IF(PYXXZ6.LT.0D0) THEN
53105 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
53106 WRITE(MSTU(11),*) (XXC(I),I=1,5)
53107 WRITE(MSTU(11),*) (XXC(I),I=6,10)
53108 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
53109 WRITE(MSTU(11),*) S23MIN,S23MAX
53117 C*********************************************************************
53120 C...Calculates chi0_i -> chi0_j + gamma.
53122 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
53124 C...Double precision and integer declarations.
53125 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53126 IMPLICIT INTEGER(I-N)
53127 INTEGER PYK,PYCHGE,PYCOMP
53129 C...Local variables.
53130 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
53131 DOUBLE PRECISION F1,F2
53133 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
53134 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
53135 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
53136 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
53141 C*********************************************************************
53144 C...Calculates the decay rate for ino -> ino + gauge boson.
53146 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
53148 C...Double precision and integer declarations.
53149 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53150 IMPLICIT INTEGER(I-N)
53151 INTEGER PYK,PYCHGE,PYCOMP
53153 C...Local variables.
53154 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
53155 DOUBLE PRECISION XL,PYLAMF,C1
53156 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53162 XL=PYLAMF(XMI2,XMJ2,XMV2)
53163 PYX2XG=C1/8D0/XMI3*SQRT(XL)
53164 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
53165 &12D0*GLR*XM1*XM2*XMV2)
53170 C*********************************************************************
53173 C...Calculates the decay rate for ino -> ino + H.
53175 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
53177 C...Double precision and integer declarations.
53178 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53179 IMPLICIT INTEGER(I-N)
53180 INTEGER PYK,PYCHGE,PYCOMP
53182 C...Local variables.
53183 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
53184 DOUBLE PRECISION XL,PYLAMF,C1
53185 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53191 XL=PYLAMF(XMI2,XMJ2,XMV2)
53192 PYX2XH=C1/8D0/XMI3*SQRT(XL)
53193 &*(GX2*(XMI2+XMJ2-XMV2)+
53199 C*********************************************************************
53202 C...Calculates the non-standard decay modes of the Higgs boson.
53204 C...Author: Stephen Mrenna
53205 C...Last Update: April 2001
53206 C......Allow complex values for Z,U, and V
53208 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
53210 C...Double precision and integer declarations.
53211 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53212 IMPLICIT INTEGER(I-N)
53213 INTEGER PYK,PYCHGE,PYCOMP
53214 C...Parameter statement to help give large particle numbers.
53215 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53216 &KEXCIT=4000000,KDIMEN=5000000)
53218 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53219 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53220 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53221 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
53222 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53223 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53224 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
53226 C...Local variables.
53227 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
53228 COMPLEX*16 QIJ,RIJ,F21K,F12K
53230 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
53231 DOUBLE PRECISION XMI2,XMI3,XMJ2
53232 DOUBLE PRECISION PYLAMF,XL,CF,EI
53234 DOUBLE PRECISION TANW,XW,AEM,C1,AS
53235 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
53236 DOUBLE PRECISION XLAM(0:400)
53237 INTEGER IDLAM(400,3)
53238 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
53240 INTEGER KFNCHI(4),KFCCHI(2)
53241 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
53242 DOUBLE PRECISION SR2
53243 DOUBLE PRECISION BETA,ALFA
53244 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
53245 DOUBLE PRECISION PYALEM
53246 DOUBLE PRECISION AL,AR,ALR
53247 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
53248 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
53249 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
53250 DATA ITH/25,35,36,37/
53251 DATA ETAH/1D0,1D0,-1D0/
53252 DATA SR2/1.4142136D0/
53253 DATA KFNCHI/1000022,1000023,1000025,1000035/
53254 DATA KFCCHI/1000024,1000037/
53256 C...COUNT THE NUMBER OF DECAY MODES
53263 TANW = SQRT(XW/(1D0-XW))
53266 C...1 - 4 DEPENDING ON Higgs species.
53268 IF(KFIN.EQ.ITH(2)) IH=2
53269 IF(KFIN.EQ.ITH(3)) IH=3
53270 IF(KFIN.EQ.ITH(4)) IH=4
53293 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
53298 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
53299 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
53304 IF(IH.EQ.4) GOTO 220
53306 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
53307 C...H0_K -> CHI0_I + CHI0_J
53320 IF(AXMI.GE.AXMJ+AXMK) THEN
53322 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
53323 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
53324 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
53325 & ZMIXC(IJ,3)*ZMIXC(IK,1))
53326 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
53327 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
53328 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
53329 & ZMIXC(IJ,4)*ZMIXC(IK,1))
53330 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
53331 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
53332 C...SIGN OF MASSES I,J
53334 GX2=ABS(F12K)**2+ABS(F21K)**2
53335 GLR=DBLE(F12K*DCONJG(F21K))
53336 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
53337 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
53338 IDLAM(LKNT,1)=KFNCHI(IJ)
53339 IDLAM(LKNT,2)=KFNCHI(IK)
53345 C...H0_K -> CHI+_I CHI-_J
53352 IF(AXMI.GE.AXMJ+AXMK) THEN
53354 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
53355 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
53356 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
53357 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
53358 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53359 GLR=DBLE(OLPP*DCONJG(ORPP))
53361 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
53362 IDLAM(LKNT,1)=KFCCHI(IJ)
53363 IDLAM(LKNT,2)=-KFCCHI(IK)
53369 C...HIGGS TO SFERMION SFERMION
53371 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
53373 XMJL=PMAS(PYCOMP(IJ),1)
53374 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
53375 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
53378 XL=PYLAMF(XMI2,XMJ2,XMJ2)
53385 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
53386 & XMF**2/XMW*SINA/CBETA
53387 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
53388 & XMF**2/XMW*SINA/CBETA
53390 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
53392 ELSEIF(IFL.EQ.15) THEN
53393 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
53399 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
53400 & XMF**2/XMW*COSA/SBETA
53401 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
53402 & XMF**2/XMW*COSA/SBETA
53404 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
53411 ELSEIF(IH.EQ.2) THEN
53413 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
53414 & XMF**2/XMW*COSA/CBETA
53415 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
53416 & XMF**2/XMW*COSA/CBETA
53418 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
53420 ELSEIF(IFL.EQ.15) THEN
53421 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
53427 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
53428 & XMF**2/XMW*SINA/SBETA
53429 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
53430 & XMF**2/XMW*SINA/SBETA
53432 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
53439 ELSEIF(IH.EQ.3) THEN
53445 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
53446 ELSEIF(IFL.EQ.15) THEN
53447 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
53451 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
53455 IF(IH.EQ.3) GOTO 180
53459 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
53466 IF(AXMI.GE.2D0*XMJ) THEN
53468 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53470 & +2D0*GHLR*ALR)**2
53476 IF(AXMI.GE.2D0*XMJR) THEN
53480 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
53483 XL=PYLAMF(XMI2,XMJ2,XMJ2)
53484 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53486 & +2D0*GHLR*ALR)**2
53487 IDLAM(LKNT,1)=IJ+KSUSY1
53488 IDLAM(LKNT,2)=-(IJ+KSUSY1)
53493 IF(AXMI.GE.XMJL+XMJR) THEN
53495 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
53496 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
53497 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
53500 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
53501 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53502 & (GHLL*AL+GHRR*AR)**2
53504 IDLAM(LKNT,2)=-(IJ+KSUSY1)
53508 IDLAM(LKNT,2)=IJ+KSUSY1
53510 XLAM(LKNT)=XLAM(LKNT-1)
53520 C...H+ -> CHI+_I + CHI0_J
53528 IF(AXMI.GE.AXMJ+AXMK) THEN
53530 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
53531 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
53532 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
53533 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
53534 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53535 GLR=DBLE(OLPP*DCONJG(ORPP))
53536 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
53537 IDLAM(LKNT,1)=KFNCHI(IJ)
53538 IDLAM(LKNT,2)=KFCCHI(IK)
53544 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
53545 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
53551 XM1=PMAS(PYCOMP(KSUSY1+6),1)
53552 XM2=PMAS(PYCOMP(KSUSY1+5),1)
53553 IF(XMI.GE.XM1+XM2) THEN
53554 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53556 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53557 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
53558 IDLAM(LKNT,1)=KSUSY1+6
53559 IDLAM(LKNT,2)=-(KSUSY1+5)
53564 XM1=PMAS(PYCOMP(KSUSY2+6),1)
53565 XM2=PMAS(PYCOMP(KSUSY1+5),1)
53566 IF(XMI.GE.XM1+XM2) THEN
53567 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53569 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53570 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
53571 IDLAM(LKNT,1)=KSUSY2+6
53572 IDLAM(LKNT,2)=-(KSUSY1+5)
53577 XM1=PMAS(PYCOMP(KSUSY1+6),1)
53578 XM2=PMAS(PYCOMP(KSUSY2+5),1)
53579 IF(XMI.GE.XM1+XM2) THEN
53580 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53582 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53583 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
53584 IDLAM(LKNT,1)=KSUSY1+6
53585 IDLAM(LKNT,2)=-(KSUSY2+5)
53590 XM1=PMAS(PYCOMP(KSUSY2+6),1)
53591 XM2=PMAS(PYCOMP(KSUSY2+5),1)
53592 IF(XMI.GE.XM1+XM2) THEN
53593 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53595 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53596 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
53597 IDLAM(LKNT,1)=KSUSY2+6
53598 IDLAM(LKNT,2)=-(KSUSY2+5)
53603 GL=-XMW/SR2*SIN(2D0*BETA)
53605 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
53606 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
53607 IF(XMI.GE.XM1+XM2) THEN
53608 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53610 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
53611 IDLAM(LKNT,1)=-(KSUSY1+IJ)
53612 IDLAM(LKNT,2)=KSUSY1+IJ+1
53620 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
53621 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
53622 IF(XMI.GE.XM1+XM2) THEN
53623 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53625 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
53626 IDLAM(LKNT,1)=-(KSUSY1+IJ)
53627 IDLAM(LKNT,2)=KSUSY1+IJ+1
53632 C...H+ -> TAU1 NUTAUL
53633 XM1=PMAS(PYCOMP(KSUSY1+15),1)
53634 XM2=PMAS(PYCOMP(KSUSY1+16),1)
53635 IF(XMI.GE.XM1+XM2) THEN
53636 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53638 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
53639 IDLAM(LKNT,1)=-(KSUSY1+15)
53640 IDLAM(LKNT,2)= KSUSY1+16
53644 C...H+ -> TAU2 NUTAUL
53645 XM1=PMAS(PYCOMP(KSUSY2+15),1)
53646 XM2=PMAS(PYCOMP(KSUSY1+16),1)
53647 IF(XMI.GE.XM1+XM2) THEN
53648 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53650 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
53651 IDLAM(LKNT,1)=-(KSUSY2+15)
53652 IDLAM(LKNT,2)= KSUSY1+16
53660 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
53661 XLAM(0)=XLAM(0)+XLAM(I)
53663 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
53668 C*********************************************************************
53671 C...Calculates the decay rate for a Higgs to an ino pair.
53673 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
53675 C...Double precision and integer declarations.
53676 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53677 IMPLICIT INTEGER(I-N)
53678 INTEGER PYK,PYCHGE,PYCOMP
53680 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53683 C...Local variables.
53684 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
53685 DOUBLE PRECISION XL,PYLAMF,C1
53686 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
53692 XL=PYLAMF(XMI2,XMJ2,XMK2)
53693 PYH2XX=C1/4D0/XMI3*SQRT(XL)
53694 &*(GX2*(XMI2-XMJ2-XMK2)-
53696 IF(PYH2XX.LT.0D0) PYH2XX=0D0
53701 C*********************************************************************
53704 C...Integration by adaptive Gaussian quadrature.
53705 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53707 FUNCTION PYGAUS(F, A, B, EPS)
53709 C...Double precision and integer declarations.
53710 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53711 IMPLICIT INTEGER(I-N)
53712 INTEGER PYK,PYCHGE,PYCOMP
53714 C...Local declarations.
53716 DOUBLE PRECISION F,W(12), X(12)
53717 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53718 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53719 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
53720 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
53721 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
53722 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
53723 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
53724 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
53725 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
53726 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
53727 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
53728 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
53730 C...The Gaussian quadrature algorithm.
53732 IF(B .EQ. A) GOTO 140
53733 CONST = 5D-3 / ABS(B-A)
53744 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
53749 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
53752 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
53754 IF(BB .NE. B) GOTO 100
53757 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
53759 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
53768 C*********************************************************************
53771 C...Integration by adaptive Gaussian quadrature.
53772 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53773 C...Carbon copy of PYGAUS, but avoids having to use it recursively.
53775 FUNCTION PYGAU2(F, A, B, EPS)
53777 C...Double precision and integer declarations.
53778 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53779 IMPLICIT INTEGER(I-N)
53780 INTEGER PYK,PYCHGE,PYCOMP
53782 C...Local declarations.
53784 DOUBLE PRECISION F,W(12), X(12)
53785 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53786 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53787 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
53788 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
53789 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
53790 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
53791 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
53792 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
53793 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
53794 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
53795 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
53796 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
53798 C...The Gaussian quadrature algorithm.
53800 IF(B .EQ. A) GOTO 140
53801 CONST = 5D-3 / ABS(B-A)
53812 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
53817 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
53820 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
53822 IF(BB .NE. B) GOTO 100
53825 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
53827 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
53836 C*********************************************************************
53839 C...Simpson formula for an integral.
53841 FUNCTION PYSIMP(Y,X0,X1,N)
53843 C...Double precision and integer declarations.
53844 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53845 IMPLICIT INTEGER(I-N)
53846 INTEGER PYK,PYCHGE,PYCOMP
53848 C...Local variables.
53849 DOUBLE PRECISION Y,X0,X1,H,S
53855 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
53862 C*********************************************************************
53865 C...The standard lambda function.
53867 FUNCTION PYLAMF(X,Y,Z)
53869 C...Double precision and integer declarations.
53870 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53871 IMPLICIT INTEGER(I-N)
53872 INTEGER PYK,PYCHGE,PYCOMP
53874 C...Local variables.
53875 DOUBLE PRECISION PYLAMF,X,Y,Z
53877 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
53878 IF(PYLAMF.LT.0D0) PYLAMF=0D0
53883 C*********************************************************************
53886 C...Generates 3-body decays of gauginos.
53888 SUBROUTINE PYTBDY(IDIN)
53890 C...Double precision and integer declarations.
53891 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53892 IMPLICIT INTEGER(I-N)
53893 INTEGER PYK,PYCHGE,PYCOMP
53894 C...Parameter statement to help give large particle numbers.
53895 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53896 &KEXCIT=4000000,KDIMEN=5000000)
53898 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53899 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53900 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53901 C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
53902 C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53903 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53904 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53905 C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
53906 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
53908 C...Local variables.
53909 DOUBLE PRECISION XM(5)
53910 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
53911 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
53912 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
53913 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
53914 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
53915 DOUBLE PRECISION CPHI1,SPHI1
53916 DOUBLE PRECISION S23DEL,EPS
53917 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
53918 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
53919 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
53921 DATA INOID/22,23,25,35/
53932 S12MIN=(XM(1)+XM(2))**2
53933 S12MAX=(XM(5)-XM(3))**2
53934 YJACO1=S12MAX-S12MIN
53936 C...Initialize some parameters
53948 C...Mrenna: check that we are indeed decaying a SUSY particle
53949 IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
53953 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
53954 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
53956 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
53957 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
53958 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
53959 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
53962 EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
53963 T3I=SIGN(1D0,EI+1D-6)/2D0
53966 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
53968 ELSEIF(IZID1*IZID2.NE.0) THEN
53970 GMMZ=PMAS(23,1)*PMAS(23,2)
53972 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
53973 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
53975 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
53976 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
53978 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
53980 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
53982 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
53983 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
53984 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
53985 XM1M2=SMZ(IZID1)*SMZ(IZID2)
53986 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
53988 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
53990 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
53992 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
53994 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
53995 IF(IZID1.NE.0) THEN
53996 XM1M2=SMZ(IZID1)*SMW(IWID2)
54000 XM1M2=SMZ(IZID2)*SMW(IWID1)
54003 RT2I = 1D0/SQRT(2D0)
54005 GMMZ=PMAS(24,1)*PMAS(24,2)
54007 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54008 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54011 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
54013 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
54014 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
54015 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
54016 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
54017 EJ=KCHG(IABS(JA),1)/3D0
54018 T3J=SIGN(1D0,EJ+1D-6)/2D0
54019 QRLS=DCMPLX(0D0,0D0)
54025 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
54026 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
54027 IF(MOD(IA,2).EQ.0) THEN
54028 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
54029 & TANW+ZMIXC(IZID2,2)*T3I)
54030 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54031 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
54033 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
54034 & TANW+ZMIXC(IZID2,2)*T3J)
54035 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54036 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
54038 ELSEIF(IWID1*IWID2.NE.0) THEN
54041 XM1M2=SMW(IWID1)*SMW(IWID2)
54043 GMMZ=PMAS(23,1)*PMAS(23,2)
54045 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54046 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54047 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
54048 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
54050 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
54051 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
54052 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
54053 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
54054 QRLS=-DCMPLX(EI/XW1)*ORPP
54055 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
54056 QRRS=-DCMPLX(EI/XW1)*OLPP
54057 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
54058 IF(MOD(IA,2).EQ.0) THEN
54059 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
54060 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
54062 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
54063 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
54065 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
54072 IF(ISKIP.NE.0) THEN
54075 S12=S12MIN+YJACO1*(KT-1)/99
54076 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54077 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54078 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54079 & -(2D0*XM(1)*XM(2))**2
54080 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54081 & -(2D0*XM(3)*XM(5))**2
54084 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54086 S23MIN=S23AVE-S23DEL
54087 S23MAX=S23AVE+S23DEL
54088 YJACO2=S23MAX-S23MIN
54091 S23=S23MIN+YJACO2*(KS-1)/99
54094 WU2 = (UH-ZM12)*(UH-ZM22)
54095 WT2 = (TH-ZM12)*(TH-ZM22)
54097 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54098 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54099 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54100 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54101 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54102 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54103 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54104 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
54105 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54106 IF(WT0.GT.WTMAX) WTMAX=WT0
54116 BX=S12MIN+0.5D0*YJACO1
54119 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
54127 C...SOLVE FOR F1 AND F2
54128 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54129 &-(2D0*XM(1)*XM(2))**2
54130 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54131 &-(2D0*XM(3)*XM(5))**2
54134 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54136 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54137 &-(2D0*XM(1)*XM(2))**2
54138 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54139 &-(2D0*XM(3)*XM(5))**2
54142 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54145 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
54146 C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
54152 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54153 & -(2D0*XM(1)*XM(2))**2
54154 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54155 & -(2D0*XM(3)*XM(5))**2
54158 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54165 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54166 & -(2D0*XM(1)*XM(2))**2
54167 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54168 & -(2D0*XM(3)*XM(5))**2
54171 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54176 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
54186 180 S12=S12MIN+PYR(0)*YJACO1
54189 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54190 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54191 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54192 &-(2D0*XM(1)*XM(2))**2
54193 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54194 &-(2D0*XM(3)*XM(5))**2
54197 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54199 S23MIN=S23AVE-S23DEL
54200 S23MAX=S23AVE+S23DEL
54201 YJACO2=S23MAX-S23MIN
54202 S23=S23MIN+PYR(0)*YJACO2
54204 C...CHECK THE SAMPLING
54205 IF(IKNT.GT.100) THEN
54206 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
54209 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
54211 IF(ISKIP.EQ.0) GOTO 190
54217 WU2 = (UH-ZM12)*(UH-ZM22)
54218 WT2 = (TH-ZM12)*(TH-ZM22)
54220 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54221 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54223 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54224 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54225 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54226 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54227 c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
54228 c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
54229 c &/DCMPLX(TH-XML2)
54230 c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
54231 c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
54232 c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
54233 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54234 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
54235 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54237 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
54238 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
54240 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
54241 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
54243 P1=SQRT(D1*D1-XM(1)**2)
54244 P2=SQRT(D2*D2-XM(2)**2)
54245 P3=SQRT(D3*D3-XM(3)**2)
54246 CTHE1=2D0*PYR(0)-1D0
54247 ANG1=2D0*PYR(0)*PARU(1)
54251 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
54253 P(N+1,1)=P1*STHE1*CPHI1
54254 P(N+1,2)=P1*STHE1*SPHI1
54259 ANG3=2D0*PYR(0)*PARU(1)
54262 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
54264 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
54266 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
54267 &+P3*STHE3*SPHI3*SPHI1
54268 &+P3*CTHE3*STHE1*CPHI1
54269 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
54270 &-P3*STHE3*SPHI3*CPHI1
54271 &+P3*CTHE3*STHE1*SPHI1
54272 P(N+3,3)=P3*STHE3*CPHI3*STHE1
54277 P(N+2,I)=-P(N+1,I)-P(N+3,I)
54285 C*********************************************************************
54288 C...Finds the s-hat dependent eigenvalues of the inverse propagator
54289 C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
54290 C...phase space generation. Extended to include techni-a meson, and
54291 C...to return the width.
54293 SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
54295 C...Double precision and integer declarations.
54296 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54297 IMPLICIT INTEGER(I-N)
54298 INTEGER PYK,PYCHGE,PYCOMP
54299 C...Parameter statement to help give large particle numbers.
54300 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54301 &KEXCIT=4000000,KDIMEN=5000000)
54303 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54304 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54305 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54306 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
54307 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
54309 C...Local variables.
54310 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
54311 &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
54312 &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
54319 SINW=MIN(SQRT(PARU(102)),1D0)
54320 COSW=SQRT(1D0-SINW**2)
54322 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
54323 QUPD=2D0*RTCM(2)-1D0
54325 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
54326 FAR=SQRT(AEM/ALPRHT)
54330 FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
54343 AR(2,2) = SH-PMAS(23,1)**2
54344 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
54345 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
54346 AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
54367 CALL PYWIDT(23,SH,WDTP,WDTE)
54368 AT(2,2) = WDTP(0)*SHR
54369 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
54370 AT(3,3) = WDTP(0)*SHR
54371 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
54372 AT(4,4) = WDTP(0)*SHR
54373 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
54374 AT(5,5) = WDTP(0)*SHR
54378 AR(1,1) = SH-PMAS(24,1)**2
54379 AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
54380 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
54387 CALL PYWIDT(24,SH,WDTP,WDTE)
54388 AT(1,1) = WDTP(0)*SHR
54389 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
54390 AT(2,2) = WDTP(0)*SHR
54391 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
54392 AT(3,3) = WDTP(0)*SHR
54395 CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
54400 WX(I)=SQRT(ABS(SH-WR(I)))
54402 IF(WR(I).LT.SXMN) THEN
54412 C*********************************************************************
54415 C...Universal Extra Dimensions Model (UED)
54416 C...Initialize the xd masses and widths
54417 C...M. ELKACIMI 4/03/2006
54418 C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands
54422 C...Double precision and integer declarations.
54423 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54424 IMPLICIT INTEGER(I-N)
54425 INTEGER PYK,PYCHGE,PYCOMP
54427 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54428 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54429 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
54430 C...UED Pythia common
54431 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54433 C...SAVE statements
54434 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPUED/
54436 C...Print out some info about the UED model
54437 WRITE(MSTU(11),7000)
54439 & '********** PYXDIN: initialization of UED ******************',
54441 & 'Universal Extra Dimensions (UED) switched on ',
54443 & 'This implementation is courtesy of',
54444 & ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ',
54445 & ' see [hep-ph/0602198] (Les Houches 2005) ',
54447 & 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ',
54448 & 'Dobrescu), with gravity-mediated decay widths calculated in',
54449 & '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
54450 & 'radiative corrections to the KK masses from [hep/ph0204342]',
54451 & '(Cheng, Matchev, Schmaltz).'
54452 WRITE(MSTU(11),7000)
54454 & 'SM particles can propagate into one small extra dimension ',
54455 & 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
54456 & 'graviton is further allowed to propagate into N = IUED(4)',
54457 & 'large (eV^-1) extra dimensions.'
54458 WRITE(MSTU(11),7000)
54460 & 'The switches and parameters for UED are:',
54461 & ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
54462 & ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
54463 & ' IUED(3): (D=5) number of quark flavours',
54464 & ' IUED(4): (D=6) number of large extra dimensions into',
54465 & ' which the graviton propagates',
54466 & ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
54467 & ' IUED(6): (D=1) With/without rad.corrs. (=1/0)',
54469 & ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
54470 & ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
54471 & ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
54472 & ' when IUED(5)=0',
54473 & ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
54474 WRITE(MSTU(11),7000)
54476 & 'N.B.: the Higgs mass is also a free parameter of the UED ',
54477 & 'model, but is set through pmas(25,1).',
54480 C...Hardcoded switch, required by current implementation
54481 CALL PYGIVE('MSTP(42)=0')
54483 C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
54484 IF(IUED(2).EQ.0) CALL PYGIVE('MDCY(C5100022,1)=0')
54486 C...Calculated the radiative corrections to the KK particle masses
54489 C...Initialize the graviton mass
54490 C...only if the KK particles decays gravitationally
54491 IF(IUED(2).EQ.1) CALL PYGRAM(0)
54493 WRITE(MSTU(11),7000)
54494 & '********** PYXDIN: UED initialization completed ***********'
54496 C...Format to use for comments
54497 7000 FORMAT(' * ',A)
54501 C*********************************************************************
54504 C...Auxiliary to PYXDIN
54505 C...Mass kk states radiative corrections
54506 C...Radiative corrections are included (hep/ph0204342)
54510 C...Double precision and integer declarations.
54511 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54512 IMPLICIT INTEGER(I-N)
54513 INTEGER PYK,PYCHGE,PYCOMP
54515 PARAMETER(KKPART=25,KKFLA=450)
54517 C...UED Pythia common
54518 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54519 C...Pythia common: particles properties
54520 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54522 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54523 C...Decay information.
54524 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54525 C...Resonance width and secondary decay treatment.
54526 COMMON/PYINT4/MWID(500),WIDS(500,5)
54527 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54529 C...Local variables
54530 DOUBLE PRECISION PI,QUP,QDW
54531 DOUBLE PRECISION WDTP,WDTE
54532 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
54533 DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3
54534 DOUBLE PRECISION DSMG2,LOGLAM,DBMG2
54535 DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE
54536 DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2
54537 DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2
54538 DOUBLE PRECISION SWW1,CWW1
54539 DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST
54540 DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE
54541 DOUBLE PRECISION SW21,CW21,SW021,CW021
54542 COMMON/SW1/SW021,CW021
54543 C...UED related declarations:
54544 C...equivalences between ordered particles (451->475)
54545 C...and UED particle code (5 000 000 + id)
54546 DIMENSION IUEDEQ(475)
54547 DATA (IUEDEQ(I),I=451,475)/
54549 & 6100001,6100002,6100003,6100004,6100005,6100006,
54551 & 5100001,5100002,5100003,5100004,5100005,5100006,
54552 C...Singlet leptons
54553 & 6100011,6100013,6100015,
54554 C...Doublet leptons
54555 & 5100012,5100011,5100014,5100013,5100016,5100015,
54556 C...Gauge boson KK excitations
54557 & 5100021,5100022,5100023,5100024/
54559 C...N.B. rinv=rued(1)
54560 IF(RUED(1).LE.0.)THEN
54561 WRITE(MSTU(11),*) 'PYUEDC: RINV < 0 : ',RUED(1)
54562 WRITE(MSTU(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
54575 c...qt is q-tilde, qs is q-star
54576 c...strong coupling value
54580 c...weak mixing angle
54584 c...for the mass corrections
54589 C... Either fix the cutoff scale LAMUED
54590 IF(IUED(5).EQ.0)THEN
54591 LOGLAM = DLOG((RUED(3)*(1./RUED(1)))**2)
54592 C... or the ratio LAMUED/RINV (=product Lambda*R)
54593 ELSEIF(IUED(5).EQ.1)THEN
54594 LOGLAM = DLOG(RUED(4)**2)
54596 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
54600 C...Calculate the radiative corrections for the UED KK masses
54601 IF(IUED(6).EQ.1)THEN
54603 C...or induce a minute mass difference
54604 C...keeping the UED KK mass values nearly equal to 1/R
54605 ELSEIF(IUED(6).EQ.0)THEN
54608 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
54612 c...Take into account only the strong interactions:
54614 c...The space bulk corrections :
54615 DSMG2 = RMKK2*(-1.5)*(ALPHS/4./PI)*ZETA3/PI**2
54616 c...The boundary terms:
54617 DBMG2 = RMKK2*(23./2.)*(ALPHS/4./PI)*LOGLAM
54619 c...Mass corrections for fermions are extracted from
54620 c...Phys. Rev. D66 036005(2002)9
54621 DBMQDO=RMKK*(3.*(ALPHS/4./PI)+27./16.*(ALPHEM/4./PI/SW2)
54622 . +1./16.*(ALPHEM/4./PI/CW2))*LOGLAM
54623 DBMQU=RMKK*(3.*(ALPHS/4./PI)
54624 . +(ALPHEM/4./PI/CW2))*LOGLAM
54625 DBMQD=RMKK*(3.*(ALPHS/4./PI)
54626 . +0.25*(ALPHEM/4./PI/CW2))*LOGLAM
54628 DBMLDO=RMKK *((27./16.)*(ALPHEM/4./PI/SW2)+9./16.*
54629 . (ALPHEM/4./PI/CW2))*LOGLAM
54630 DBMLE=RMKK *(9./4.*(ALPHEM/4./PI/CW2))*LOGLAM
54632 c...Vector boson masss matrix diagonalization
54633 DBMB2 = RMKK2*(-1./6.)*(ALPHEM/4./PI/CW2)*LOGLAM
54634 DSMB2 = RMKK2*(-39./2.)*(ALPHEM/4./PI**3/CW2)*ZETA3
54635 DBMA2 = RMKK2*(15./2.)*(ALPHEM/4./PI/SW2)*LOGLAM
54636 DSMA2 = RMKK2*(-5./2.)*(ALPHEM/4./PI**3/SW2)*ZETA3
54638 c...Elements of the mass matrix
54639 A = RMZ2*SW2 + DBMB2 + DSMB2
54640 B = RMZ2*CW2 + DBMA2 + DSMA2
54641 C = RMZ2*DSQRT(SW2*CW2)
54642 SQRDEL = DSQRT( (A-B)**2 + 4*C**2 )
54644 c...Eigenvalues: corrections to X1 and Z1 masses
54645 DMB2 = (A+B-SQRDEL)/2.
54646 DMA2 = (A+B+SQRDEL)/2.
54648 c...Rotation angles
54652 SW21= SWW1**2/(SWW1**2 + CWW1**2)
54659 RMGST = RMKK+RFACT*(DSQRT(RMKK2 + DSMG2 + DBMG2)-RMKK)
54661 RMDQST=RMKK+RFACT*DBMQDO
54662 RMSQUS=RMKK+RFACT*DBMQU
54663 RMSQDS=RMKK+RFACT*DBMQD
54665 C...Note: MZ mass is included in ma2
54666 RMPHST= RMKK+RFACT*(DSQRT(RMKK2 + DMB2)-RMKK)
54667 RMZST = RMKK+RFACT*(DSQRT(RMKK2 + DMA2)-RMKK)
54668 RMWST = RMKK+RFACT*(DSQRT(RMKK2 + DBMA2 + DSMA2 + RMW**2)-RMKK)
54670 RMLSLD=RMKK+RFACT*DBMLDO
54671 RMLSLE=RMKK+RFACT*DBMLE
54674 PMAS(KKFLA+IPART,1)=RMSQDS
54677 PMAS(KKFLA+IPART,1)=RMSQUS
54680 PMAS(KKFLA+IPART,1)=RMDQST
54683 PMAS(KKFLA+IPART,1)=RMLSLE
54686 PMAS(KKFLA+IPART,1)=RMLSLD
54688 PMAS(KKFLA+22,1)=RMGST
54689 PMAS(KKFLA+23,1)=RMPHST
54690 PMAS(KKFLA+24,1)=RMZST
54691 PMAS(KKFLA+25,1)=RMWST
54693 WRITE(MSTU(11),7000) ' PYUEDC: ',
54694 & 'UED Mass Spectrum (GeV) :'
54695 WRITE(MSTU(11),7100) ' m(d*_S,s*_S,b*_S) = ',RMSQDS
54696 WRITE(MSTU(11),7100) ' m(u*_S,c*_S,t*_S) = ',RMSQUS
54697 WRITE(MSTU(11),7100) ' m(q*_D) = ',RMDQST
54698 WRITE(MSTU(11),7100) ' m(l*_S) = ',RMLSLE
54699 WRITE(MSTU(11),7100) ' m(l*_D) = ',RMLSLD
54700 WRITE(MSTU(11),7100) ' m(g*) = ',RMGST
54701 WRITE(MSTU(11),7100) ' m(gamma*) = ',RMPHST
54702 WRITE(MSTU(11),7100) ' m(Z*) = ',RMZST
54703 WRITE(MSTU(11),7100) ' m(W*) = ',RMWST
54704 WRITE(MSTU(11),7000) ' '
54706 C...Initialize widths, branching ratios and life time
54709 IF(MWID(KC).EQ.1.AND.MDCY(KC,1).EQ.1)THEN
54710 CALL PYWIDT(IUEDEQ(KC),PMAS(KC,1)**2,WDTP,WDTE)
54711 IF(WDTP(0).LE.0)THEN
54713 + 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', KC
54714 WRITE(MSTU(11),*) 'INITIAL VALUE IS TAKEN',PMAS(KC,2)
54717 DO 180 IDC=1,MDCY(KC,3)
54718 IC=IDC+MDCY(KC,2)-1
54719 IF(MDME(IC,1).EQ.1.AND.WDTP(IDC).GT.0.)THEN
54720 C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm
54721 PMAS(KC,4)=PARU(3)/WDTP(IDC)*1.D-12
54722 BRAT(IC)=WDTP(IDC)/WDTP(0)
54729 C...Format to use for comments
54730 7000 FORMAT(' * ',A)
54731 7100 FORMAT(' * ',A,F12.3)
54734 C********************************************************************
54737 C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
54738 C... Original version:
54741 C Universal Extra Dimensions Subprocess cross sections
54742 C The expressions used are from atl-com-phys-2005-003
54743 C What is coded here is shat**2/pi * dsigma/dt = |M|**2
54744 C For each UED subprocess, the color flow used is the same
54745 C as the equivalent QCD subprocess. Different configuration
54746 C color flows are considered to have the same probability.
54748 C The Xsection is calculated following ATL-PHYS-PUB-2005-003
54749 C by G.Azuelos and P.H.Beauchemin.
54751 C This routine is called from pysigh.
54753 SUBROUTINE PYXUED(NCHN,SIGS)
54755 C...Double precision and integer declarations
54756 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54757 IMPLICIT INTEGER(I-N)
54760 COMMON/DECMOD/NGRDEC
54762 PARAMETER(KKPART=25,KKFLA=450)
54764 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54765 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54766 COMMON/PYINT1/MINT(400),VINT(400)
54767 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
54768 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
54769 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
54770 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
54771 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
54772 SAVE /PYDAT2/,/PYINT1/,/PYINT3/,/PYPARS/
54773 C...UED Pythia common
54774 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54775 C...Local arrays and complex variables
54776 DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS
54777 + ,FAC1,XMNKK,XMUED,SIGS
54780 C...Return if UED not switched on
54781 IF (IUED(1).LE.0) THEN
54785 C...Energy scale of the parton processus
54786 C...taken equal to the mass of the final state kk
54789 C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
54790 XMNKK=PMAS(KKFLA+23,1)
54792 C...To compare the cross section with phys-pub-2005-03
54793 C...(no radiative corrections),
54794 C...take xmnkk=rinv and q2=rinv**2
54796 C...n.b. (rinv=rued(1))
54797 c IF(NGRDEC.EQ.1)XMNKK=RUED(0)
54798 IF(NGRDEC.EQ.1)XMNKK=RUED(1)
54807 BETA34=DSQRT(1.D0-4.D0*XMNKK**2/SHAT)
54810 c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
54811 Q2=RUED(1)**2+(TP*UP-RUED(1)**4)/SP
54813 c IF(NGRDEC.EQ.1)Q2=RUED(0)**2
54814 IF(NGRDEC.EQ.1)Q2=RUED(1)**2
54817 C...Strong coupling value
54820 IF(ISUB.EQ.311)THEN
54822 FAC1=9./8.*ALPHAS**2/(SP*TP*UP)**2
54823 XMUED=FAC1*(XMNKK**4*(6.*TP**4+18.*TP**3*UP+
54824 & 24.*TP**2*UP**2+18.*TP*UP**3+6.*UP**4)
54825 & +XMNKK**2*(6.*TP**4*UP+12.*TP**3*UP**2+
54826 & 12.*TP**2*UP**3+6*TP*UP**4)
54827 & +2.*TP**6+6*TP**5*UP+13*TP**4*UP**2+
54828 & 15.*TP**3*UP**3+13*TP**2*UP**4+
54829 & 6.*TP*UP**5+2.*UP**6)
54833 C...Three color flow configurations (qcd g+g->g+g)
54835 IF(XCOL.LE.1./3.)THEN
54837 ELSEIF(XCOL.LE.2./3.)THEN
54842 SIGH(NCHN)=COMFAC*XMUED
54843 ELSEIF(ISUB.EQ.312)THEN
54844 C...q + g -> q*_D + g*, q*_S + g*
54845 C...(the two channels have the same cross section)
54846 FAC1=-1./36.*ALPHAS**2/(SP*TP*UP)**2
54847 XMUED=FAC1*(12.*SP*UP**5+5.*SP**2*UP**4+22.*SP**3*UP**3+
54848 & 5.*SP**4*UP**2+12.*SP**5*UP)
54849 XMUED=COMFAC*2.*XMUED
54851 DO 190 I=MMINA,MMAXA
54852 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
54855 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
54856 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
54859 ISIG(NCHN,3-ISDE)=21
54862 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
54866 ELSEIF(ISUB.EQ.313)THEN
54867 C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj
54868 C...(the two channels have the same cross section)
54869 C...qi and qj have the same charge sign
54870 DO 100 I=MMIN1,MMAX1
54872 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 100
54873 DO 101 J=MMIN2,MMAX2
54875 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).
54877 IF(J*I.LE.0)GOTO 101
54882 FAC1=1./72.*ALPHAS**2/(TP*UP)**2
54884 & (XMNKK**2*(8*TP**3+4./3.*TP**2*UP+4./3.*TP*UP**2
54885 & +8.*UP**3)+8.*TP**4+56./3.*TP**3*UP+
54886 & 20.*TP**2*UP**2+56./3.*
54887 & TP*UP**3+8.*UP**4)
54888 SIGH(NCHN)=COMFAC*2.*XMUED
54890 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
54892 FAC1=2./9.*ALPHAS**2/TP**2
54893 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
54894 SIGH(NCHN)=COMFAC*2.*XMUED
54899 ELSEIF(ISUB.EQ.314)THEN
54900 C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
54901 C...(the two channels have the same cross section)
54905 ISIG(NCHN,3)=INT(1.5+PYR(0))
54907 FAC1=5./6.*ALPHAS**2/(SP*TP*UP)**2
54908 XMUED=FAC1*(-XMNKK**4*(8.*TP*UP**3+8.*TP**2*UP**2+8.*TP**3*UP
54909 + +4.*UP**4+4*TP**4)
54910 + -XMNKK**2*(0.5*TP*UP**4+4.*TP**2*UP**3+15./2.*TP**3
54911 + *UP**2+ 4.*TP**4*UP)+TP*UP**5-0.25*TP**2*UP**4+
54912 + 2.*TP**3*UP**3-0.25*TP**4*UP**2+TP**5*UP)
54914 SIGH(NCHN)=COMFAC*XMUED
54915 C...has been multiplied by 5: all possible quark flavors in final state
54917 ELSEIF(ISUB.EQ.315)THEN
54918 C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
54919 C...(the two channels have the same cross section)
54920 DO 141 I=MMIN1,MMAX1
54921 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
54922 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 141
54923 DO 142 J=MMIN2,MMAX2
54924 IF(J.EQ.0.OR.ABS(I).NE.ABS(J).OR.I*J.GE.0) GOTO 142
54925 FAC1=2./9.*ALPHAS**2*1./(SP*TP)**2
54926 XMUED=FAC1*(XMNKK**2*SP*(4.*TP**2-SP*TP-SP**2)+
54927 & 4.*TP**4+3.*SP*TP**3+11./12.*TP**2*SP**2-
54928 & 2./3.*SP**3*TP+SP**4)
54933 SIGH(NCHN)=COMFAC*2.*XMUED
54936 ELSEIF(ISUB.EQ.316)THEN
54937 C...q + qbar' -> q*_D + q*_Sbar'
54938 FAC1=2./9.*ALPHAS**2
54939 DO 300 I=MMIN1,MMAX1
54941 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 300
54942 DO 301 J=MMIN2,MMAX2
54944 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 301
54945 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 301
54950 FAC1=2./9.*ALPHAS**2/TP**2
54951 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
54952 SIGH(NCHN)=COMFAC*XMUED
54956 ELSEIF(ISUB.EQ.317)THEN
54957 C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar'
54958 C...(the two channels have the same cross section)
54959 DO 400 I=MMIN1,MMAX1
54961 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 400
54962 DO 401 J=MMIN1,MMAX1
54964 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 401
54965 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 401
54970 FAC1=1./18.*ALPHAS**2/TP**2
54971 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
54972 SIGH(NCHN)=COMFAC*2.*XMUED
54975 ELSEIF(ISUB.EQ.318)THEN
54976 C...q + q' -> q*_D + q*_S'
54977 DO 500 I=MMIN1,MMAX1
54979 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 500
54980 DO 501 J=MMIN2,MMAX2
54982 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 501
54983 IF(J*I.LE.0)GOTO 501
54988 ISIG(NCHN,3)=INT(1.5+PYR(0))
54989 FAC1=1./36.*ALPHAS**2/(TP*UP)**2
54990 XMUED=FAC1*(-8.*XMNKK**2*(TP**3+TP**2*UP+TP*UP**2+UP**3)
54991 & +8.*TP**4+4.*TP**2*UP**2+8.*UP**4)
54992 SIGH(NCHN)=COMFAC*XMUED
54998 FAC1=1./18.*ALPHAS**2/TP**2
54999 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
55000 SIGH(NCHN)=COMFAC*2.*XMUED
55004 ELSEIF(ISUB.EQ.319)THEN
55005 C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
55006 C...(the two channels have the same cross section)
55007 DO 741 I=MMIN1,MMAX1
55008 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
55009 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 741
55010 DO 742 J=MMIN2,MMAX2
55011 IF(J.EQ.0.OR.IABS(J).NE.IABS(I).OR.J*I.GT.0) GOTO 742
55012 FAC1=16./9.*ALPHAS**2*1./(SP)**2
55013 XMUED=FAC1*(2.*XMNKK**2*SP+SP**2+2.*SP*TP+2.*TP**2)
55018 SIGH(NCHN)=COMFAC*2.*XMUED
55026 C*********************************************************************
55029 C...Universal Extra Dimensions Model (UED)
55030 C...Computation of the Graviton mass.
55032 SUBROUTINE PYGRAM(IN)
55034 C...Double precision and integer declarations
55035 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55036 IMPLICIT INTEGER(I-N)
55038 C...Pythia commonblocks
55039 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55040 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55041 C...UED Pythia common
55042 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55044 C...Local variables
55046 PARAMETER(KCFLA=450,NMAX=5000)
55047 DIMENSION YVEC(5000),RESVEC(5000)
55048 COMMON/INTSAV/YSAV,YMAX,RESMAX
55049 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55050 COMMON/KAPPA/XKAPPA
55052 C...External function (used in call to PYGAUS)
55055 C...SAVE statements
55056 SAVE /PYDAT1/,/PYDAT2/,/PYPUED/,/INTSAV/
55064 C...Initialize for numerical integration
55066 XKAPPA=DSQRT(2.D0)/XMPLNK
55068 C...For NDIM=2, compute graviton mass distribution numerically
55071 C... For first event: tabulate distribution of stepwise integrals:
55072 C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
55077 YSAV = (I-0.5)/DBLE(NMAX)
55079 C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
55080 RESINT = PYGAUS(PYGRAW,0D0,1D0,TOL)
55083 C... Save max of distribution (for accept/reject below)
55084 IF(RESINT.GT.RESMAX)THEN
55091 C... Generate Mg for each graviton (1D0 ensures a minimal open phase space)
55094 XMGAMK=PMAS(KCGAKK,1)
55096 C... Pick random graviton mass, accept according to stored integrals
55097 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55098 110 RMG=AMMAX*PYR(0)
55101 C... Bin enumeration starts at 1, but make sure always in range
55103 IBIN=MIN(IBIN,NMAX)
55104 IF(RESVEC(IBIN)/RESMAX.LT.PYR(0)) GOTO 110
55106 C... For NDIM=4 and 6, the analytical expression for the
55107 C... graviton mass distribution integral is used.
55108 ELSEIF(NDIM.EQ.4.OR.NDIM.EQ.6)THEN
55110 C... Ensure minimal open phase space (max(mG*) < m(gamma*))
55113 C... KK photon (?) compressed code and mass
55115 XMGAMK=PMAS(KCGAKK,1)
55117 C... Find maximum of (dGamma/dMg)
55123 RESINT=Y**(NDIM-3)*(1D0/(1D0-Y**2))*(1D0+DCOS(PI*Y))
55124 IF(RESINT.GE.RESMAX)THEN
55131 C... Pick random graviton mass, accept/reject
55132 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55133 130 RMG=AMMAX*PYR(0)
55135 DGADMG=X**(NDIM-3)*(1./(1.-X**2))*(1.+DCOS(PI*X))
55136 IF(DGADMG/RESMAX.LT.PYR(0)) GOTO 130
55138 C... If the user has not chosen N=2,4 or 6, STOP
55140 WRITE(MSTU(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',NDIM,
55141 & ' (MUST BE 2, 4, OR 6) '
55145 C... Now store the sampled Mg
55151 C*********************************************************************
55154 C...Universal Extra Dimensions Model (UED)
55156 C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
55158 C...Integrand for the KK boson -> SM boson + graviton
55159 C...graviton mass distribution (and gravity mediated total width),
55160 C...which contains (see 0201300 and below for the full product)
55161 C...the gravity mediated partial decay width Gamma(xx, yy)
55162 C... i.e. GRADEN(YY)*PYWDKK(XXA)
55163 C... where xx is exclusive to gravity
55164 C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55165 C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.
55167 DOUBLE PRECISION FUNCTION PYGRAW(YIN)
55169 C...Double precision and integer declarations
55170 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55171 IMPLICIT INTEGER (I-N)
55173 C...Pythia commonblocks
55174 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55176 C...Local UED commonblocks and variables
55177 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55178 COMMON/INTSAV/YSAV,YMAX,RESMAX
55180 C...SAVE statements
55181 SAVE /PYDAT1/,/INTSAV/
55183 C...External: Pythia's Gamma function
55192 XX=DSQRT(1.-YY**2)*YIN
55193 DJAC=(1.-YMIN)*DSQRT(1.-YY**2)
55194 FAC=2.*PI**((NDIM-1.)/2.)*XMPLNK**2*RINV**NDIM/XMD**(NDIM+2)
55198 XXA=DSQRT(XX**2+YY**2)
55199 GRADEN=4./PI2 * (YY**2/(1.-YY**2)**2)*(1.+DCOS(PI*YY))
55202 + FAC*XX**(NDIM-2)*GRADEN*PYWDKK(XXA)
55206 C*********************************************************************
55209 C...Universal Extra Dimensions Model (UED)
55211 C...Multiplied by the square modulus of a form factor
55212 C...(see GRADEN in function PYGRAW)
55213 C...PYWDKK is the KK boson -> SM boson + graviton
55214 C...gravity mediated partial decay width Gamma(xx, yy)
55215 C... where xx is exclusive to gravity
55216 C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55217 C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
55219 C...N.B. The Feynman rules for the couplings of the graviton fields
55220 C...to the UED fields are related to the corresponding couplings of
55221 C...the graviton fields to the SM fields by the form factor.
55223 DOUBLE PRECISION FUNCTION PYWDKK(X)
55225 C...Double precision and integer declarations
55226 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55227 IMPLICIT INTEGER (I-N)
55229 C...Pythia commonblocks
55230 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55231 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55233 C...Local UED commonblocks and variables
55234 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55235 COMMON/KAPPA/XKAPPA
55237 C...SAVE statements
55238 SAVE /PYDAT1/,/PYDAT2/,/UEDGRA/,/KAPPA/
55242 C...gamma* mass 473
55244 XMNKK=PMAS(KCQKK,1)
55246 C...Bosons partial width Macesanu hep-ph/0201300
55247 PYWDKK=XKAPPA**2/(96.*PI)*XMNKK**3/X**4*
55248 + ((1.-X**2)**2*(1.+3.*X**2+6.*X**4))
55253 C*********************************************************************
55256 C...Finds eigenvalues of a general complex matrix
55258 C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
55259 C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
55260 C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
55261 C OF A COMPLEX GENERAL MATRIX.
55265 C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
55266 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55267 C DIMENSION STATEMENT.
55269 C N IS THE ORDER OF THE MATRIX A=(AR,AI).
55271 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
55272 C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
55274 C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
55275 C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
55276 C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
55280 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55281 C RESPECTIVELY, OF THE EIGENVALUES.
55283 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55284 C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
55286 C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
55287 C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
55288 C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
55290 C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
55292 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55293 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55295 C THIS VERSION DATED AUGUST 1983.
55298 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
55300 INTEGER N,NM,IS1,IS2,IERR,MATZ
55301 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55302 X FV1(5),FV2(5),FV3(5)
55303 IF (N .LE. NM) GOTO 100
55307 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
55308 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
55309 IF (MATZ .NE. 0) GOTO 110
55310 C .......... FIND EIGENVALUES ONLY ..........
55311 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
55313 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
55314 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
55315 IF (IERR .NE. 0) GOTO 120
55316 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
55320 C*********************************************************************
55323 C...Auxiliary to PYEICG.
55325 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55326 C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
55328 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
55329 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55330 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55332 C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
55333 C UPPER HESSENBERG MATRIX BY THE QR METHOD.
55337 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55338 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55339 C DIMENSION STATEMENT.
55341 C N IS THE ORDER OF THE MATRIX.
55343 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55344 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55345 C SET LOW=1, IGH=N.
55347 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55348 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55349 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
55350 C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
55351 C THE REDUCTION BY CORTH, IF PERFORMED.
55355 C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
55356 C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
55357 C CALLING COMQR IF SUBSEQUENT CALCULATION OF
55358 C EIGENVECTORS IS TO BE PERFORMED.
55360 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55361 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55362 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55363 C FOR INDICES IERR+1,...,N.
55366 C ZERO FOR NORMAL RETURN,
55367 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55368 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55370 C CALLS PYCDIV FOR COMPLEX DIVISION.
55371 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55372 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55374 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55375 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55377 C THIS VERSION DATED AUGUST 1983.
55380 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
55382 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
55383 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
55384 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55388 IF (LOW .EQ. IGH) GOTO 130
55389 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55394 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
55395 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
55396 YR = HR(I,I-1) / NORM
55397 YI = HI(I,I-1) / NORM
55402 SI = YR * HI(I,J) - YI * HR(I,J)
55403 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
55408 SI = YR * HI(J,I) + YI * HR(J,I)
55409 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
55414 C .......... STORE ROOTS ISOLATED BY CBAL ..........
55415 130 DO 140 I = 1, N
55416 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
55425 C .......... SEARCH FOR NEXT EIGENVALUE ..........
55426 150 IF (EN .LT. LOW) GOTO 320
55429 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55430 C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
55431 160 DO 170 LL = LOW, EN
55433 IF (L .EQ. LOW) GOTO 180
55434 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
55435 X + DABS(HR(L,L)) + DABS(HI(L,L))
55436 TST2 = TST1 + DABS(HR(L,L-1))
55437 IF (TST2 .EQ. TST1) GOTO 180
55439 C .......... FORM SHIFT ..........
55440 180 IF (L .EQ. EN) GOTO 300
55441 IF (ITN .EQ. 0) GOTO 310
55442 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
55445 XR = HR(ENM1,EN) * HR(EN,ENM1)
55446 XI = HI(ENM1,EN) * HR(EN,ENM1)
55447 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
55448 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
55449 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
55450 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
55451 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
55454 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
55458 C .......... FORM EXCEPTIONAL SHIFT ..........
55459 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
55462 210 DO 220 I = LOW, EN
55463 HR(I,I) = HR(I,I) - SR
55464 HI(I,I) = HI(I,I) - SI
55471 C .......... REDUCE TO TRIANGLE (ROWS) ..........
55477 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
55478 XR = HR(I-1,I-1) / NORM
55480 XI = HI(I-1,I-1) / NORM
55483 HI(I-1,I-1) = 0.0D0
55484 HI(I,I-1) = SR / NORM
55491 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
55492 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
55493 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
55494 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
55500 IF (SI .EQ. 0.0D0) GOTO 250
55501 NORM = PYTHAG(HR(EN,EN),SI)
55502 SR = HR(EN,EN) / NORM
55506 C .......... INVERSE OPERATION (COLUMNS) ..........
55507 250 DO 280 J = LP1, EN
55516 IF (I .EQ. J) GOTO 260
55518 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55519 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55520 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55521 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55526 IF (SI .EQ. 0.0D0) GOTO 160
55531 HR(I,EN) = SR * YR - SI * YI
55532 HI(I,EN) = SR * YI + SI * YR
55536 C .......... A ROOT FOUND ..........
55537 300 WR(EN) = HR(EN,EN) + TR
55538 WI(EN) = HI(EN,EN) + TI
55541 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55542 C CONVERGED AFTER 30*N ITERATIONS ..........
55547 C*********************************************************************
55550 C...Auxiliary to PYEICG.
55552 C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55553 C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
55555 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
55556 C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55557 C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55559 C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
55560 C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
55561 C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
55562 C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
55563 C THIS GENERAL MATRIX TO HESSENBERG FORM.
55567 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55568 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55569 C DIMENSION STATEMENT.
55571 C N IS THE ORDER OF THE MATRIX.
55573 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55574 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55575 C SET LOW=1, IGH=N.
55577 C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
55578 C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
55579 C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
55580 C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
55581 C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
55583 C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55584 C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55585 C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
55586 C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
55587 C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
55588 C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
55593 C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
55594 C HAVE BEEN DESTROYED.
55596 C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55597 C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55598 C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55599 C FOR INDICES IERR+1,...,N.
55601 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55602 C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
55603 C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
55604 C THE EIGENVECTORS HAS BEEN FOUND.
55607 C ZERO FOR NORMAL RETURN,
55608 C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55609 C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55611 C CALLS PYCDIV FOR COMPLEX DIVISION.
55612 C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55613 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55615 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55616 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55618 C THIS VERSION DATED OCTOBER 1989.
55620 C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
55621 C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
55624 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
55626 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
55627 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
55628 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55630 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55634 C .......... INITIALIZE EIGENVECTOR MATRIX ..........
55643 C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
55644 C FROM THE INFORMATION LEFT BY CORTH ..........
55645 IEND = IGH - LOW - 1
55646 IF (IEND.LT.0) GOTO 220
55647 IF (IEND.EQ.0) GOTO 170
55648 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
55649 DO 160 II = 1, IEND
55651 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
55652 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
55653 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
55654 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
55657 DO 120 K = IP1, IGH
55658 ORTR(K) = HR(K,I-1)
55659 ORTI(K) = HI(K,I-1)
55667 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
55668 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
55675 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
55676 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
55682 C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55687 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
55688 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
55689 YR = HR(I,I-1) / NORM
55690 YI = HI(I,I-1) / NORM
55695 SI = YR * HI(I,J) - YI * HR(I,J)
55696 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
55701 SI = YR * HI(J,I) + YI * HR(J,I)
55702 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
55706 DO 200 J = LOW, IGH
55707 SI = YR * ZI(J,I) + YI * ZR(J,I)
55708 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
55713 C .......... STORE ROOTS ISOLATED BY CBAL ..........
55714 220 DO 230 I = 1, N
55715 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
55724 C .......... SEARCH FOR NEXT EIGENVALUE ..........
55725 240 IF (EN .LT. LOW) GOTO 430
55728 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55729 C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
55730 250 DO 260 LL = LOW, EN
55732 IF (L .EQ. LOW) GOTO 270
55733 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
55734 X + DABS(HR(L,L)) + DABS(HI(L,L))
55735 TST2 = TST1 + DABS(HR(L,L-1))
55736 IF (TST2 .EQ. TST1) GOTO 270
55738 C .......... FORM SHIFT ..........
55739 270 IF (L .EQ. EN) GOTO 420
55740 IF (ITN .EQ. 0) GOTO 550
55741 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
55744 XR = HR(ENM1,EN) * HR(EN,ENM1)
55745 XI = HI(ENM1,EN) * HR(EN,ENM1)
55746 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
55747 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
55748 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
55749 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
55750 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
55753 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
55757 C .......... FORM EXCEPTIONAL SHIFT ..........
55758 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
55761 300 DO 310 I = LOW, EN
55762 HR(I,I) = HR(I,I) - SR
55763 HI(I,I) = HI(I,I) - SI
55770 C .......... REDUCE TO TRIANGLE (ROWS) ..........
55776 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
55777 XR = HR(I-1,I-1) / NORM
55779 XI = HI(I-1,I-1) / NORM
55782 HI(I-1,I-1) = 0.0D0
55783 HI(I,I-1) = SR / NORM
55790 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
55791 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
55792 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
55793 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
55799 IF (SI .EQ. 0.0D0) GOTO 350
55800 NORM = PYTHAG(HR(EN,EN),SI)
55801 SR = HR(EN,EN) / NORM
55805 IF (EN .EQ. N) GOTO 350
55811 HR(EN,J) = SR * YR + SI * YI
55812 HI(EN,J) = SR * YI - SI * YR
55814 C .......... INVERSE OPERATION (COLUMNS) ..........
55815 350 DO 390 J = LP1, EN
55824 IF (I .EQ. J) GOTO 360
55826 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55827 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55828 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55829 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55832 DO 380 I = LOW, IGH
55837 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55838 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55839 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55840 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55845 IF (SI .EQ. 0.0D0) GOTO 250
55850 HR(I,EN) = SR * YR - SI * YI
55851 HI(I,EN) = SR * YI + SI * YR
55854 DO 410 I = LOW, IGH
55857 ZR(I,EN) = SR * YR - SI * YI
55858 ZI(I,EN) = SR * YI + SI * YR
55862 C .......... A ROOT FOUND ..........
55863 420 HR(EN,EN) = HR(EN,EN) + TR
55865 HI(EN,EN) = HI(EN,EN) + TI
55869 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
55870 C VECTORS OF UPPER TRIANGULAR FORM ..........
55876 TR = DABS(HR(I,J)) + DABS(HI(I,J))
55877 IF (TR .GT. NORM) NORM = TR
55880 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
55881 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
55889 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
55890 DO 490 II = 1, ENM1
55897 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
55898 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
55903 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
55906 460 YR = 0.01D0 * YR
55908 IF (TST2 .GT. TST1) GOTO 460
55910 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
55911 C .......... OVERFLOW CONTROL ..........
55912 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
55913 IF (TR .EQ. 0.0D0) GOTO 490
55915 TST2 = TST1 + 1.0D0/TST1
55916 IF (TST2 .GT. TST1) GOTO 490
55918 HR(J,EN) = HR(J,EN)/TR
55919 HI(J,EN) = HI(J,EN)/TR
55925 C .......... END BACKSUBSTITUTION ..........
55926 C .......... VECTORS OF ISOLATED ROOTS ..........
55928 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
55936 C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
55937 C VECTORS OF ORIGINAL FULL MATRIX.
55938 C FOR J=N STEP -1 UNTIL LOW DO -- ..........
55943 DO 540 I = LOW, IGH
55948 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
55949 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
55957 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55958 C CONVERGED AFTER 30*N ITERATIONS ..........
55963 C*********************************************************************
55966 C...Auxiliary to PYCMQR
55968 C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
55971 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
55973 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
55974 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
55976 S = DABS(BR) + DABS(BI)
55981 S = BRS**2 + BIS**2
55982 CR = (ARS*BRS + AIS*BIS)/S
55983 CI = (AIS*BRS - ARS*BIS)/S
55987 C*********************************************************************
55990 C...Auxiliary to PYCMQR
55992 C (YR,YI) = COMPLEX DSQRT(XR,XI)
55993 C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
55996 SUBROUTINE PYCSRT(XR,XI,YR,YI)
55998 DOUBLE PRECISION XR,XI,YR,YI
55999 DOUBLE PRECISION S,TR,TI,PYTHAG
56003 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
56004 IF (TR .GE. 0.0D0) YR = S
56005 IF (TI .LT. 0.0D0) S = -S
56006 IF (TR .LE. 0.0D0) YI = S
56007 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
56008 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
56012 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
56013 DOUBLE PRECISION A,B
56015 C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
56017 DOUBLE PRECISION P,R,S,T,U
56018 P = DMAX1(DABS(A),DABS(B))
56019 IF (P .EQ. 0.0D0) GOTO 110
56020 R = (DMIN1(DABS(A),DABS(B))/P)**2
56023 IF (T .EQ. 4.0D0) GOTO 110
56025 U = 1.0D0 + 2.0D0*S
56033 C*********************************************************************
56036 C...Auxiliary to PYEICG
56038 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56039 C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
56040 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56041 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56043 C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
56044 C EIGENVALUES WHENEVER POSSIBLE.
56048 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56049 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56050 C DIMENSION STATEMENT.
56052 C N IS THE ORDER OF THE MATRIX.
56054 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56055 C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
56059 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56060 C RESPECTIVELY, OF THE BALANCED MATRIX.
56062 C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
56063 C ARE EQUAL TO ZERO IF
56064 C (1) I IS GREATER THAN J AND
56065 C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
56067 C SCALE CONTAINS INFORMATION DETERMINING THE
56068 C PERMUTATIONS AND SCALING FACTORS USED.
56070 C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
56071 C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
56072 C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
56073 C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
56074 C SCALE(J) = P(J), FOR J = 1,...,LOW-1
56075 C = D(J,J) J = LOW,...,IGH
56076 C = P(J) J = IGH+1,...,N.
56077 C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
56080 C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
56082 C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
56083 C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
56084 C K,L HAVE BEEN REVERSED.)
56086 C ARITHMETIC IS REAL THROUGHOUT.
56088 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56089 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56091 C THIS VERSION DATED AUGUST 1983.
56094 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
56096 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
56097 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
56098 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
56107 C .......... IN-LINE PROCEDURE FOR ROW AND
56108 C COLUMN EXCHANGE ..........
56110 IF (J .EQ. M) GOTO 130
56130 130 IF(IEXC.EQ.1) GOTO 140
56131 IF(IEXC.EQ.2) GOTO 180
56132 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
56133 C AND PUSH THEM DOWN ..........
56134 140 IF (L .EQ. 1) GOTO 320
56136 C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
56137 150 DO 170 JJ = 1, L
56141 IF (I .EQ. J) GOTO 160
56142 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
56151 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
56152 C AND PUSH THEM LEFT ..........
56155 190 DO 210 J = K, L
56158 IF (I .EQ. J) GOTO 200
56159 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
56166 C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
56168 220 SCALE(I) = 1.0D0
56169 C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
56170 230 NOCONV = .FALSE.
56177 IF (J .EQ. I) GOTO 240
56178 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
56179 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
56181 C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
56182 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
56186 250 IF (C .GE. G) GOTO 260
56191 270 IF (C .LT. G) GOTO 280
56195 C .......... NOW BALANCE ..........
56196 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
56198 SCALE(I) = SCALE(I) * F
56202 AR(I,J) = AR(I,J) * G
56203 AI(I,J) = AI(I,J) * G
56207 AR(J,I) = AR(J,I) * F
56208 AI(J,I) = AI(J,I) * F
56213 IF (NOCONV) GOTO 230
56220 C*********************************************************************
56223 C...Auxiliary to PYEICG.
56225 C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56226 C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
56227 C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56228 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56230 C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
56231 C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
56232 C BALANCED MATRIX DETERMINED BY CBAL.
56236 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56237 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56238 C DIMENSION STATEMENT.
56240 C N IS THE ORDER OF THE MATRIX.
56242 C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
56244 C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
56245 C AND SCALING FACTORS USED BY CBAL.
56247 C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
56249 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56250 C RESPECTIVELY, OF THE EIGENVECTORS TO BE
56251 C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
56255 C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56256 C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
56257 C IN THEIR FIRST M COLUMNS.
56259 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56260 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56262 C THIS VERSION DATED AUGUST 1983.
56265 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
56267 INTEGER I,J,K,M,N,II,NM,IGH,LOW
56268 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
56271 IF (M .EQ. 0) GOTO 150
56272 IF (IGH .EQ. LOW) GOTO 120
56274 DO 110 I = LOW, IGH
56276 C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
56277 C IF THE FOREGOING STATEMENT IS REPLACED BY
56278 C S=1.0D0/SCALE(I). ..........
56280 ZR(I,J) = ZR(I,J) * S
56281 ZI(I,J) = ZI(I,J) * S
56285 C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
56286 C IGH+1 STEP 1 UNTIL N DO -- ..........
56287 120 DO 140 II = 1, N
56289 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
56290 IF (I .LT. LOW) I = LOW - II
56292 IF (K .EQ. I) GOTO 140
56308 C*********************************************************************
56311 C...Auxiliary to PYEICG.
56313 C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
56314 C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
56315 C BY MARTIN AND WILKINSON.
56316 C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
56318 C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
56319 C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
56320 C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
56321 C UNITARY SIMILARITY TRANSFORMATIONS.
56325 C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56326 C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56327 C DIMENSION STATEMENT.
56329 C N IS THE ORDER OF THE MATRIX.
56331 C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56332 C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56333 C SET LOW=1, IGH=N.
56335 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56336 C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
56340 C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56341 C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
56342 C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
56343 C IS STORED IN THE REMAINING TRIANGLES UNDER THE
56344 C HESSENBERG MATRIX.
56346 C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
56347 C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
56349 C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56351 C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56352 C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56354 C THIS VERSION DATED AUGUST 1983.
56357 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
56359 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
56360 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
56361 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
56365 IF (LA .LT. KP1) GOTO 210
56372 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
56374 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
56376 IF (SCALE .EQ. 0.0D0) GOTO 200
56378 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56381 ORTR(I) = AR(I,M-1) / SCALE
56382 ORTI(I) = AI(I,M-1) / SCALE
56383 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
56387 F = PYTHAG(ORTR(M),ORTI(M))
56388 IF (F .EQ. 0.0D0) GOTO 120
56391 ORTR(M) = (1.0D0 + G) * ORTR(M)
56392 ORTI(M) = (1.0D0 + G) * ORTI(M)
56397 C .......... FORM (I-(U*UT)/H) * A ..........
56398 130 DO 160 J = M, N
56401 C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56404 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
56405 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
56412 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
56413 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
56417 C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
56421 C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
56424 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
56425 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
56432 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
56433 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
56438 ORTR(M) = SCALE * ORTR(M)
56439 ORTI(M) = SCALE * ORTI(M)
56440 AR(M,M-1) = -G * AR(M,M-1)
56441 AI(M,M-1) = -G * AI(M,M-1)
56447 C*********************************************************************
56450 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56453 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
56455 INTEGER N,NP,INDX(N)
56457 COMPLEX*16 A(NP,NP)
56458 PARAMETER (TINY=1.0D-20)
56460 REAL*8 AAMAX,VV(6),DUM
56461 COMPLEX*16 SUM,DUMC
56467 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
56469 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
56476 SUM=SUM-A(I,K)*A(K,J)
56484 SUM=SUM-A(I,K)*A(K,J)
56488 IF (DUM.GE.AAMAX) THEN
56503 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
56506 A(I,J)=A(I,J)/A(J,J)
56514 C*********************************************************************
56517 C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56520 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
56522 INTEGER N,NP,INDX(N)
56523 COMPLEX*16 A(NP,NP),B(N)
56534 SUM=SUM-A(I,J)*B(J)
56536 ELSE IF (ABS(SUM).NE.0D0) THEN
56544 SUM=SUM-A(I,J)*B(J)
56551 C***********************************************************************
56554 C...Calculates full and partial widths of resonances.
56555 C....copy of PYWIDT, used for techniparticle widths
56557 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
56559 C...Double precision and integer declarations.
56560 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56561 IMPLICIT INTEGER(I-N)
56562 INTEGER PYK,PYCHGE,PYCOMP
56563 C...Parameter statement to help give large particle numbers.
56564 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56565 &KEXCIT=4000000,KDIMEN=5000000)
56567 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56568 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56569 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
56570 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
56571 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
56572 COMMON/PYINT1/MINT(400),VINT(400)
56573 COMMON/PYINT4/MWID(500),WIDS(500,5)
56574 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
56575 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
56576 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
56577 &/PYINT4/,/PYMSSM/,/PYTCSM/
56578 C...Local arrays and saved variables.
56579 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
56581 SAVE MOFSV,WIDWSV,WID2SV
56582 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
56584 C...Compressed code and sign; mass.
56591 C...Reset width information.
56596 C...Common electroweak and strong constants.
56599 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
56602 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
56604 RADC=1D0+AS/PARU(1)
56606 IF(KFLA.EQ.23) THEN
56608 XWC=1D0/(16D0*XW*XW1)
56609 FAC=(AEM*XWC/3D0)*SHR
56611 DO 130 I=1,MDCY(KC,3)
56613 IF(MDME(IDC,1).LT.0) GOTO 130
56614 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
56615 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
56616 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
56620 AF=SIGN(1D0,EF+0.1D0)
56623 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
56624 ELSEIF(I.LE.16) THEN
56625 C...Z0 -> l+ + l-, nu + nubar
56627 AF=SIGN(1D0,EF+0.1D0)
56631 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
56632 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
56634 WDTP(0)=WDTP(0)+WDTP(I)
56638 ELSEIF(KFLA.EQ.24) THEN
56640 FAC=(AEM/(24D0*XW))*SHR
56641 DO 140 I=1,MDCY(KC,3)
56643 IF(MDME(IDC,1).LT.0) GOTO 140
56644 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
56645 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
56646 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
56649 C...W+/- -> q + qbar'
56650 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
56651 ELSEIF(I.LE.20) THEN
56652 C...W+/- -> l+/- + nu
56655 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
56656 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
56657 WDTP(0)=WDTP(0)+WDTP(I)
56660 C.....V8 -> quark anti-quark
56661 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
56664 IF(ITCM(2).EQ.0) THEN
56666 ELSEIF(ITCM(2).EQ.1) THEN
56669 DO 150 I=1,MDCY(KC,3)
56671 IF(MDME(IDC,1).LT.0) GOTO 150
56672 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
56674 IF(RM1.GT.0.25D0) GOTO 150
56676 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
56681 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
56682 IF(I.EQ.6) WID2=WIDS(6,1)
56683 WDTP(0)=WDTP(0)+WDTP(I)
56690 C*********************************************************************
56693 C...Calculates R-violating decays of sfermions.
56696 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
56698 C...Double precision and integer declarations.
56699 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56700 IMPLICIT INTEGER(I-N)
56701 C...Parameter statement to help give large particle numbers.
56702 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56703 &KEXCIT=4000000,KDIMEN=5000000)
56705 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56706 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
56707 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
56708 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
56709 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
56710 C...Local variables.
56711 DOUBLE PRECISION XLAM(0:400)
56712 INTEGER IDLAM(400,3), PYCOMP
56713 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
56715 C...IS R-VIOLATION ON ?
56716 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
56717 C...Mass eigenstate counter
56718 ICNT=INT(KFIN/KSUSY1)
56719 C...SM KF code of SUSY particle
56720 KFSM=KFIN-ICNT*KSUSY1
56721 C...Squared Sparticle Mass
56722 SM=PMAS(PYCOMP(KFIN),1)**2
56723 C... Squared mass of top quark
56724 SMT=PMAS(PYCOMP(6),1)**2
56725 C...IS L-VIOLATION ON ?
56726 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
56727 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
56728 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
56734 C...~e,~mu,~tau -> nu_I + lepton-_J
56736 IDLAM(LKNT,1)= 12 +2*(I-1)
56737 IDLAM(LKNT,2)= 11 +2*(J-1)
56740 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56741 IF (IMSS(51).NE.0) XLAM(LKNT) =
56742 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56743 C...KINEMATICS CHECK
56744 IF (XLAM(LKNT).EQ.0D0) THEN
56750 C...~e,~mu,~tau -> nu_Ibar + lepton-_K
56756 IDLAM(LKNT,1)=-12 -2*(I-1)
56757 IDLAM(LKNT,2)= 11 +2*(K-1)
56760 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56761 IF (IMSS(51).NE.0) XLAM(LKNT) =
56762 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56763 C...KINEMATICS CHECK
56764 IF (XLAM(LKNT).EQ.0D0) THEN
56770 C...~e,~mu,~tau -> u_Jbar + d_K
56775 IDLAM(LKNT,1)=-2 -2*(J-1)
56776 IDLAM(LKNT,2)= 1 +2*(K-1)
56779 IF (IMSS(52).NE.0) THEN
56780 C...Use massive top quark
56781 IF (IDLAM(LKNT,1).EQ.-6) THEN
56782 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
56785 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
56786 C...If no top quark, all decay products massless
56788 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56790 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56792 C...KINEMATICS CHECK
56793 IF (XLAM(LKNT).EQ.0D0) THEN
56800 C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
56801 C...No right-handed neutrinos
56803 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
56808 C...~nu_J -> lepton+_I + lepton-_K
56810 IDLAM(LKNT,1)=-11 -2*(I-1)
56811 IDLAM(LKNT,2)= 11 +2*(K-1)
56814 RM2=RVLAM(I,J,K)**2 * SM
56815 IF (IMSS(51).NE.0) XLAM(LKNT) =
56816 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56817 C...KINEMATICS CHECK
56818 IF (XLAM(LKNT).EQ.0D0) THEN
56824 C...~nu_I -> dbar_J + d_K
56829 IDLAM(LKNT,1)=-1 -2*(J-1)
56830 IDLAM(LKNT,2)= 1 +2*(K-1)
56833 RM2=3*RVLAMP(I,J,K)**2 * SM
56834 IF (IMSS(52).NE.0) XLAM(LKNT) =
56835 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56836 C...KINEMATICS CHECK
56837 IF (XLAM(LKNT).EQ.0D0) THEN
56844 C * SDOWN -> NU(BAR) + D and LEPTON- + U
56845 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
56849 C...~d_J -> nu_Ibar + d_K
56851 IDLAM(LKNT,1)=-12 -2*(I-1)
56852 IDLAM(LKNT,2)= 1 +2*(K-1)
56855 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56856 IF (IMSS(52).NE.0) XLAM(LKNT) =
56857 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56858 C...KINEMATICS CHECK
56859 IF (XLAM(LKNT).EQ.0D0) THEN
56867 C...~d_K -> nu_I + d_J
56869 IDLAM(LKNT,1)= 12 +2*(I-1)
56870 IDLAM(LKNT,2)= 1 +2*(J-1)
56873 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56874 IF (IMSS(52).NE.0) XLAM(LKNT) =
56875 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56876 C...KINEMATICS CHECK
56877 IF (XLAM(LKNT).EQ.0D0) THEN
56880 C...~d_K -> lepton_I- + u_J
56882 IDLAM(LKNT,1)= 11 +2*(I-1)
56883 IDLAM(LKNT,2)= 2 +2*(J-1)
56886 IF (IMSS(52).NE.0) THEN
56887 C...Use massive top quark
56888 IF (IDLAM(LKNT,2).EQ.6) THEN
56889 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
56891 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
56892 C...If no top quark, all decay products massless
56894 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56896 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56898 C...KINEMATICS CHECK
56899 IF (XLAM(LKNT).EQ.0D0) THEN
56906 C * SUP -> LEPTON+ + D
56907 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
56911 C...~u_J -> lepton_I+ + d_K
56913 IDLAM(LKNT,1)=-11 -2*(I-1)
56914 IDLAM(LKNT,2)= 1 +2*(K-1)
56917 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56918 IF (IMSS(52).NE.0) XLAM(LKNT) =
56919 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56920 C...KINEMATICS CHECK
56921 IF (XLAM(LKNT).EQ.0D0) THEN
56928 C...BARYON NUMBER VIOLATING DECAYS
56929 IF (IMSS(53).GE.1) THEN
56930 C * SUP -> DBAR + DBAR
56931 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
56935 C...~u_I -> dbar_J + dbar_K
56937 C...(anti-) symmetry J <-> K.
56939 IDLAM(LKNT,1) = -1 -2*(J-1)
56940 IDLAM(LKNT,2) = -1 -2*(K-1)
56943 RM2 = 2.*(RVLAMB(I,J,K)**2)
56944 & * SFMIX(KFSM,2*ICNT)**2 * SM
56946 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56947 C...KINEMATICS CHECK
56948 IF (XLAM(LKNT).EQ.0D0) THEN
56955 C * SDOWN -> UBAR + DBAR
56956 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
56960 C...LAMB coupling antisymmetric in J and K.
56962 C...~d_K -> ubar_I + dbar_K
56964 IDLAM(LKNT,1)= -2 -2*(I-1)
56965 IDLAM(LKNT,2)= -1 -2*(J-1)
56968 C...Use massive top quark
56969 IF (IDLAM(LKNT,1).EQ.-6) THEN
56970 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
56973 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
56974 C...If no top quark, all decay products massless
56976 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56978 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56980 C...KINEMATICS CHECK
56981 IF (XLAM(LKNT).EQ.0D0) THEN
56994 C*********************************************************************
56997 C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
57000 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
57002 C...Double precision and integer declarations.
57003 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57004 IMPLICIT INTEGER(I-N)
57005 C...Parameter statement to help give large particle numbers.
57006 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57007 &KEXCIT=4000000,KDIMEN=5000000)
57009 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57010 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57011 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57012 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57013 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57014 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57015 C...Local variables.
57016 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57018 DOUBLE PRECISION XLAM(0:400)
57019 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
57020 INTEGER IDLAM(400,3), PYCOMP
57022 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
57024 C...R-VIOLATING DECAYS
57025 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57027 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
57028 C...WHICH NEUTRALINO ?
57030 IF (KFSM.EQ.23) NCHI=2
57031 IF (KFSM.EQ.25) NCHI=3
57032 IF (KFSM.EQ.35) NCHI=4
57033 C...SIGN OF MASS (Opposite convention as HERWIG)
57035 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
57037 C...Useful parameters for the calculation of the A and B constants.
57038 WMASS = PMAS(PYCOMP(24),1)
57039 ECHG = 2*SQRT(PARU(103)*PARU(1))
57040 COSB=1/(SQRT(1+RMSS(5)**2))
57041 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
57042 COSW=SQRT(1-PARU(102))
57043 SINW=SQRT(PARU(102))
57044 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
57045 C...Run quark masses to neutralino mass squared (for Higgs-type
57047 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
57049 RMQ(I)=PYMRUN(I,SQMCHI)
57051 C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
57053 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
57054 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
57055 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
57056 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
57058 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
57059 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
57060 C2=ECHG*ZPMIX(NCHI,1)
57061 C3=GW*ZPMIX(NCHI,2)/COSW
57065 C x=1-2 : Select A or B constant (1:A ; 2:B)
57066 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57067 C 11-16:e,nu_e,mu,...)
57068 C z=1-2 : Mass eigenstate number
57069 C...CALCULATE COUPLINGS
57071 CMS=PMAS(PYCOMP(I),1)
57072 C...Intermediate sleptons
57073 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
57074 & *(C2-C3*SINW**2))
57075 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
57076 & *(C2-C3*SINW**2))
57077 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
57079 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
57081 C...Inermediate sneutrinos
57083 AB(2,I+1,1)=5D-1*C3
57086 C...Inermediate sdown
57089 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
57090 & *ED*(C2-C3*SINW**2))
57091 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
57092 & *ED*(C2-C3*SINW**2))
57093 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
57094 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57095 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
57096 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57097 C...Inermediate sup
57100 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
57101 & *EU*(C2-C3*SINW**2))
57102 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
57103 & *EU*(C2-C3*SINW**2))
57104 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
57105 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57106 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
57107 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57110 IF (IMSS(51).GE.1) THEN
57111 C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
57112 C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
57113 C...STEP IN I,J,K USING SINGLE COUNTER
57115 C...LAMBDA COUPLING ASYM IN I,J
57116 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57118 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57119 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57120 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57122 C...Set coupling, and decay product masses on/off
57123 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57124 & ,MOD(ISC,3)+1)**2
57126 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
57128 C...Resonance KF codes (1=I,2=J,3=K)
57129 KFR(1)=-IDLAM(LKNT,1)
57130 KFR(2)=-IDLAM(LKNT,2)
57131 KFR(3)=-IDLAM(LKNT,3)
57132 C...Calculate width.
57133 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57134 & IDLAM(LKNT,3),XLAM(LKNT))
57135 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57136 C...Charge conjugate mode.
57138 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57139 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57140 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57141 XLAM(LKNT)=XLAM(LKNT-1)
57142 C...KINEMATICS CHECK
57143 IF (XLAM(LKNT).EQ.0D0) THEN
57150 IF (IMSS(52).GE.1) THEN
57151 C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
57152 C * CHI0 -> NUBAR_I + DBAR_J + D_K
57155 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57156 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57157 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57159 C...Set coupling, and decay product masses on/off
57160 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57161 & ,MOD(ISC,3)+1)**2
57163 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
57165 C...Resonance KF codes (1=I,2=J,3=K)
57166 KFR(1)=-IDLAM(LKNT,1)
57167 KFR(2)=-IDLAM(LKNT,2)
57168 KFR(3)=-IDLAM(LKNT,3)
57169 C...Calculate width.
57170 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57172 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57173 C...Charge conjugate mode.
57175 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57176 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57177 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57178 XLAM(LKNT)=XLAM(LKNT-1)
57179 C...KINEMATICS CHECK
57180 IF (XLAM(LKNT).EQ.0D0) THEN
57184 C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
57186 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57187 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57188 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57190 C...Set coupling, and decay product masses on/off
57191 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57192 & ,MOD(ISC,3)+1)**2
57194 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
57195 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
57196 C...Resonance KF codes (1=I,2=J,3=K)
57197 KFR(1)=-IDLAM(LKNT,1)
57198 KFR(2)=-IDLAM(LKNT,2)
57199 KFR(3)=-IDLAM(LKNT,3)
57200 C...Calculate width.
57201 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57203 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57204 C...Charge conjugate mode.
57206 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57207 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57208 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57209 XLAM(LKNT)=XLAM(LKNT-1)
57210 C...KINEMATICS CHECK
57211 IF (XLAM(LKNT).EQ.0D0) THEN
57217 IF (IMSS(53).GE.1) THEN
57218 C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
57219 C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
57221 C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
57222 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
57224 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
57225 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57226 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57228 C...Set coupling, and decay product masses on/off
57229 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
57230 & +1,MOD(ISC,3)+1)**2
57232 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
57233 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
57234 C...Resonance KF codes (1=I,2=J,3=K)
57235 KFR(1) = IDLAM(LKNT,1)
57236 KFR(2) = IDLAM(LKNT,2)
57237 KFR(3) = IDLAM(LKNT,3)
57238 C...Calculate width.
57239 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57240 & IDLAM(LKNT,3),XLAM(LKNT))
57241 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57242 C...Charge conjugate mode.
57244 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57245 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57246 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57247 XLAM(LKNT)=XLAM(LKNT-1)
57248 C...KINEMATICS CHECK
57249 IF (XLAM(LKNT).EQ.0D0) THEN
57261 C*********************************************************************
57264 C...Calculates R-violating chargino decay widths.
57267 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
57269 C...Double precision and integer declarations.
57270 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57271 IMPLICIT INTEGER(I-N)
57272 C...Parameter statement to help give large particle numbers.
57273 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57274 &KEXCIT=4000000,KDIMEN=5000000)
57276 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57277 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57278 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57279 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57280 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57281 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57282 C...Local variables.
57283 DOUBLE PRECISION XLAM(0:400)
57284 INTEGER IDLAM(400,3), PYCOMP
57285 C...Information from main routine to PYRVGW
57286 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57288 C...Auxiliary variables needed for BV (RV Gauge STOre)
57289 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
57291 C...Running quark masses
57292 DOUBLE PRECISION RMQ(6)
57293 C...Decay product masses on/off
57295 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57299 C...IF R-VIOLATION ON.
57300 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57302 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
57303 C...WHICH CHARGINO ?
57305 IF (KFSM.EQ.37) NCHI = 2
57307 C...Useful parameters for calculating the A and B constants.
57308 C...SIGN OF MASS (Opposite convention as HERWIG)
57310 IF (SMW(NCHI).LT.0D0) ISM = -1
57311 WMASS = PMAS(PYCOMP(24),1)
57312 COSB = 1/(SQRT(1+RMSS(5)**2))
57313 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
57314 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
57315 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
57316 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
57319 C...Running masses at Q^2=MCHI^2.
57320 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
57322 RMQ(I)=PYMRUN(I,SQMCHI)
57325 C... AB(x,y,z) coefficients:
57326 C x=1-2 : A or B coefficient (1:A ; 2:B)
57327 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57328 C 11-16:e,nu_e,mu,...)
57329 C z=1-2 : Mass eigenstate number
57331 C...Intermediate sleptons
57334 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
57336 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
57338 C...Intermediate sneutrinos
57339 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
57341 AB(2,I+1,1) = ISM*C3
57343 C...Intermediate sdown
57345 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
57346 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
57347 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
57348 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
57349 C...Intermediate sup
57351 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
57352 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
57353 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
57354 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
57357 C...LLE TYPE R-VIOLATION
57358 IF (IMSS(51).GE.1) THEN
57359 C...LOOP OVER DECAY MODES
57362 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
57363 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57365 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
57366 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
57367 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
57369 C...Set coupling, and decay product masses on/off
57370 RVLAMC = GW2 * 5D-1 *
57371 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57374 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
57375 C...Resonance KF codes (1=I,2=J,3=K).
57378 KFR(3) = -IDLAM(LKNT,3)+1
57379 C...Calculate width.
57380 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57381 & IDLAM(LKNT,3),XLAM(LKNT))
57382 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57383 C...KINEMATICS CHECK
57384 IF (XLAM(LKNT).EQ.0D0) THEN
57388 C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
57389 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
57391 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
57392 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
57393 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
57395 C...Set coupling, and decay product masses on/off
57396 RVLAMC = GW2 * 5D-1 *
57397 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57398 C...I,J SYMMETRY => FACTOR 2
57401 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
57402 C...Resonance KF codes (1=I,2=J,3=K)
57403 KFR(1)=IDLAM(LKNT,1)-1
57404 KFR(2)=IDLAM(LKNT,2)-1
57406 C...Calculate width.
57407 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57408 & IDLAM(LKNT,3),XLAM(LKNT))
57409 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57410 C...KINEMATICS CHECK
57411 IF (XLAM(LKNT).EQ.0D0) THEN
57416 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
57418 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57419 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57420 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57422 C...Set coupling, and decay product masses on/off
57423 RVLAMC = GW2 * 5D-1 *
57424 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57425 C...I,J SYMMETRY => FACTOR 2
57428 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
57429 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
57430 C...Resonance KF codes (1=I,2=J,3=K)
57431 KFR(1) =-IDLAM(LKNT,1)+1
57432 KFR(2) =-IDLAM(LKNT,2)+1
57434 C...Calculate width.
57435 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57436 & IDLAM(LKNT,3),XLAM(LKNT))
57437 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57438 C...KINEMATICS CHECK
57439 IF (XLAM(LKNT).EQ.0D0) THEN
57446 C...LQD TYPE R-VIOLATION
57447 IF (IMSS(52).GE.1) THEN
57448 C...LOOP OVER DECAY MODES
57451 C...CHI+ -> NUBAR_I + DBAR_J + U_K
57453 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57454 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57455 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
57457 C...Set coupling, and decay product masses on/off
57458 RVLAMC = 3. * GW2 * 5D-1 *
57459 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57461 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
57463 C...Resonance KF codes (1=I,2=J,3=K)
57466 KFR(3)=-IDLAM(LKNT,3)+1
57467 C...Calculate width.
57468 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57470 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57471 C...KINEMATICS CHECK
57472 IF (XLAM(LKNT).EQ.0D0) THEN
57476 C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
57478 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57479 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57480 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
57482 C...Set coupling, and decay product masses on/off
57483 RVLAMC = 3. * GW2 * 5D-1 *
57484 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57486 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
57487 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
57488 C...Resonance KF codes (1=I,2=J,3=K)
57491 KFR(3)=-IDLAM(LKNT,3)+1
57492 C...Calculate width.
57493 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57495 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57496 C...KINEMATICS CHECK
57497 IF (XLAM(LKNT).EQ.0D0) THEN
57501 C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
57503 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57504 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57505 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57507 C...Set coupling, and decay product masses on/off
57508 RVLAMC = 3. * GW2 * 5D-1 *
57509 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57511 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
57512 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
57513 C...Resonance KF codes (1=I,2=J,3=K)
57514 KFR(1)=-IDLAM(LKNT,1)+1
57515 KFR(2)=-IDLAM(LKNT,2)+1
57517 C...Calculate width.
57518 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57520 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57521 C...KINEMATICS CHECK
57522 IF (XLAM(LKNT).EQ.0D0) THEN
57526 C * CHI+ -> NU_I + U_J + DBAR_K.
57528 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
57529 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
57530 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57532 C...Set coupling, and decay product masses on/off
57534 RVLAMC = 3. * GW2 * 5D-1 *
57535 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57536 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
57538 C...Resonance KF codes (1=I,2=J,3=K)
57539 KFR(1)=IDLAM(LKNT,1)-1
57540 KFR(2)=IDLAM(LKNT,2)-1
57542 C...Calculate width.
57543 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57545 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57546 C...KINEMATICS CHECK
57547 IF (XLAM(LKNT).EQ.0D0) THEN
57554 C...UDD TYPE R-VIOLATION
57555 C...These decays need special treatment since more than one BV coupling
57556 C...contributes (with interference). Consider e.g. (symbolically)
57557 C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
57558 C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
57559 C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
57560 C...The problem is that a single call to PYRVGW would evaluate all
57561 C...these terms and sum them, but without the different couplings. The
57562 C...way out is to call PYRVGW three times, once for the first line, once
57563 C...for the second line, and then once for all the lines (it is
57564 C...impossible to get just the last line out) without multiplying by
57565 C...couplings. The last line is then obtained as the result of the third
57566 C...call minus the results of the two first calls. Each term is then
57567 C...multiplied by its respective coupling before the whole thing is
57568 C...summed up in XLAM.
57569 C...Note that with three interfering resonances, this procedure becomes
57570 C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
57572 IF (IMSS(53).GE.1) THEN
57573 C...LOOP OVER DECAY MODES
57576 C...CHI+ -> U_I + U_J + D_K
57577 C...Decay mode I<->J symmetric.
57578 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
57580 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
57581 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
57582 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57584 C...Set coupling, and decay product masses on/off
57585 RVLAMC= 6. * GW2 * 5D-1
57586 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
57588 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
57590 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
57593 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
57594 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
57595 C...Resonance KF codes (1=I,2=J,3=K)
57596 KFR(1) = -IDLAM(LKNT,1)+1
57599 C...Calculate width.
57600 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57601 & IDLAM(LKNT,3),XRESI)
57602 C...Resonance KF codes (1=I,2=J,3=K)
57604 KFR(2) = -IDLAM(LKNT,2)+1
57606 C...Calculate width.
57607 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57608 & IDLAM(LKNT,3),XRESJ)
57609 C...Resonance KF codes (1=I,2=J,3=K)
57610 KFR(1) = -IDLAM(LKNT,1)+1
57611 KFR(2) = -IDLAM(LKNT,2)+1
57613 C...Calculate width.
57614 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57615 & IDLAM(LKNT,3),XRESIJ)
57616 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
57617 XRESIJ = XRESIJ-XRESI-XRESJ
57621 C...CALCULATE TOTAL WIDTH
57622 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
57623 & + RVLJIK*RVLIJK * XRESIJ
57624 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57625 C...KINEMATICS CHECK
57626 IF (XLAM(LKNT).EQ.0D0) THEN
57630 C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
57631 C...Symmetry I<->J<->K.
57632 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
57633 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
57635 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
57636 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57637 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57639 C...Set coupling, and decay product masses on/off
57640 RVLAMC = 6. * GW2 * 5D-1
57641 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
57643 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
57645 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
57648 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
57649 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
57650 C...Collect symmetry factors
57651 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
57652 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
57653 & RVLAMC = 5D-1 * RVLAMC
57654 C...Resonance KF codes (1=I,2=J,3=K)
57655 KFR(1) = IDLAM(LKNT,1)-1
57658 C...Calculate width.
57659 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57660 & IDLAM(LKNT,3),XRESI)
57661 C...Resonance KF codes (1=I,2=J,3=K)
57663 KFR(2) = IDLAM(LKNT,2)-1
57665 C...Calculate width.
57666 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57667 & IDLAM(LKNT,3),XRESJ)
57668 C...Resonance KF codes (1=I,2=J,3=K)
57671 KFR(3) = IDLAM(LKNT,3)-1
57672 C...Calculate width.
57673 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57674 & IDLAM(LKNT,3),XRESK)
57675 C...Resonance KF codes (1=I,2=J,3=K)
57676 KFR(1) = IDLAM(LKNT,1)-1
57677 KFR(2) = IDLAM(LKNT,2)-1
57679 C...Calculate width.
57680 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57681 & IDLAM(LKNT,3),XRESIJ)
57682 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*(XRESI+XRESJ)) THEN
57683 XRESIJ = XRESI+XRESJ-XRESIJ
57687 C...Resonance KF codes (1=I,2=J,3=K)
57689 KFR(2) = IDLAM(LKNT,2)-1
57690 KFR(3) = IDLAM(LKNT,3)-1
57691 C...Calculate width.
57692 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57693 & IDLAM(LKNT,3),XRESJK)
57694 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*(XRESJ+XRESK)) THEN
57695 XRESJK = XRESJ+XRESK-XRESJK
57699 C...Resonance KF codes (1=I,2=J,3=K)
57700 KFR(1) = IDLAM(LKNT,1)-1
57702 KFR(3) = IDLAM(LKNT,3)-1
57703 C...Calculate width.
57704 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57705 & IDLAM(LKNT,3),XRESIK)
57706 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*(XRESI+XRESK)) THEN
57707 XRESIK = XRESI+XRESK-XRESIK
57711 C...CALCULATE TOTAL WIDTH
57713 & RVLIJK**2 * XRESI
57714 & + RVLJKI**2 * XRESJ
57715 & + RVLKIJ**2 * XRESK
57716 & + RVLIJK*RVLJKI * XRESIJ
57717 & + RVLIJK*RVLKIJ * XRESIK
57718 & + RVLJKI*RVLKIJ * XRESJK
57719 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
57720 C...KINEMATICS CHECK
57721 IF (XLAM(LKNT).EQ.0D0) THEN
57733 C*********************************************************************
57736 C...Calculates R-violating gluino decay widths.
57737 C...See BV part of PYRVCH for comments about the way the BV decay width
57738 C...is calculated. Same comments apply here.
57741 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
57743 C...Double precision and integer declarations.
57744 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57745 IMPLICIT INTEGER(I-N)
57746 C...Parameter statement to help give large particle numbers.
57747 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57748 &KEXCIT=4000000,KDIMEN=5000000)
57750 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57751 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57752 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57753 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57754 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57755 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57756 C...Local variables.
57757 DOUBLE PRECISION XLAM(0:400)
57758 INTEGER IDLAM(400,3), PYCOMP
57759 C...Information from main routine to PYRVGW
57760 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57762 C...Auxiliary variables needed for BV (RV Gauge STOre)
57763 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
57765 C...Running quark masses
57766 DOUBLE PRECISION RMQ(6)
57767 C...Decay product masses on/off
57769 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57772 C...IF LQD OR UDD TYPE R-VIOLATION ON.
57773 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
57777 C x=1-2 : Select A or B coupling (1:A ; 2:B)
57778 C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57779 C 11-16:e,nu_e,mu,... not used here)
57780 C z=1-2 : Mass eigenstate number
57783 AB(1,I,1) = SFMIX(I,2)
57784 AB(1,I,2) = SFMIX(I,4)
57786 AB(2,I,1) = -SFMIX(I,1)
57787 AB(2,I,2) = -SFMIX(I,3)
57789 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
57791 IF (IMSS(52).GE.1) THEN
57792 C...STEP IN I,J,K USING SINGLE COUNTER
57794 C * GLUINO -> NUBAR_I + DBAR_J + D_K.
57796 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57797 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57798 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57800 C...Set coupling, and decay product masses on/off
57801 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57804 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
57805 C...Resonance KF codes (1=I,2=J,3=K)
57807 KFR(2) = -IDLAM(LKNT,2)
57808 KFR(3) = -IDLAM(LKNT,3)
57809 C...Calculate width.
57810 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57813 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57814 C...Charge conjugate mode.
57816 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
57817 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
57818 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
57819 XLAM(LKNT) = XLAM(LKNT-1)
57820 C...KINEMATICS CHECK
57821 IF (XLAM(LKNT).EQ.0D0) THEN
57825 C * GLUINO -> LEPTON+_I + UBAR_J + D_K
57827 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57828 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57829 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57831 C...Set coupling, and decay product masses on/off
57832 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57833 & **2* 5D-1 * GSTR2
57835 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
57836 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
57837 C...Resonance KF codes (1=I,2=J,3=K)
57839 KFR(2) = -IDLAM(LKNT,2)
57840 KFR(3) = -IDLAM(LKNT,3)
57841 C...Calculate width.
57842 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57844 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57845 C...Charge conjugate mode.
57847 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
57848 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
57849 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
57850 XLAM(LKNT) = XLAM(LKNT-1)
57851 C...KINEMATICS CHECK
57852 IF (XLAM(LKNT).EQ.0D0) THEN
57860 IF (IMSS(53).GE.1) THEN
57861 C...STEP IN I,J,K USING SINGLE COUNTER
57863 C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
57864 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
57866 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
57867 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57868 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57870 C...Set coupling, and decay product masses on/off. A factor of 2 for
57871 C...(N_C-1) has been used to cancel a factor 0.5.
57872 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57875 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
57876 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
57877 C...Resonance KF codes (1=I,2=J,3=K)
57878 KFR(1) = IDLAM(LKNT,1)
57881 C...Calculate width.
57882 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57884 C...Resonance KF codes (1=I,2=J,3=K)
57886 KFR(2) = IDLAM(LKNT,2)
57888 C...Calculate width.
57889 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57891 C...Resonance KF codes (1=I,2=J,3=K)
57894 KFR(3) = IDLAM(LKNT,3)
57895 C...Calculate width.
57896 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57898 C...Resonance KF codes (1=I,2=J,3=K)
57899 KFR(1) = IDLAM(LKNT,1)
57900 KFR(2) = IDLAM(LKNT,2)
57902 C...Calculate width.
57903 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57905 C...Calculate interference function. (Factor -1/2 to make up for factor
57907 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
57908 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
57912 C...Resonance KF codes (1=I,2=J,3=K)
57914 KFR(2) = IDLAM(LKNT,2)
57915 KFR(3) = IDLAM(LKNT,3)
57916 C...Calculate width.
57917 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57919 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*XRESJK) THEN
57920 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
57924 C...Resonance KF codes (1=I,2=J,3=K)
57925 KFR(1) = IDLAM(LKNT,1)
57927 KFR(3) = IDLAM(LKNT,3)
57928 C...Calculate width.
57929 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57931 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*XRESIK) THEN
57932 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
57936 C...Calculate total width (factor 1/2 from 1/(N_C-1))
57937 XLAM(LKNT) = XRESI + XRESJ + XRESK
57938 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
57940 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57941 C...Charge conjugate mode.
57943 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
57944 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
57945 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
57946 XLAM(LKNT) = XLAM(LKNT-1)
57947 C...KINEMATICS CHECK
57948 IF (XLAM(LKNT).EQ.0D0) THEN
57958 C*********************************************************************
57961 C...Auxiliary function to PYRVSF for calculating R-Violating
57962 C...sfermion widths. Though the decay products are most often treated
57963 C...as massless in the calculation, the kinematical boundary of phase
57964 C...space is tested using the true masses.
57965 C...MODE = 1: All decay products massive
57966 C...MODE = 2: Decay product 1 massless
57967 C...MODE = 3: Decay product 2 massless
57968 C...MODE = 4: All decay products massless
57970 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
57972 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
57973 IMPLICIT INTEGER (I-N)
57974 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57975 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57976 SAVE /PYDAT1/,/PYDAT2/
57977 DOUBLE PRECISION SM(3)
57978 INTEGER PYCOMP, KC(3)
57982 SM(1)=PMAS(KC(1),1)**2
57983 SM(2)=PMAS(KC(2),1)**2
57984 SM(3)=PMAS(KC(3),1)**2
57985 C...Kinematics check
57986 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
57990 C...CM momenta squared
57991 IF (MODE.EQ.1) THEN
57992 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
57993 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
57994 ELSE IF (MODE.EQ.2) THEN
57995 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
57996 ELSE IF (MODE.EQ.3) THEN
57997 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
58001 C...Calculate Width
58002 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
58006 C*********************************************************************
58009 C...Generalized Matrix Element for R-Violating 3-body widths.
58011 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
58013 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
58014 IMPLICIT INTEGER (I-N)
58015 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58016 &KEXCIT=4000000,KDIMEN=5000000)
58017 PARAMETER (EPS=1D-4)
58018 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58019 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58021 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58022 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58023 DOUBLE PRECISION XLIM(3,3)
58024 INTEGER KC(0:3), PYCOMP
58025 LOGICAL DCMASS, DCHECK(6)
58026 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
58030 KC(0) = PYCOMP(KFIN)
58031 KC(1) = PYCOMP(ID1)
58032 KC(2) = PYCOMP(ID2)
58033 KC(3) = PYCOMP(ID3)
58034 RMS(0) = PMAS(KC(0),1)
58035 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
58036 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
58037 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
58038 C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
58039 XLIM(1,1)=(RMS(1)+RMS(2))**2
58040 XLIM(1,2)=(RMS(0)-RMS(3))**2
58041 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
58042 XLIM(2,1)=(RMS(2)+RMS(3))**2
58043 XLIM(2,2)=(RMS(0)-RMS(1))**2
58044 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
58045 XLIM(3,1)=(RMS(1)+RMS(3))**2
58046 XLIM(3,2)=(RMS(0)-RMS(2))**2
58047 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
58048 C...Check Phase Space
58049 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
58053 C...INITIALIZE RESONANCE INFORMATION
58056 IRES = 2*(JRES-1)+IMASS
58058 DCHECK(IRES) =.FALSE.
58059 C...NO RIGHT-HANDED NEUTRINOS
58060 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
58061 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
58062 & .KFR(JRES).EQ.0) GOTO 100
58063 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
58064 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
58065 INTRES(IRES,1) = IABS(KFR(JRES))
58066 INTRES(IRES,2) = IMASS
58067 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
58068 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
58072 C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
58074 C...RESONANCE CONTRIBUTIONS
58075 C...(Only sum contributions where the resonance is off shell).
58076 C...Store whether diagram on/off in DCHECK.
58077 C...LOOP OVER MASS STATES
58080 IF(INTRES(IDR,1).NE.0) THEN
58082 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58083 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
58084 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58085 DCHECK(IDR) =.TRUE.
58086 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
58091 IF(INTRES(IDR,1).NE.0) THEN
58092 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58093 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58094 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58095 DCHECK(IDR) =.TRUE.
58096 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
58101 IF(INTRES(IDR,1).NE.0) THEN
58102 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58103 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58104 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58105 DCHECK(IDR) =.TRUE.
58106 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
58110 C... L-R INTERFERENCES
58111 C... (Only add contributions where both contributing diagrams
58112 C... are non-resonant).
58114 IF (DCHECK(1).AND.DCHECK(2)) THEN
58115 C...Bug corrected 11/12 2001. Skands.
58116 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
58117 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
58118 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
58122 IF (DCHECK(3).AND.DCHECK(4)) THEN
58123 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
58124 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
58125 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
58129 IF (DCHECK(5).AND.DCHECK(6)) THEN
58130 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
58131 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
58132 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
58134 C... TRUE INTERFERENCES
58135 C... (Only add contributions where both contributing diagrams
58136 C... are non-resonant).
58138 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
58143 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58144 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
58145 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58146 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58151 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58152 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
58153 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58154 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58159 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58160 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
58161 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58162 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58170 C*********************************************************************
58173 C...Function to integrate resonance contributions
58175 FUNCTION PYRVI1(ID1,ID2,ID3)
58178 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
58179 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58180 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58181 LOGICAL MFLAG,DCMASS
58182 EXTERNAL PYRVG1,PYGAUS
58183 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58185 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58186 SAVE/PYRVNV/,/PYRVPM/
58187 C...Initialize mass and width information
58193 RESM(1)= RES(IDR,1)
58194 RESW(1)= RES(IDR,2)
58195 C...A->B and B->A for antisparticles
58196 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58197 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58198 C...Integration boundaries and mass flag
58199 LO = (RM(1)+RM(2))**2
58200 HI = (RM(0)-RM(3))**2
58202 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
58206 C*********************************************************************
58209 C...Function to integrate L-R interference contributions
58211 FUNCTION PYRVI2(ID1,ID2,ID3)
58214 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
58215 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58216 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58217 LOGICAL MFLAG,DCMASS
58218 EXTERNAL PYRVG2,PYGAUS
58219 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58221 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58222 SAVE/PYRVNV/,/PYRVPM/
58223 C...Initialize mass and width information
58229 RESM(1)= RES(IDR,1)
58230 RESW(1)= RES(IDR,2)
58231 RESM(2)= RES(IDR+1,1)
58232 RESW(2)= RES(IDR+1,2)
58233 C...A->B and B->A for antisparticles
58234 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58235 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58236 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
58237 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
58238 C...Boundaries and mass flag
58239 LO = (RM(1)+RM(2))**2
58240 HI = (RM(0)-RM(3))**2
58242 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
58246 C*********************************************************************
58249 C...Function to integrate true interference contributions
58251 FUNCTION PYRVI3(ID1,ID2,ID3)
58254 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
58255 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58256 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58257 LOGICAL MFLAG,DCMASS
58258 EXTERNAL PYRVG3,PYGAUS
58259 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58261 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58262 SAVE/PYRVNV/,/PYRVPM/
58263 C...Initialize mass and width information
58269 RESM(1)= RES(IDR,1)
58270 RESW(1)= RES(IDR,2)
58271 RESM(2)= RES(IDR2,1)
58272 RESW(2)= RES(IDR2,2)
58273 C...A -> B and B -> A for antisparticles
58274 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58275 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58276 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
58277 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
58278 C...Boundaries and mass flag
58279 LO = (RM(1)+RM(2))**2
58280 HI = (RM(0)-RM(3))**2
58282 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
58286 C*********************************************************************
58289 C...Integrand for resonance contributions
58294 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58295 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
58296 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
58299 RVR = PYRVR(X,RESM(1),RESW(1))
58300 C1 = 2D0*SQRT(MAX(0D0,X))
58301 IF (.NOT.MFLAG) THEN
58303 E3 = (RM(0)**2-X)/C1
58305 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
58307 E2 = (X-RM(1)**2+RM(2)**2)/C1
58308 E3 = (RM(0)**2-X-RM(3)**2)/C1
58309 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58310 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58311 DELTAY = 4D0*SR1*SR2
58312 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
58313 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
58314 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
58319 C*********************************************************************
58322 C...Integrand for L-R interference contributions
58327 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58328 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
58329 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
58332 C1 = 2D0*SQRT(MAX(0D0,X))
58333 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
58334 IF (.NOT.MFLAG) THEN
58336 E3 = (RM(0)**2-X)/C1
58338 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
58340 E2 = (X-RM(1)**2+RM(2)**2)/C1
58341 E3 = (RM(0)**2-X-RM(3)**2)/C1
58342 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58343 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58344 DELTAY = 4D0*SR1*SR2
58345 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
58346 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
58347 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
58352 C*********************************************************************
58355 C...Function to do Y integration over true interference contributions
58360 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58361 C...Second Dalitz variable for PYRVG4
58363 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
58364 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
58365 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
58367 EXTERNAL PYGAU2,PYRVG4
58368 SAVE/PYRVPM/,/PYG2DX/
58370 C1=2D0*SQRT(MAX(1D-9,X))
58372 IF (.NOT.MFLAG) THEN
58374 E3 = (RM(0)**2-X)/C1
58378 E2 = (X-RM(1)**2+RM(2)**2)/C1
58379 E3 = (RM(0)**2-X-RM(3)**2)/C1
58381 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58382 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58383 YMIN = SQ1-(SR1+SR2)**2
58384 YMAX = SQ1-(SR1-SR2)**2
58386 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
58390 C*********************************************************************
58393 C...Integrand for true intereference contributions
58398 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58400 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
58402 SAVE /PYRVPM/,/PYG2DX/
58404 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
58405 IF (.NOT.MFLAG) THEN
58406 PYRVG4 = RVS*B(1)*B(2)*X*Y
58408 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
58409 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
58410 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
58411 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
58416 C*********************************************************************
58419 C...Breit-Wigner for resonance contributions
58421 FUNCTION PYRVR(Mab2,RM,RW)
58424 DOUBLE PRECISION Mab2,RM,RW,PYRVR
58425 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
58429 C*********************************************************************
58432 C...Interference function
58434 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
58437 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
58438 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
58443 C*********************************************************************
58446 C...Stores one parton/particle in commonblock PYJETS.
58448 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
58450 C...Double precision and integer declarations.
58451 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58452 IMPLICIT INTEGER(I-N)
58453 INTEGER PYK,PYCHGE,PYCOMP
58455 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58456 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58457 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58458 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58460 C...Standard checks.
58462 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58463 IPA=MAX(1,IABS(IP))
58464 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
58465 &'(PY1ENT:) writing outside PYJETS memory')
58467 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
58469 C...Find mass. Reset K, P and V vectors.
58471 IF(MSTU(10).EQ.1) PM=P(IPA,5)
58472 IF(MSTU(10).GE.2) PM=PYMASS(KF)
58479 C...Store parton/particle in K and P vectors.
58481 IF(IP.LT.0) K(IPA,1)=2
58484 P(IPA,4)=MAX(PE,PM)
58485 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
58486 P(IPA,1)=PA*SIN(THE)*COS(PHI)
58487 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
58488 P(IPA,3)=PA*COS(THE)
58490 C...Set N. Optionally fragment/decay.
58492 IF(IP.EQ.0) CALL PYEXEC
58497 C*********************************************************************
58500 C...Stores two partons/particles in their CM frame,
58501 C...with the first along the +z axis.
58503 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
58505 C...Double precision and integer declarations.
58506 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58507 IMPLICIT INTEGER(I-N)
58508 INTEGER PYK,PYCHGE,PYCOMP
58510 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58511 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58512 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58513 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58515 C...Standard checks.
58517 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58518 IPA=MAX(1,IABS(IP))
58519 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
58520 &'(PY2ENT:) writing outside PYJETS memory')
58523 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
58524 &'(PY2ENT:) unknown flavour code')
58526 C...Find masses. Reset K, P and V vectors.
58528 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58529 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58531 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58532 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58541 C...Check flavours.
58542 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58543 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58544 IF(MSTU(19).EQ.1) THEN
58547 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
58548 & '(PY2ENT:) unphysical flavour combination')
58553 C...Store partons/particles in K vectors for normal case.
58556 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
58559 C...Store partons in K vectors for parton shower evolution.
58563 K(IPA,4)=MSTU(5)*(IPA+1)
58565 K(IPA+1,4)=MSTU(5)*IPA
58566 K(IPA+1,5)=K(IPA+1,4)
58569 C...Check kinematics and store partons/particles in P vectors.
58570 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
58571 &'(PY2ENT:) energy smaller than sum of masses')
58572 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
58575 P(IPA,4)=SQRT(PM1**2+PA**2)
58578 P(IPA+1,4)=SQRT(PM2**2+PA**2)
58581 C...Set N. Optionally fragment/decay.
58583 IF(IP.EQ.0) CALL PYEXEC
58588 C*********************************************************************
58591 C...Stores three partons or particles in their CM frame,
58592 C...with the first along the +z axis and the third in the (x,z)
58593 C...plane with x > 0.
58595 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
58597 C...Double precision and integer declarations.
58598 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58599 IMPLICIT INTEGER(I-N)
58600 INTEGER PYK,PYCHGE,PYCOMP
58602 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58603 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58604 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58605 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58607 C...Standard checks.
58609 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58610 IPA=MAX(1,IABS(IP))
58611 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
58612 &'(PY3ENT:) writing outside PYJETS memory')
58616 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
58617 &'(PY3ENT:) unknown flavour code')
58619 C...Find masses. Reset K, P and V vectors.
58621 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58622 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58624 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58625 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58627 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
58628 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
58637 C...Check flavours.
58638 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58639 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58640 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
58641 IF(MSTU(19).EQ.1) THEN
58643 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
58644 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
58645 & KQ1+KQ3.EQ.4)) THEN
58647 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
58653 C...Store partons/particles in K vectors for normal case.
58656 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
58658 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
58661 C...Store partons in K vectors for parton shower evolution.
58667 IF(KQ1.EQ.-1) KCS=5
58668 K(IPA,KCS)=MSTU(5)*(IPA+1)
58669 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
58670 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
58671 K(IPA+1,9-KCS)=MSTU(5)*IPA
58672 K(IPA+2,KCS)=MSTU(5)*IPA
58673 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
58676 C...Check kinematics.
58678 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
58679 &0.5D0*X3*PECM.LE.PM3) MKERR=1
58680 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
58681 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
58682 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
58683 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
58684 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
58685 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
58686 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
58687 IF(MKERR.NE.0) CALL PYERRM(13,
58688 &'(PY3ENT:) unphysical kinematical variable setup')
58690 C...Store partons/particles in P vectors.
58692 P(IPA,4)=SQRT(PA1**2+PM1**2)
58694 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
58695 P(IPA+2,3)=PA3*CTHE3
58696 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
58698 P(IPA+1,1)=-P(IPA+2,1)
58699 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
58700 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
58703 C...Set N. Optionally fragment/decay.
58705 IF(IP.EQ.0) CALL PYEXEC
58710 C*********************************************************************
58713 C...Stores four partons or particles in their CM frame, with
58714 C...the first along the +z axis, the last in the xz plane with x > 0
58715 C...and the second having y < 0 and y > 0 with equal probability.
58717 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
58719 C...Double precision and integer declarations.
58720 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58721 IMPLICIT INTEGER(I-N)
58722 INTEGER PYK,PYCHGE,PYCOMP
58724 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58725 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58726 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58727 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58729 C...Standard checks.
58731 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58732 IPA=MAX(1,IABS(IP))
58733 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
58734 &'(PY4ENT:) writing outside PYJETS momory')
58739 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
58740 &'(PY4ENT:) unknown flavour code')
58742 C...Find masses. Reset K, P and V vectors.
58744 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58745 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58747 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58748 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58750 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
58751 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
58753 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
58754 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
58763 C...Check flavours.
58764 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58765 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58766 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
58767 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
58768 IF(MSTU(19).EQ.1) THEN
58770 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
58771 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
58772 & KQ1+KQ4.EQ.4)) THEN
58773 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
58776 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
58783 C...Store partons/particles in K vectors for normal case.
58786 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
58788 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
58791 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
58794 C...Store partons for parton shower evolution from q-g-g-qbar or
58796 ELSEIF(KQ1+KQ2.NE.0) THEN
58802 IF(KQ1.EQ.-1) KCS=5
58803 K(IPA,KCS)=MSTU(5)*(IPA+1)
58804 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
58805 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
58806 K(IPA+1,9-KCS)=MSTU(5)*IPA
58807 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
58808 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
58809 K(IPA+3,KCS)=MSTU(5)*IPA
58810 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
58812 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
58818 K(IPA,4)=MSTU(5)*(IPA+1)
58820 K(IPA+1,4)=MSTU(5)*IPA
58821 K(IPA+1,5)=K(IPA+1,4)
58822 K(IPA+2,4)=MSTU(5)*(IPA+3)
58823 K(IPA+2,5)=K(IPA+2,4)
58824 K(IPA+3,4)=MSTU(5)*(IPA+2)
58825 K(IPA+3,5)=K(IPA+3,4)
58828 C...Check kinematics.
58830 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
58831 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
58833 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
58834 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
58835 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
58836 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
58837 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
58838 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
58839 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
58840 STHE4=SQRT(1D0-CTHE4**2)
58841 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
58842 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
58843 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
58844 STHE2=SQRT(1D0-CTHE2**2)
58845 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
58846 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
58847 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
58848 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
58849 IF(MKERR.EQ.1) CALL PYERRM(13,
58850 &'(PY4ENT:) unphysical kinematical variable setup')
58852 C...Store partons/particles in P vectors.
58854 P(IPA,4)=SQRT(PA1**2+PM1**2)
58856 P(IPA+3,1)=PA4*STHE4
58857 P(IPA+3,3)=PA4*CTHE4
58858 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
58860 P(IPA+1,1)=PA2*STHE2*CPHI2
58861 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
58862 P(IPA+1,3)=PA2*CTHE2
58863 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
58865 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
58866 P(IPA+2,2)=-P(IPA+1,2)
58867 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
58868 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
58871 C...Set N. Optionally fragment/decay.
58873 IF(IP.EQ.0) CALL PYEXEC
58878 C*********************************************************************
58881 C...An interface from a two-fermion generator to include
58882 C...parton showers and hadronization.
58884 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
58886 C...Double precision and integer declarations.
58887 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58888 IMPLICIT INTEGER(I-N)
58889 INTEGER PYK,PYCHGE,PYCOMP
58891 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58892 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58893 SAVE /PYJETS/,/PYDAT1/
58895 DIMENSION IJOIN(2),INTAU(2)
58897 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
58903 C...Loop through entries and pick up all final fermions/antifermions.
58907 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
58909 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
58910 IF(K(I,2).GT.0) THEN
58914 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
58920 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
58926 C...Check that event is arranged according to conventions.
58927 IF(I1.EQ.0.OR.I2.EQ.0) THEN
58928 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
58931 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
58934 C...Check whether fermion pair is quarks or leptons.
58935 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
58937 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
58940 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
58943 C...Decide whether to allow or not photon radiation in showers.
58945 IF(IRAD.EQ.0) MSTJ(41)=1
58947 C...Do colour joining and parton showers.
58950 IF(IQL12.EQ.1) THEN
58953 CALL PYJOIN(2,IJOIN)
58955 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
58956 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
58957 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
58958 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
58961 C...Do fragmentation and decays. Possibly except tau decay.
58965 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
58979 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
58987 C*********************************************************************
58990 C...An interface from a four-fermion generator to include
58991 C...parton showers and hadronization.
58993 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
58995 C...Double precision and integer declarations.
58996 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58997 IMPLICIT INTEGER(I-N)
58998 INTEGER PYK,PYCHGE,PYCOMP
59000 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59001 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59002 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59003 COMMON/PYINT1/MINT(400),VINT(400)
59004 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
59006 DIMENSION IJOIN(2),INTAU(4)
59008 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59014 C...Loop through entries and pick up all final fermions/antifermions.
59020 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59022 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59023 IF(K(I,2).GT.0) THEN
59026 ELSEIF(I3.EQ.0) THEN
59029 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
59034 ELSEIF(I4.EQ.0) THEN
59037 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
59043 C...Check that event is arranged according to conventions.
59044 IF(I3.EQ.0.OR.I4.EQ.0) THEN
59045 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
59047 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59048 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
59051 C...Check which fermion pairs are quarks and which leptons.
59052 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59054 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59057 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
59059 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59061 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59064 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
59067 C...Decide whether to allow or not photon radiation in showers.
59069 IF(IRAD.EQ.0) MSTJ(41)=1
59071 C...Decide on dipole pairing.
59076 IF(IQL12.EQ.IQL34) THEN
59079 DELTA=ATOTSQ-A1SQ-A2SQ
59080 IF(ISTRAT.EQ.1) THEN
59081 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
59082 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
59083 ELSEIF(ISTRAT.EQ.2) THEN
59084 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
59085 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
59087 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
59093 C...If colour reconnection then bookkeep W+W- or Z0Z0
59094 C...and copy q qbar q qbar consecutively.
59095 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59104 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
59108 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
59122 P(N+1,J)=P(IP1,J)+P(IP2,J)
59123 P(N+2,J)=P(IP3,J)+P(IP4,J)
59135 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59137 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59143 C...Remove original q qbar q qbar and update counters.
59144 K(IP1,1)=K(IP1,1)+10
59145 K(IP2,1)=K(IP2,1)+10
59146 K(IP3,1)=K(IP3,1)+10
59147 K(IP4,1)=K(IP4,1)+10
59158 C...Do colour joinings and parton showers.
59159 IF(IQL12.EQ.1) THEN
59162 CALL PYJOIN(2,IJOIN)
59164 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59165 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59166 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59167 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59170 IF(IQL34.EQ.1) THEN
59173 CALL PYJOIN(2,IJOIN)
59175 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59176 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59177 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59178 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59181 C...Optionally do colour reconnection.
59184 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59185 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
59189 C...Do fragmentation and decays. Possibly except tau decay.
59193 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59207 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59215 C*********************************************************************
59218 C...An interface from a six-fermion generator to include
59219 C...parton showers and hadronization.
59221 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
59223 C...Double precision and integer declarations.
59224 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59225 IMPLICIT INTEGER(I-N)
59226 INTEGER PYK,PYCHGE,PYCOMP
59228 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59229 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59230 SAVE /PYJETS/,/PYDAT1/
59232 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
59234 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59240 C...Loop through entries and pick up all final fermions/antifermions.
59248 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59250 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59251 IF(K(I,2).GT.0) THEN
59254 ELSEIF(I3.EQ.0) THEN
59256 ELSEIF(I5.EQ.0) THEN
59259 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
59264 ELSEIF(I4.EQ.0) THEN
59266 ELSEIF(I6.EQ.0) THEN
59269 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
59275 C...Check that event is arranged according to conventions.
59276 IF(I5.EQ.0.OR.I6.EQ.0) THEN
59277 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
59279 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
59280 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
59283 C...Check which fermion pairs are quarks and which leptons.
59284 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59286 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59289 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
59291 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59293 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59296 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
59298 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
59300 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
59303 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
59306 C...Decide whether to allow or not photon radiation in showers.
59308 IF(IRAD.EQ.0) MSTJ(41)=1
59310 C...Allow dipole pairings only among leptons and quarks separately.
59313 IF(IQL34.EQ.IQL56) P13D=P13
59315 IF(IQL12.EQ.IQL34) P21D=P21
59317 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
59319 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
59321 IF(IQL12.EQ.IQL56) P32D=P32
59323 C...Decide whether t+tbar.
59325 IF(PYR(0).LT.PTOP) THEN
59328 C...If t+tbar: reconstruct t's.
59334 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
59335 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
59343 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
59345 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
59349 C...If t+tbar: colour join t's and let them shower.
59352 CALL PYJOIN(2,IJOIN)
59353 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
59354 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
59355 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
59357 C...If t+tbar: pick up the t's after shower.
59361 IF(K(I,2).EQ.6) ITNEW=I
59362 IF(K(I,2).EQ.-6) ITBNEW=I
59365 C...If t+tbar: loop over two top systems.
59380 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
59381 & '(PY6FRM:) not b in t decay')
59383 C...If t+tbar: find boost from original to new top frame.
59385 BETAO(J)=P(ITO,J)/P(ITO,4)
59386 BETAN(J)=P(ITN,J)/P(ITN,4)
59389 C...If t+tbar: boost copy of b by t shower and connect it in colour.
59399 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59400 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59401 K(IB,4)=MSTU(5)*ITN
59402 K(IB,5)=MSTU(5)*ITN
59403 K(ITN,4)=K(ITN,4)+IB
59404 K(ITN,5)=K(ITN,5)+IB
59405 K(ITN,1)=K(ITN,1)+10
59406 K(IBO,1)=K(IBO,1)+10
59408 C...If t+tbar: construct W recoiling against b.
59416 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
59417 IF(IABS(KCHW).EQ.3) THEN
59418 K(IW,2)=ISIGN(24,KCHW)
59420 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
59424 C...If t+tbar: construct W momentum, including boost by t shower.
59426 P(IW,J)=P(IW1,J)+P(IW2,J)
59428 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
59430 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59431 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59433 C...If t+tbar: boost b and W to top rest frame.
59435 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
59437 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59438 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59440 C...If t+tbar: let b shower and pick up modified W.
59441 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
59442 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
59443 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
59445 IF(IABS(K(I,2)).EQ.24) IWM=I
59448 C...If t+tbar: take copy of W decay products.
59457 K(IW1,1)=K(IW1,1)+10
59458 K(IW2,1)=K(IW2,1)+10
59459 K(IWM,1)=K(IWM,1)+10
59473 C...If t+tbar: boost W decay products, first by effects of t shower,
59474 C...then by those of b shower. b and its shower simple boost back.
59475 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59476 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59477 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59478 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
59479 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
59480 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
59481 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
59482 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
59483 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
59487 C...Decide on dipole pairing.
59491 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
59492 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
59496 ELSEIF(PRN.LT.P12D+P13D) THEN
59500 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
59504 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
59508 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
59518 C...Do colour joinings and parton showers
59519 C...(except ones already made for t+tbar).
59521 IF(IQL12.EQ.1) THEN
59524 CALL PYJOIN(2,IJOIN)
59526 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59527 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59528 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59529 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59532 IF(IQL34.EQ.1) THEN
59535 CALL PYJOIN(2,IJOIN)
59537 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59538 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59539 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59540 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59542 IF(IQL56.EQ.1) THEN
59545 CALL PYJOIN(2,IJOIN)
59547 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
59548 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
59549 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
59550 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
59553 C...Do fragmentation and decays. Possibly except tau decay.
59557 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59571 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59579 C*********************************************************************
59582 C...An interface from a four-parton generator to include
59583 C...parton showers and hadronization.
59585 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
59587 C...Double precision and integer declarations.
59588 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59589 IMPLICIT INTEGER(I-N)
59590 INTEGER PYK,PYCHGE,PYCOMP
59592 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59593 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59594 SAVE /PYJETS/,/PYDAT1/
59596 DIMENSION IJOIN(2),PTOT(4),BETA(3)
59598 C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59604 C...Loop through entries and pick up all final partons.
59610 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59612 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
59613 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
59616 ELSEIF(I3.EQ.0) THEN
59619 CALL PYERRM(16,'(PY4JET:) more than two quarks')
59621 ELSEIF(K(I,2).LT.0) THEN
59624 ELSEIF(I4.EQ.0) THEN
59627 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
59632 ELSEIF(I4.EQ.0) THEN
59635 CALL PYERRM(16,'(PY4JET:) more than two gluons')
59641 C...Check that event is arranged according to conventions.
59642 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
59643 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
59645 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59646 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
59649 C...Check whether second pair are quarks or gluons.
59650 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59652 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
59655 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
59658 C...Boost partons to their cm frame.
59660 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
59662 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
59664 BETA(J)=PTOT(J)/PTOT(4)
59666 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59667 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59668 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59669 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59672 C...Decide and set up shower history for q qbar q' qbar' events.
59673 IF(IQG34.EQ.1) THEN
59674 W1=PY4JTW(0,I1,I3,I4)
59675 W2=PY4JTW(0,I2,I3,I4)
59676 IF(W1.GT.PYR(0)*(W1+W2)) THEN
59677 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
59679 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
59682 C...Decide and set up shower history for q qbar g g events.
59684 W1=PY4JTW(I1,I3,I2,I4)
59685 W2=PY4JTW(I1,I4,I2,I3)
59686 W3=PY4JTW(0,I3,I1,I4)
59687 W4=PY4JTW(0,I4,I1,I3)
59688 W5=PY4JTW(0,I3,I2,I4)
59689 W6=PY4JTW(0,I4,I2,I3)
59690 W7=PY4JTW(0,I1,I3,I4)
59691 W8=PY4JTW(0,I2,I3,I4)
59692 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
59694 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
59695 ELSEIF(W1+W2.GT.WR) THEN
59696 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
59697 ELSEIF(W1+W2+W3.GT.WR) THEN
59698 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
59699 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
59700 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
59701 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
59702 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
59703 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
59704 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
59705 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
59706 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
59708 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
59712 C...Boost back original partons and mark them as deleted.
59713 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
59714 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
59715 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
59716 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
59722 C...Rotate shower initiating partons to be along z axis.
59723 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
59724 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
59725 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
59726 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
59728 C...Set up copy of shower initiating partons as on mass shell.
59738 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
59749 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
59750 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
59752 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
59754 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
59757 C...Decide whether to allow or not photon radiation in showers.
59758 C...Connect up colours.
59760 IF(IRAD.EQ.0) MSTJ(41)=1
59763 CALL PYJOIN(2,IJOIN)
59765 C...Decide on maximum virtuality and do parton shower.
59766 IF(PMAX.LT.PARJ(82)) THEN
59771 CALL PYSHOW(NSAV+1,-100,PQMAX)
59773 C...Rotate and boost back system.
59774 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
59776 C...Do fragmentation and decays.
59779 C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59788 C*********************************************************************
59791 C...Auxiliary to PY4JET, to evaluate weight of configuration.
59793 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
59795 C...Double precision and integer declarations.
59796 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59797 IMPLICIT INTEGER(I-N)
59798 INTEGER PYK,PYCHGE,PYCOMP
59800 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59803 C...First case: when both original partons radiate.
59804 C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
59807 P(N+1,J)=P(IA1,J)+P(IA2,J)
59808 P(N+2,J)=P(IA3,J)+P(IA4,J)
59810 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59812 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59814 Z1=P(IA1,4)/P(N+1,4)
59815 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
59816 Z2=P(IA3,4)/P(N+2,4)
59817 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
59819 C...Second case: when one original parton radiates to three.
59820 C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
59823 P(N+2,J)=P(IA3,J)+P(IA4,J)
59824 P(N+1,J)=P(N+2,J)+P(IA2,J)
59826 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59828 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59830 IF(K(IA2,2).EQ.21) THEN
59831 Z1=P(N+2,4)/P(N+1,4)
59832 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
59835 Z1=P(IA2,4)/P(N+1,4)
59836 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
59839 Z2=P(IA3,4)/P(N+2,4)
59840 IF(K(IA2,2).EQ.21) THEN
59841 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
59843 ELSEIF(K(IA3,2).EQ.21) THEN
59844 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
59846 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
59856 C*********************************************************************
59859 C...Auxiliary to PY4JET, to set up chosen configuration.
59861 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
59863 C...Double precision and integer declarations.
59864 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59865 IMPLICIT INTEGER(I-N)
59866 INTEGER PYK,PYCHGE,PYCOMP
59868 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59880 C...First case: when both original partons radiate.
59881 C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
59884 C...Set up flavour and history pointers for new partons.
59902 C...Set up momenta for new partons.
59904 P(N+1,J)=P(IA1,J)+P(IA2,J)
59905 P(N+2,J)=P(IA3,J)+P(IA4,J)
59911 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59913 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59915 QMAX=MIN(P(N+1,5),P(N+2,5))
59917 C...Second case: q radiates twice.
59918 C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
59919 C...IA5=N+2 does not radiate.
59920 ELSEIF(K(IA2,2).EQ.21) THEN
59922 C...Set up flavour and history pointers for new partons.
59940 C...Set up momenta for new partons.
59942 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
59944 P(N+3,J)=P(IA3,J)+P(IA4,J)
59949 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59951 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
59955 C...Third case: q radiates g, g branches.
59956 C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
59957 C...IA5=N+2 does not radiate.
59960 C...Set up flavour and history pointers for new partons.
59978 C...Set up momenta for new partons.
59980 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
59983 P(N+4,J)=P(IA3,J)+P(IA4,J)
59987 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59989 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
59999 C*********************************************************************
60002 C...Connects a sequence of partons with colour flow indices,
60003 C...as required for subsequent shower evolution (or other operations).
60005 SUBROUTINE PYJOIN(NJOIN,IJOIN)
60007 C...Double precision and integer declarations.
60008 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60009 IMPLICIT INTEGER(I-N)
60010 INTEGER PYK,PYCHGE,PYCOMP
60012 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60013 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60014 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60015 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
60019 C...Check that partons are of right types to be connected.
60020 IF(NJOIN.LT.2) GOTO 120
60024 IF(I.LE.0.OR.I.GT.N) GOTO 120
60025 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
60027 IF(KC.EQ.0) GOTO 120
60028 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
60029 IF(KQ.EQ.0) GOTO 120
60030 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
60031 IF(KQ.NE.2) KQSUM=KQSUM+KQ
60032 IF(IJN.EQ.1) KQS=KQ
60034 IF(KQSUM.NE.0) GOTO 120
60036 C...Connect the partons sequentially (closing for gluon loop).
60038 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
60042 IF(IJN.NE.1) IP=IJOIN(IJN-1)
60043 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
60044 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
60045 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
60046 K(I,KCS)=MSTU(5)*IN
60047 K(I,9-KCS)=MSTU(5)*IP
60048 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
60049 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
60052 C...Error exit: no action taken.
60054 120 CALL PYERRM(12,
60055 &'(PYJOIN:) given entries can not be joined by one string')
60060 C*********************************************************************
60063 C...Sets values of commonblock variables.
60065 SUBROUTINE PYGIVE(CHIN)
60067 C...Double precision and integer declarations.
60068 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60069 IMPLICIT INTEGER(I-N)
60070 INTEGER PYK,PYCHGE,PYCOMP
60072 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60073 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60074 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60075 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60076 COMMON/PYDAT4/CHAF(500,2)
60078 COMMON/PYDATR/MRPY(6),RRPY(100)
60079 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
60080 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60081 COMMON/PYINT1/MINT(400),VINT(400)
60082 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
60083 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
60084 COMMON/PYINT4/MWID(500),WIDS(500,5)
60085 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
60086 COMMON/PYINT6/PROC(0:500)
60088 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
60089 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
60091 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
60092 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
60093 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
60094 COMMON/PYPUED/IUED(0:99),RUED(0:99)
60095 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
60096 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
60097 &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/
60098 C...Local arrays and character variables.
60099 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
60100 &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10,
60102 DIMENSION MSVAR(56,8)
60104 C...For each variable to be translated give: name,
60105 C...integer/real/character, no. of indices, lower&upper index bounds.
60106 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
60107 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
60108 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
60109 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
60110 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
60111 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
60112 &'ITCM','RTCM','IUED','RUED'/
60113 DATA ((MSVAR(I,J),J=1,8),I=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0,
60114 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
60115 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60116 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
60117 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
60118 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
60119 &1,1,1,6,4*0, 2,1,1,100,4*0,
60120 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
60121 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60122 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
60123 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
60124 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
60125 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
60126 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
60127 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
60128 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
60129 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
60130 &1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
60131 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60132 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
60134 C...Length of character variable. Subdivide it into instructions.
60135 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
60136 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
60140 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
60143 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
60145 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
60150 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
60152 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
60154 C...Send off decay-mode on/off commands to PYONOF.
60157 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
60159 IF(IONOF.EQ.1) THEN
60164 C...Peel off any text following exclamation mark.
60166 DO 140 LLOW2=LHIG2,1,-1
60167 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
60169 IF(LBIT.EQ.0) RETURN
60171 C...Identify commonblock variable.
60174 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
60175 &LNAM.LE.6) GOTO 150
60176 CHNAM=CHBIT(1:LNAM-1)//' '
60177 DO 170 LCOM=1,LNAM-1
60179 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
60180 & CHALP(2)(LALP:LALP)
60185 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
60188 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
60190 IF(LLOW.LT.LTOT) GOTO 120
60194 C...Identify any indices.
60199 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
60202 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
60204 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
60205 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
60206 & IVAR.EQ.37)) THEN
60207 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
60208 READ(CHIND,'(I8)') KF
60210 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
60212 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
60215 IF(LLOW.LT.LTOT) GOTO 120
60218 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60219 READ(CHIND,'(I8)') I1
60222 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
60225 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
60228 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
60230 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60231 READ(CHIND,'(I8)') I2
60233 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
60236 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
60239 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
60241 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60242 READ(CHIND,'(I8)') I3
60247 C...Check that indices allowed.
60249 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
60250 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
60252 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
60254 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
60256 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
60258 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
60261 IF(LLOW.LT.LTOT) GOTO 120
60265 C...Save old value of variable.
60268 ELSEIF(IVAR.EQ.2) THEN
60270 ELSEIF(IVAR.EQ.3) THEN
60272 ELSEIF(IVAR.EQ.4) THEN
60274 ELSEIF(IVAR.EQ.5) THEN
60276 ELSEIF(IVAR.EQ.6) THEN
60278 ELSEIF(IVAR.EQ.7) THEN
60280 ELSEIF(IVAR.EQ.8) THEN
60282 ELSEIF(IVAR.EQ.9) THEN
60284 ELSEIF(IVAR.EQ.10) THEN
60286 ELSEIF(IVAR.EQ.11) THEN
60288 ELSEIF(IVAR.EQ.12) THEN
60290 ELSEIF(IVAR.EQ.13) THEN
60292 ELSEIF(IVAR.EQ.14) THEN
60294 ELSEIF(IVAR.EQ.15) THEN
60296 ELSEIF(IVAR.EQ.16) THEN
60298 ELSEIF(IVAR.EQ.17) THEN
60299 CHOLD=CHAF(I1,I2)(1:8)
60300 ELSEIF(IVAR.EQ.18) THEN
60302 ELSEIF(IVAR.EQ.19) THEN
60304 ELSEIF(IVAR.EQ.20) THEN
60306 ELSEIF(IVAR.EQ.21) THEN
60308 ELSEIF(IVAR.EQ.22) THEN
60310 ELSEIF(IVAR.EQ.23) THEN
60312 ELSEIF(IVAR.EQ.24) THEN
60314 ELSEIF(IVAR.EQ.25) THEN
60316 ELSEIF(IVAR.EQ.26) THEN
60318 ELSEIF(IVAR.EQ.27) THEN
60320 ELSEIF(IVAR.EQ.28) THEN
60322 ELSEIF(IVAR.EQ.29) THEN
60324 ELSEIF(IVAR.EQ.30) THEN
60326 ELSEIF(IVAR.EQ.31) THEN
60328 ELSEIF(IVAR.EQ.32) THEN
60330 ELSEIF(IVAR.EQ.33) THEN
60331 IOLD=ICOL(I1,I2,I3)
60332 ELSEIF(IVAR.EQ.34) THEN
60334 ELSEIF(IVAR.EQ.35) THEN
60336 ELSEIF(IVAR.EQ.36) THEN
60338 ELSEIF(IVAR.EQ.37) THEN
60340 ELSEIF(IVAR.EQ.38) THEN
60342 ELSEIF(IVAR.EQ.39) THEN
60344 ELSEIF(IVAR.EQ.40) THEN
60346 ELSEIF(IVAR.EQ.41) THEN
60348 ELSEIF(IVAR.EQ.42) THEN
60349 ROLD=SIGT(I1,I2,I3)
60350 ELSEIF(IVAR.EQ.43) THEN
60352 ELSEIF(IVAR.EQ.44) THEN
60354 ELSEIF(IVAR.EQ.45) THEN
60356 ELSEIF(IVAR.EQ.46) THEN
60358 ELSEIF(IVAR.EQ.47) THEN
60360 ELSEIF(IVAR.EQ.48) THEN
60362 ELSEIF(IVAR.EQ.49) THEN
60364 ELSEIF(IVAR.EQ.50) THEN
60365 ROLD=RVLAM(I1,I2,I3)
60366 ELSEIF(IVAR.EQ.51) THEN
60367 ROLD=RVLAMP(I1,I2,I3)
60368 ELSEIF(IVAR.EQ.52) THEN
60369 ROLD=RVLAMB(I1,I2,I3)
60370 ELSEIF(IVAR.EQ.53) THEN
60372 ELSEIF(IVAR.EQ.54) THEN
60374 ELSEIF(IVAR.EQ.55) THEN
60376 ELSEIF(IVAR.EQ.56) THEN
60380 C...Print current value of variable. Loop back.
60381 IF(LNAM.GE.LBIT) THEN
60383 CHBIT(15:60)=' has the value '
60384 IF(MSVAR(IVAR,1).EQ.1) THEN
60385 WRITE(CHBIT(51:60),'(I10)') IOLD
60386 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60387 WRITE(CHBIT(47:60),'(F14.5)') ROLD
60388 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60393 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60395 IF(LLOW.LT.LTOT) GOTO 120
60399 C...Read in new variable value.
60400 IF(MSVAR(IVAR,1).EQ.1) THEN
60402 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
60403 READ(CHINI,'(I10)') INEW
60404 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60406 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
60408 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60409 CHNEW=CHBIT(LNAM+1:LBIT)//' '
60411 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
60414 C...Store new variable value.
60417 ELSEIF(IVAR.EQ.2) THEN
60419 ELSEIF(IVAR.EQ.3) THEN
60421 ELSEIF(IVAR.EQ.4) THEN
60423 ELSEIF(IVAR.EQ.5) THEN
60425 ELSEIF(IVAR.EQ.6) THEN
60427 ELSEIF(IVAR.EQ.7) THEN
60429 ELSEIF(IVAR.EQ.8) THEN
60431 ELSEIF(IVAR.EQ.9) THEN
60433 ELSEIF(IVAR.EQ.10) THEN
60435 ELSEIF(IVAR.EQ.11) THEN
60437 ELSEIF(IVAR.EQ.12) THEN
60439 ELSEIF(IVAR.EQ.13) THEN
60441 ELSEIF(IVAR.EQ.14) THEN
60443 ELSEIF(IVAR.EQ.15) THEN
60445 ELSEIF(IVAR.EQ.16) THEN
60447 ELSEIF(IVAR.EQ.17) THEN
60449 ELSEIF(IVAR.EQ.18) THEN
60451 ELSEIF(IVAR.EQ.19) THEN
60453 ELSEIF(IVAR.EQ.20) THEN
60455 ELSEIF(IVAR.EQ.21) THEN
60457 ELSEIF(IVAR.EQ.22) THEN
60459 ELSEIF(IVAR.EQ.23) THEN
60461 ELSEIF(IVAR.EQ.24) THEN
60463 ELSEIF(IVAR.EQ.25) THEN
60465 ELSEIF(IVAR.EQ.26) THEN
60467 ELSEIF(IVAR.EQ.27) THEN
60469 ELSEIF(IVAR.EQ.28) THEN
60471 ELSEIF(IVAR.EQ.29) THEN
60473 ELSEIF(IVAR.EQ.30) THEN
60475 ELSEIF(IVAR.EQ.31) THEN
60477 ELSEIF(IVAR.EQ.32) THEN
60479 ELSEIF(IVAR.EQ.33) THEN
60480 ICOL(I1,I2,I3)=INEW
60481 ELSEIF(IVAR.EQ.34) THEN
60483 ELSEIF(IVAR.EQ.35) THEN
60485 ELSEIF(IVAR.EQ.36) THEN
60487 ELSEIF(IVAR.EQ.37) THEN
60489 ELSEIF(IVAR.EQ.38) THEN
60491 ELSEIF(IVAR.EQ.39) THEN
60493 ELSEIF(IVAR.EQ.40) THEN
60495 ELSEIF(IVAR.EQ.41) THEN
60497 ELSEIF(IVAR.EQ.42) THEN
60498 SIGT(I1,I2,I3)=RNEW
60499 ELSEIF(IVAR.EQ.43) THEN
60501 ELSEIF(IVAR.EQ.44) THEN
60503 ELSEIF(IVAR.EQ.45) THEN
60505 ELSEIF(IVAR.EQ.46) THEN
60507 ELSEIF(IVAR.EQ.47) THEN
60509 ELSEIF(IVAR.EQ.48) THEN
60511 ELSEIF(IVAR.EQ.49) THEN
60513 ELSEIF(IVAR.EQ.50) THEN
60514 RVLAM(I1,I2,I3)=RNEW
60515 ELSEIF(IVAR.EQ.51) THEN
60516 RVLAMP(I1,I2,I3)=RNEW
60517 ELSEIF(IVAR.EQ.52) THEN
60518 RVLAMB(I1,I2,I3)=RNEW
60519 ELSEIF(IVAR.EQ.53) THEN
60521 ELSEIF(IVAR.EQ.54) THEN
60523 ELSEIF(IVAR.EQ.55) THEN
60525 ELSEIF(IVAR.EQ.56) THEN
60529 C...Write old and new value. Loop back.
60531 CHBIT(15:60)=' changed from to '
60532 IF(MSVAR(IVAR,1).EQ.1) THEN
60533 WRITE(CHBIT(33:42),'(I10)') IOLD
60534 WRITE(CHBIT(51:60),'(I10)') INEW
60535 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60536 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60537 WRITE(CHBIT(29:42),'(F14.5)') ROLD
60538 WRITE(CHBIT(47:60),'(F14.5)') RNEW
60539 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60540 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60543 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60545 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
60546 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
60549 IF(LLOW.LT.LTOT) GOTO 120
60551 C...Format statement for output on unit MSTU(11) (by default 6).
60552 5000 FORMAT(5X,A60)
60553 5100 FORMAT(5X,A88)
60558 C*********************************************************************
60561 C...Switches on and off decay channel by search for match.
60563 SUBROUTINE PYONOF(CHIN)
60565 C...Double precision and integer declarations.
60566 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60567 IMPLICIT INTEGER(I-N)
60568 INTEGER PYK,PYCHGE,PYCOMP
60570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60571 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60572 SAVE /PYDAT1/,/PYDAT3/
60573 C...Local arrays and character variables.
60574 INTEGER KFCMP(10),KFTMP(10)
60575 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
60577 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60578 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
60580 C...Determine length of character variable.
60584 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
60587 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
60589 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
60591 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
60593 C...Find colon separator and particle code.
60595 120 LCOLON=LCOLON+1
60596 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
60598 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
60599 READ(CHCODE,'(I8)',ERR=300) KF
60602 C...Done if unknown code or no decay channels.
60604 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
60609 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
60610 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
60614 C...Find command name up to blank or equal sign.
60617 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
60618 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
60620 LMODE=LSEP-LCOLON-1
60621 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
60623 C...Convert to uppercase.
60624 DO 150 LCOM=1,LMODE
60626 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
60627 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
60631 C...Identify command. Failed if not identified.
60633 IF(CHMODE.EQ.'ALLOFF') MODE=1
60634 IF(CHMODE.EQ.'ALLON') MODE=2
60635 IF(CHMODE.EQ.'OFFIFANY') MODE=3
60636 IF(CHMODE.EQ.'ONIFANY') MODE=4
60637 IF(CHMODE.EQ.'OFFIFALL') MODE=5
60638 IF(CHMODE.EQ.'ONIFALL') MODE=6
60639 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
60640 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
60642 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
60646 C...Simple cases when all on or all off.
60647 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
60648 WRITE(MSTU(11),1000) KF,CHMODE
60649 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
60650 IF(MDME(IDC,1).LT.0) GOTO 160
60656 C...Identify matching list.
60660 IF(LBEG.GT.LEN) GOTO 190
60661 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
60662 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
60665 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
60666 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
60667 IF(LEND.LT.LEN) LEND=LEND-1
60669 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
60670 READ(CHCODE,'(I8)',ERR=300) KFREAD
60672 KFCMP(NCMP)=IABS(KFREAD)
60674 IF(NCMP.LT.10) GOTO 170
60676 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
60678 C...Only one matching required.
60679 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
60680 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
60681 IF(MDME(IDC,1).LT.0) GOTO 220
60683 KFNOW=IABS(KFDP(IDC,IKF))
60684 IF(KFNOW.EQ.0) GOTO 210
60686 IF(KFCMP(ICMP).EQ.KFNOW) THEN
60696 C...Multiple matchings required.
60697 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
60698 IF(MDME(IDC,1).LT.0) GOTO 260
60701 KFTMP(ITMP)=KFCMP(ITMP)
60705 KFNOW=IABS(KFDP(IDC,IKF))
60706 IF(KFNOW.EQ.0) GOTO 250
60709 IF(KFTMP(ITMP).EQ.KFNOW) THEN
60710 KFTMP(ITMP)=KFTMP(NTMP)
60716 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
60717 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
60718 & MDME(IDC,1)=MODE-7
60722 C...Error exit for impossible read of particle code.
60723 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
60726 C...Formats for output.
60727 1000 FORMAT(' Decays for',I8,' set ',A10)
60728 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
60732 C*********************************************************************
60735 C...Presets for a few specific underlying-event and min-bias tunes
60736 C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
60737 C...others require particular versions of pythia (e.g. the SCI and GAL
60738 C...models). See below for details.
60739 SUBROUTINE PYTUNE(ITUNE)
60741 C ITUNE NAME (detailed descriptions below)
60742 C 0 Default : No settings changed => defaults.
60744 C ====== Old UE, Q2-ordered showers ====================================
60745 C 100 A : Rick Field's CDF Tune A (Oct 2002)
60746 C 101 AW : Rick Field's CDF Tune AW (Apr 2006)
60747 C 102 BW : Rick Field's CDF Tune BW (Apr 2006)
60748 C 103 DW : Rick Field's CDF Tune DW (Apr 2006)
60749 C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006)
60750 C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?)
60751 C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?)
60752 C 107 ACR : Tune A modified with new CR model (Mar 2007)
60753 C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?)
60754 C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?)
60755 C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
60756 C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008)
60757 C 111 AW-Pro : Tune AW, -"- (Oct 2008)
60758 C 112 BW-Pro : Tune BW, -"- (Oct 2008)
60759 C 113 DW-Pro : Tune DW, -"- (Oct 2008)
60760 C 114 DWT-Pro : Tune DWT, -"- (Oct 2008)
60761 C 115 QW-Pro : Tune QW, -"- (Oct 2008)
60762 C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008)
60763 C 117 ACR-Pro : Tune ACR, -"- (Oct 2008)
60764 C 118 D6-Pro : Tune D6, -"- (Oct 2008)
60765 C 119 D6T-Pro : Tune D6T, -"- (Oct 2008)
60766 C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
60767 C 129 Pro-Q20 : Professor Q2-ordered tune (Feb 2009)
60769 C ====== Intermediate and Hybrid Models ================================
60770 C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
60771 C 201 APT : Tune A w. pT-ordered FSR (Mar 2007)
60772 C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008)
60773 C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009)
60774 C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
60776 C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
60777 C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006)
60778 C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006)
60779 C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006)
60780 C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006)
60781 C 304 NOCR : New UE "best try" without col. rec. (Apr 2006)
60782 C 305 Old : New UE, original (primitive) col. rec. (Aug 2004)
60783 C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
60784 C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
60785 C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008)
60786 C 311 S1-Pro : S1 -"- (Oct 2008)
60787 C 312 S2-Pro : S2 -"- (Oct 2008)
60788 C 313 S0A-Pro : S0A -"- (Oct 2008)
60789 C 314 NOCR-Pro : NOCR -"- (Oct 2008)
60790 C 315 Old-Pro : Old -"- (Oct 2008)
60791 C ---- Peter's Perugia Tunes : 320+ ------------------------------------
60792 C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009)
60793 C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
60794 C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
60795 C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
60796 C balance & different scaling to LHC & RHIC (Feb 2009)
60797 C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009)
60798 C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
60799 C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
60800 C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
60801 C 329 Pro-pT0 : Professor pT-ordered tune w. S0 CR model (Feb 2009)
60803 C ======= The Uppsala models ===========================================
60804 C ( NB! must be run with special modified Pythia 6.215 version )
60805 C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
60806 C 400 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
60807 C 401 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
60808 C 402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006)
60809 C 403 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
60813 C Quick Dictionary:
60814 C BE : Bose-Einstein
60815 C BR : Beam Remnants
60816 C CR : Colour Reconnections
60817 C HAD: Hadronization
60818 C ISR/FSR: Initial-State Radiation / Final-State Radiation
60819 C FSI: Final-State Interactions (=CR+BE)
60820 C MB : Minimum-bias
60821 C MI : Multiple Interactions
60822 C UE : Underlying Event
60824 C=======================================================================
60825 C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
60826 C=======================================================================
60828 C A (100) and AW (101). CTEQ5L parton distributions
60829 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60830 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60831 C...Key feature: extensively compared to CDF data (R.D. Field).
60832 C...* Large starting scale for ISR (PARP(67)=4)
60833 C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
60834 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60836 C BW (102). CTEQ5L parton distributions
60837 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60838 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60839 C...Key feature: extensively compared to CDF data (R.D. Field).
60840 C...NB: Can also be run with Pythia 6.2 or 6.312+
60841 C...* Small starting scale for ISR (PARP(67)=1)
60842 C...* BW has more radiation due to smaller mu_R choice in alpha_s.
60843 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60845 C DW (103) and DWT (104). CTEQ5L parton distributions
60846 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60847 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60848 C...Key feature: extensively compared to CDF data (R.D. Field).
60849 C...NB: Can also be run with Pythia 6.2 or 6.312+
60850 C...* Intermediate starting scale for ISR (PARP(67)=2.5)
60851 C...* DWT has a different reference energy, the same as the "S" models
60852 C... below, leading to more UE activity at the LHC, but less at RHIC.
60853 C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60855 C QW (105). CTEQ61 parton distributions
60856 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60857 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60858 C...Key feature: uses CTEQ61 (external pdf library must be linked)
60860 C ATLAS-DC2 (106). CTEQ5L parton distributions
60861 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60862 C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60863 C...Key feature: tune used by the ATLAS collaboration.
60865 C ACR (107). CTEQ5L parton distributions
60866 C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
60867 C...Key feature: Tune A modified to use annealing CR.
60868 C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
60870 C D6 (108) and D6T (109). CTEQ6L parton distributions
60871 C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
60873 C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
60874 C Old UE model, Q2-ordered showers.
60875 C...Key feature: Rick Field's family of tunes revamped with the
60876 C...Professor Q2-ordered final-state shower and fragmentation tunes
60877 C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
60878 C...Key feature: improved descriptions of LEP data.
60880 C Pro-Q20 (129). CTEQ5L parton distributions
60881 C Old UE model, Q2-ordered showers.
60882 C...Key feature: Complete retune of old model by Professor, including
60883 C...large amounts of both LEP and Tevatron data.
60884 C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
60885 C...extreme in this tune, corresponding to using mu_R = pT/3 .
60887 C=======================================================================
60888 C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
60889 C=======================================================================
60891 C IM1 (200). Intermediate model, Q2-ordered showers,
60892 C CTEQ5L parton distributions
60893 C...Key feature: new UE model w Q2-ordered showers and no interleaving.
60894 C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
60895 C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
60897 C APT (201). Old UE model, pT-ordered final-state showers,
60898 C CTEQ5L parton distributions
60899 C...Key feature: Rick Field's Tune A, but with new final-state showers
60901 C APT-Pro (211). Old UE model, pT-ordered final-state showers,
60902 C CTEQ5L parton distributions
60903 C...Key feature: APT revamped with the Professor pT-ordered final-state
60904 C...shower and fragmentation tunes presented by Hendrik Hoeth at the
60905 C...Perugia MPI workshop in October 2008.
60907 C Perugia-APT (221). Old UE model, pT-ordered final-state showers,
60908 C CTEQ5L parton distributions
60909 C...Key feature: APT-Pro with final-state showers off the MPI,
60910 C...lower ISR renormalization scale to improve agreement with the
60911 C...Tevatron Drell-Yan pT measurements and with improved energy scaling
60912 C...to min-bias at 630 GeV.
60914 C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
60915 C CTEQ6L1 parton distributions.
60916 C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
60917 C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
60918 C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
60920 C=======================================================================
60921 C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
60922 C=======================================================================
60924 C S0 (300) and S0A (303). CTEQ5L parton distributions
60925 C...Key feature: large amount of multiple interactions
60926 C...* Somewhat faster than the other colour annealing scenarios.
60927 C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
60928 C... from Tune A, leading to less UE at the LHC, but more at RHIC.
60929 C...* Small amount of radiation.
60930 C...* Large amount of low-pT MI
60931 C...* Low degree of proton lumpiness (broad matter dist.)
60932 C...* CR Type S (driven by free triplets), of medium strength.
60933 C...* See: Pythia6402 update notes or later.
60935 C S1 (301). CTEQ5L parton distributions
60936 C...Key feature: large amount of radiation.
60937 C...* Large amount of low-pT perturbative ISR
60938 C...* Large amount of FSR off ISR partons
60939 C...* Small amount of low-pT multiple interactions
60940 C...* Moderate degree of proton lumpiness
60941 C...* Least aggressive CR type (S+S Type I), but with large strength
60942 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60944 C S2 (302). CTEQ5L parton distributions
60945 C...Key feature: very lumpy proton + gg string cluster formation allowed
60946 C...* Small amount of radiation
60947 C...* Moderate amount of low-pT MI
60948 C...* High degree of proton lumpiness (more spiky matter distribution)
60949 C...* Most aggressive CR type (S+S Type II), but with small strength
60950 C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60952 C NOCR (304). CTEQ5L parton distributions
60953 C...Key feature: no colour reconnections (NB: "Best fit" only).
60954 C...* NB: <pT>(Nch) problematic in this tune.
60955 C...* Small amount of radiation
60956 C...* Small amount of low-pT MI
60957 C...* Low degree of proton lumpiness
60958 C...* Large BR composite x enhancement factor
60959 C...* Most clever colour flow without CR ("Lambda ordering")
60961 C ATLAS-CSC (306). CTEQ6L parton distributions
60962 C...Key feature: 11-parameter ATLAS tune of the new framework.
60963 C...* Old (pre-annealing) colour reconnections a la 305.
60964 C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
60966 C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
60967 C...Key feature: the S0 family of tunes revamped with the Professor
60968 C...pT-ordered final-state shower and fragmentation tunes presented by
60969 C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
60970 C...Key feature: improved descriptions of LEP data.
60972 C Perugia-0 (320). CTEQ5L parton distributions.
60973 C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
60974 C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
60975 C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
60976 C...beam-remnant breakup (more baryon number transport), and suppression
60977 C...of CR in high-pT string pieces.
60979 C Perugia-HARD (321). CTEQ5L parton distributions.
60980 C...Key feature: More ISR, More FSR, Less MPI, Less BR
60981 C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
60982 C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
60983 C...baryon number transport), and more fragmentation pT.
60984 C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
60985 C...DY pT spectrum is HARD.
60987 C Perugia-SOFT (322). CTEQ5L parton distributions.
60988 C...Key feature: Less ISR, Less FSR, More MPI, More BR
60989 C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
60990 C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
60991 C...number transport), and less fragmentation pT.
60992 C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
60993 C...DY pT spectrum is SOFT
60995 C Perugia-3 (323). CTEQ5L parton distributions.
60996 C...Key feature: variant of Perugia-0 with more extreme energy scaling
60997 C...properties while still agreeing with Tevatron data from 630 to 1960.
60998 C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
60999 C...allows FSR off the active end of dipoles stretched to the remnant.
61001 C Perugia-NOCR (324). CTEQ5L parton distributions.
61002 C...Key feature: Retune of NOCR-Pro with better scaling properties to
61003 C...lower energies and somewhat better agreement with Tevatron data
61006 C Perugia-* (325). MRST LO* parton distributions for generators
61007 C...Key feature: first attempt at using the LO* distributions
61008 C...(external pdf library must be linked).
61010 C Perugia-6 (326). CTEQ6L1 parton distributions
61011 C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
61013 C Pro-pT0 (329). CTEQ5L parton distributions
61014 C...Key feature: Complete retune of new model by Professor, including
61015 C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
61017 C=======================================================================
61019 C=======================================================================
61021 C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
61022 C...with an unmodified Pythia distribution.
61023 C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
61025 C ::: + Future improvements?
61026 C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
61027 C (problem: K-factor affects everything so only works as
61028 C intended for min-bias, not for UE ... probably need a
61029 C better long-term solution to handle UE as well. Anyway,
61030 C Mark uses MSTP(33) and PARP(31)-PARP(33).)
61032 C...Global statements
61033 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61034 INTEGER PYK,PYCHGE,PYCOMP
61037 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61038 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
61040 C...SCI and GAL Commonblocks
61041 COMMON /SCIPAR/MSWI(2),PARSCI(2)
61043 C...SAVE statements
61044 SAVE /PYDAT1/,/PYPARS/
61047 C...Internal parameters
61048 PARAMETER(MXTUNS=500)
61049 CHARACTER*8 CHVERS, CHDOC
61050 PARAMETER (CHVERS='1.015 ',CHDOC='Jan 2009')
61051 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
61052 CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
61053 & CHPARJ(1:100), CH40
61056 DATA (CHNAMS(I),I=0,1)/'Default',' '/
61057 DATA (CHNAMS(I),I=100,119)/
61058 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
61059 & 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
61060 1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
61061 1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
61062 1 'Tune D6-Pro','Tune D6T-Pro'/
61063 DATA (CHNAMS(I),I=120,129)/
61065 DATA (CHNAMS(I),I=300,309)/
61066 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
61067 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
61068 DATA (CHNAMS(I),I=310,315)/
61069 & 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
61070 & 'NOCR-Pro','Old-Pro'/
61071 DATA (CHNAMS(I),I=320,329)/
61072 & 'Perugia 0','Perugia HARD','Perugia SOFT',
61073 & 'Perugia 3','Perugia NOCR','Perugia LO*',
61074 & 'Perugia 6',2*' ','Pro-pT0'/
61075 DATA (CHNAMS(I),I=200,229)/
61076 & 'IM Tune 1','Tune APT',8*' ',
61077 & ' ','Tune APT-Pro',8*' ',
61078 & ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
61079 DATA (CHNAMS(I),I=400,409)/
61080 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
61081 DATA (CHMSTJ(I),I=11,20)/
61082 & 'HAD choice of fragmentation function(s)',4*' ',
61083 & 'HAD treatment of small-mass systems',4*' '/
61084 DATA (CHMSTJ(I),I=41,50)/
61085 & 'FSR type (Q2 or pT) for old framework',9*' '/
61086 DATA (CHMSTP(I),I=51,100)/
61087 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
61088 6 'ISR master switch',2*' ','ISR alphaS type',2*' ',
61089 6 'ISR coherence option for 1st emission',
61090 6 'ISR phase space choice & ME corrections',' ',
61091 7 'ISR IR regularization scheme',' ',
61092 7 'ISR scheme for FSR off ISR',8*' ',
61094 8 'UE hadron transverse mass distribution',5*' ',
61095 8 'BR composite scheme','BR colour scheme',
61096 9 'BR primordial kT compensation',
61097 9 'BR primordial kT distribution',
61098 9 'BR energy partitioning scheme',2*' ',
61099 9 'FSI colour (re-)connection model',5*' '/
61100 DATA (CHPARP(I),I=61,100)/
61101 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
61102 6 2*' ','ISR Q2max factor',3*' ',
61103 7 'FSR Q2max factor for non-s-channel procs',5*' ',
61104 7 'FSI colour reco high-pT dampening strength',
61105 7 'FSI colour reconnection strength',
61106 7 'BR composite x enhancement','BR breakup suppression',
61107 8 2*'UE IR cutoff at reference ecm',
61108 8 2*'UE mass distribution parameter',
61109 8 'UE gg colour correlated fraction','UE total gg fraction',
61111 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
61112 9 'BR primordial kT width <|kT|>',' ',
61113 9 'BR primordial kT UV cutoff',7*' '/
61114 DATA (CHPARJ(I),I=1,30)/
61115 & 'HAD diquark suppression','HAD strangeness suppression',
61116 & 'HAD strange diquark suppression',
61117 & 'HAD vector diquark suppression',6*' ',
61118 1 'HAD P(vector meson), u and d only',
61119 1 'HAD P(vector meson), contains s',
61120 1 'HAD P(vector meson), heavy quarks',7*' ',
61121 2 'HAD fragmentation pT',' ',' ',' ',
61122 2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
61123 DATA (CHPARJ(I),I=41,90)/
61124 4 'HAD string parameter a','HAD string parameter b',3*' ',
61125 4 'HAD Lund(=0)-Bowler(=1) rQ (rc)',
61126 4 'HAD Lund(=0)-Bowler(=1) rb',3*' ',
61127 5 3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
61129 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
61131 C...1) Shorthand notation
61134 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
61135 CHNAME=CHNAMS(ITUNE)
61136 IF (ITUNE.EQ.0) GOTO 9999
61138 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
61143 IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
61145 C...3) Tune parameters
61147 C=======================================================================
61148 C...S0, S1, S2, S0A, NOCR, Rap,
61149 C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
61150 C...Perugia 0, HARD, SOFT, Perugia 3, Perugia LO*, Perugia 6
61152 IF ((ITUNE.GE.300.AND.ITUNE.LE.305)
61153 & .OR.(ITUNE.GE.310.AND.ITUNE.LE.315)
61154 & .OR.(ITUNE.GE.320.AND.ITUNE.LE.326).OR.ITUNE.EQ.329) THEN
61155 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
61156 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
61157 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61159 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326.AND.ITUNE.NE.324.AND.
61160 & (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419)))
61162 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61166 C...Use Professor's LEP pars if ITUNE >= 310
61167 C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
61168 IF (ITUNE.LT.310) THEN
61171 C...# Old default flavour parameters
61178 ELSEIF (ITUNE.GE.310) THEN
61179 C...# Tuned flavour parameters:
61189 C...# Always use pT-ordered shower:
61191 C...# Switch on Bowler:
61193 C...# Fragmentation
61202 C...Remove middle digit now for Professor variants, since identical pars
61204 IF (ITUNE.GE.310.AND.ITUNE.LE.319) THEN
61205 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
61208 C...PDFs: all use CTEQ5L as starting point
61211 IF (ITUNE.EQ.325) THEN
61212 C...MRST LO* for 325
61215 ELSEIF (ITUNE.EQ.326) THEN
61216 C...CTEQ6L1 for 326
61221 C...ISR: use Lambda_MSbar with default scale for S0(A)
61224 IF (ITUNE.EQ.320.OR.ITUNE.EQ.323.OR.ITUNE.EQ.324.OR.
61225 & ITUNE.EQ.326) THEN
61226 C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
61229 ELSEIF (ITUNE.EQ.321) THEN
61230 C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
61233 ELSEIF (ITUNE.EQ.322) THEN
61234 C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
61237 ELSEIF (ITUNE.EQ.325) THEN
61238 C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
61241 ELSEIF (ITUNE.EQ.329) THEN
61242 C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
61247 C...ISR : power-suppressed power showers above s_color (since 6.4.19)
61250 C...Perugia tunes have stronger suppression, except HARD
61251 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61253 IF (ITUNE.EQ.321) PARP(67)=4D0
61254 IF (ITUNE.EQ.322) PARP(67)=0.5D0
61257 C...ISR IR cutoff type and FSR off ISR setting:
61258 C...Smooth ISR, low FSR-off-ISR
61261 IF (ITUNEB.EQ.301) THEN
61262 C...S1, S1-Pro: sharp ISR, high FSR
61265 ELSEIF (ITUNE.EQ.320.OR.ITUNE.EQ.324.OR.ITUNE.EQ.326
61266 & .OR.ITUNE.EQ.325) THEN
61267 C...Perugia default is smooth ISR, high FSR-off-ISR
61270 ELSEIF (ITUNE.EQ.321) THEN
61271 C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
61275 ELSEIF (ITUNE.EQ.322) THEN
61276 C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
61280 ELSEIF (ITUNE.EQ.323) THEN
61281 C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
61287 C...FSR activity: Perugia tunes use a lower PARP(71) as indicated
61288 C...by Professor tunes (with HARD and SOFT variations)
61290 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61292 IF (ITUNE.EQ.321) PARP(71)=4D0
61293 IF (ITUNE.EQ.322) PARP(71)=1D0
61295 IF (ITUNE.EQ.329) PARP(71)=2D0
61297 C...FSR: Lambda_FSR scale (only if not using professor)
61298 IF (ITUNE.LT.310) PARJ(81)=0.23D0
61299 IF (ITUNE.EQ.321) PARJ(81)=0.30D0
61300 IF (ITUNE.EQ.322) PARJ(81)=0.20D0
61302 C...UE on, new model
61305 C...UE: hadron-hadron overlap profile (expOfPow for all)
61307 C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
61309 IF (ITUNEB.EQ.301) PARP(83)=1.4D0
61310 IF (ITUNEB.EQ.302) PARP(83)=1.2D0
61311 C...NOCR variants have very smooth distributions
61312 IF (ITUNEB.EQ.304) PARP(83)=1.8D0
61313 IF (ITUNEB.EQ.305) PARP(83)=2.0D0
61314 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61315 C...Perugia variants have slightly smoother profiles by default
61316 C...(to compensate for more tail by added radiation)
61317 C...Perugia-SOFT has more peaked distribution, NOCR less peaked
61319 IF (ITUNE.EQ.322) PARP(83)=1.5D0
61320 IF (ITUNE.EQ.324) PARP(83)=1.8D0
61322 C...Professor-pT0 also has very smooth distribution
61323 IF (ITUNE.EQ.329) PARP(83)=1.8
61325 C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
61327 IF (ITUNEB.EQ.301) PARP(82)=2.1D0
61328 IF (ITUNEB.EQ.302) PARP(82)=1.9D0
61329 IF (ITUNEB.EQ.304) PARP(82)=2.05D0
61330 IF (ITUNEB.EQ.305) PARP(82)=1.9D0
61331 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61332 C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
61333 C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
61334 C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
61335 C...slightly higher, due to increased activity.
61337 IF (ITUNE.EQ.321) PARP(82)=2.3D0
61338 IF (ITUNE.EQ.322) PARP(82)=1.9D0
61339 IF (ITUNE.EQ.323) PARP(82)=2.2D0
61340 IF (ITUNE.EQ.324) PARP(82)=1.95D0
61341 IF (ITUNE.EQ.325) PARP(82)=2.2D0
61342 IF (ITUNE.EQ.326) PARP(82)=1.95D0
61344 C...Professor-pT0 maintains low pT0 vaue
61345 IF (ITUNE.EQ.329) PARP(82)=1.85D0
61347 C...UE: IR cutoff reference energy and default energy scaling pace
61350 C...S0A, S0A-Pro have tune A energy scaling
61351 IF (ITUNEB.EQ.303) PARP(90)=0.25D0
61352 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61353 C...Perugia tunes explicitly include MB at 630 to fix energy scaling
61355 IF (ITUNE.EQ.321) PARP(90)=0.30D0
61356 IF (ITUNE.EQ.322) PARP(90)=0.24D0
61357 IF (ITUNE.EQ.323) PARP(90)=0.32D0
61358 IF (ITUNE.EQ.324) PARP(90)=0.24D0
61359 C...LO* and CTEQ6L1 tunes have slower energy scaling
61360 IF (ITUNE.EQ.325) PARP(90)=0.23D0
61361 IF (ITUNE.EQ.326) PARP(90)=0.22D0
61363 C...Professor-pT0 has intermediate scaling
61364 IF (ITUNE.EQ.329) PARP(90)=0.22D0
61366 C...BR: MPI initiator color connections rap-ordered by default
61367 C...NOCR variants are Lambda-ordered, Perugia SOFT is random-ordered
61369 IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89)=2
61370 IF (ITUNE.EQ.322) MSTP(89)=0
61372 C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
61374 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61375 C...Perugia tunes have more beam blowup by default
61377 IF (ITUNE.EQ.321) PARP(80)=0.01
61378 IF (ITUNE.EQ.323) PARP(80)=0.03
61379 IF (ITUNE.EQ.324) PARP(80)=0.01
61382 C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
61385 IF (ITUNEB.EQ.304) PARP(79)=3D0
61386 IF (ITUNE.EQ.329) PARP(79)=1.18
61388 C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
61392 C...Perugia-HARD only uses 1.0 GeV
61393 IF (ITUNE.EQ.321) PARP(91)=1.0D0
61394 C...Perugia-3 only uses 1.5 GeV
61395 IF (ITUNE.EQ.323) PARP(91)=1.5D0
61396 C...Professor-pT0 uses 7-GeV cutoff
61397 IF (ITUNE.EQ.329) PARP(93)=7.0
61399 C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
61401 C...S1, S1-Pro: use S1
61402 IF (ITUNEB.EQ.301) MSTP(95)=2
61403 C...S2, S2-Pro: use S2
61404 IF (ITUNEB.EQ.302) MSTP(95)=4
61405 C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
61406 IF (ITUNE.EQ.304.OR.ITUNE.EQ.314.OR.ITUNE.EQ.324) MSTP(95)=0
61407 C..."Old" and "Old"-Pro: use old CR
61408 IF (ITUNEB.EQ.305) MSTP(95)=1
61410 C...FSI: CR strength and high-pT dampening, default is S0
61411 IF (ITUNE.LT.320.OR.ITUNE.EQ.329) THEN
61414 IF (ITUNEB.EQ.301) PARP(78)=0.35D0
61415 IF (ITUNEB.EQ.302) PARP(78)=0.15D0
61416 IF (ITUNEB.EQ.304) PARP(78)=0.0D0
61417 IF (ITUNEB.EQ.305) PARP(78)=1.0D0
61418 IF (ITUNE.EQ.329) PARP(78)=0.17D0
61420 C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
61423 IF (ITUNE.EQ.321) THEN
61424 C...HARD has HIGH amount of CR
61427 ELSEIF (ITUNE.EQ.322) THEN
61428 C...SOFT has LOW amount of CR
61431 ELSEIF (ITUNE.EQ.323) THEN
61432 C...Scaling variant appears to need slightly more than default
61435 ELSEIF (ITUNE.EQ.324) THEN
61442 C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
61443 IF (ITUNE.EQ.321) PARJ(21)=0.34D0
61444 IF (ITUNE.EQ.322) PARJ(21)=0.28D0
61446 C...Switch off trial joinings
61449 C...S0 (300), S0A (303)
61450 IF (ITUNEB.EQ.300.OR.ITUNEB.EQ.303) THEN
61452 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
61453 WRITE(M11,5030) CH60
61454 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
61455 WRITE(M11,5030) CH60
61456 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61457 WRITE(M11,5030) CH60
61458 IF (ITUNE.GE.310) THEN
61459 CH60='LEP parameters tuned by Professor'
61460 WRITE(M11,5030) CH60
61465 ELSEIF(ITUNEB.EQ.301) THEN
61467 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61468 WRITE(M11,5030) CH60
61469 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61470 WRITE(M11,5030) CH60
61471 IF (ITUNE.GE.310) THEN
61472 CH60='LEP parameters tuned with Professor'
61473 WRITE(M11,5030) CH60
61478 ELSEIF(ITUNEB.EQ.302) THEN
61480 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61481 WRITE(M11,5030) CH60
61482 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61483 WRITE(M11,5030) CH60
61484 IF (ITUNE.GE.310) THEN
61485 CH60='LEP parameters tuned by Professor'
61486 WRITE(M11,5030) CH60
61491 ELSEIF(ITUNEB.EQ.304) THEN
61493 CH60='"best try" without colour reconnections'
61494 WRITE(M11,5030) CH60
61495 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
61496 WRITE(M11,5030) CH60
61497 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61498 WRITE(M11,5030) CH60
61499 IF (ITUNE.GE.310) THEN
61500 CH60='LEP parameters tuned by Professor'
61501 WRITE(M11,5030) CH60
61505 C..."Lo FSR" retune (305)
61506 ELSEIF(ITUNEB.EQ.305) THEN
61508 CH60='"Lo FSR retune" with primitive colour reconnections'
61509 WRITE(M11,5030) CH60
61510 CH60='see T. Sjostrand & P. Skands, hep-ph/0408302'
61511 WRITE(M11,5030) CH60
61512 IF (ITUNE.GE.310) THEN
61513 CH60='LEP parameters tuned by Professor'
61514 WRITE(M11,5030) CH60
61518 C...Perugia Tunes (320-326)
61519 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61521 CH60='P. Skands, Perugia MPI workshop October 2008'
61522 WRITE(M11,5030) CH60
61523 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61524 WRITE(M11,5030) CH60
61525 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
61526 WRITE(M11,5030) CH60
61527 CH60='LEP parameters tuned by Professor'
61528 WRITE(M11,5030) CH60
61529 IF (ITUNE.EQ.325) THEN
61530 CH70='NB! This tune requires MRST LO* pdfs to be '//
61531 & 'externally linked'
61532 WRITE(M11,5035) CH70
61533 ELSEIF (ITUNE.EQ.326) THEN
61534 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
61535 & 'externally linked'
61536 WRITE(M11,5035) CH70
61537 ELSEIF (ITUNE.EQ.321) THEN
61538 CH60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
61539 WRITE(M11,5030) CH60
61540 ELSEIF (ITUNE.EQ.322) THEN
61541 CH60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
61542 WRITE(M11,5030) CH60
61546 C...Professor-pT0 (329)
61547 ELSEIF(ITUNE.EQ.329) THEN
61549 CH60='See T. Sjostrand & P. Skands, hep-ph/0408302'
61550 WRITE(M11,5030) CH60
61551 CH60='and M. Sandhoff & P. Skands, in hep-ph/0604120'
61552 WRITE(M11,5030) CH60
61553 CH60='LEP/Tevatron parameters tuned by Professor'
61554 WRITE(M11,5030) CH60
61561 WRITE(M11,5030) ' '
61562 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
61563 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
61564 IF (MSTP(70).EQ.0) THEN
61565 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
61566 ELSEIF (MSTP(70).EQ.1) THEN
61567 WRITE(M11,5050) 81, PARP(81), CHPARP(62)
61568 CH60='(Note: PARP(81) replaces PARP(62).)'
61569 WRITE(M11,5030) CH60
61571 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
61572 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
61573 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
61574 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
61575 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
61576 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61577 WRITE(M11,5030) CH60
61578 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
61579 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
61580 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
61581 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
61582 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
61583 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
61584 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
61585 IF (MSTP(70).EQ.2) THEN
61586 CH60='(Note: PARP(82) replaces PARP(62).)'
61587 WRITE(M11,5030) CH60
61589 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
61590 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
61591 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
61592 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
61593 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
61594 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
61595 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
61596 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
61597 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
61598 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
61599 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
61600 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
61601 IF (MSTP(95).GE.1) THEN
61602 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
61603 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
61605 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
61606 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
61607 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
61608 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
61609 IF (MSTJ(11).LE.3) THEN
61610 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
61611 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
61613 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
61615 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
61618 C=======================================================================
61619 C...ATLAS-CSC 11-parameter tune (By A. Moraes)
61620 ELSEIF (ITUNE.EQ.306) THEN
61621 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
61622 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
61623 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61634 C...UE on, new model.
61639 C...Switch off trial joinings
61641 C...Primordial kT cutoff
61644 CH60='see presentations by A. Moraes (ATLAS),'
61645 WRITE(M11,5030) CH60
61646 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61647 WRITE(M11,5030) CH60
61648 WRITE(M11,5030) ' '
61649 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
61650 & 'externally linked'
61651 WRITE(M11,5035) CH70
61653 C...Smooth ISR, low FSR
61658 C...Transverse density profile.
61662 C...ISR & FSR in interactions after the first (default)
61665 C...No double-counting (default)
61667 C...Companion quark parent gluon (1-x) power
61669 C...Primordial kT compensation along chaings (default = 0 : uniform)
61671 C...Colour Reconnections
61674 C...Lambda_FSR scale.
61676 C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
61681 C...Peterson charm frag, and c and b hadr parameters
61687 WRITE(M11,5030) ' '
61688 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
61689 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
61690 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
61691 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
61692 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61693 WRITE(M11,5030) CH60
61694 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
61695 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
61696 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
61697 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
61698 CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
61699 WRITE(M11,5030) CH60
61700 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
61701 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
61702 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
61703 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
61704 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
61705 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
61706 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
61707 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
61708 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
61709 WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
61710 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
61711 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
61712 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
61713 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
61714 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
61715 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
61716 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
61717 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
61718 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
61719 IF (MSTJ(11).LE.3) THEN
61720 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
61721 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
61723 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
61725 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
61728 C=======================================================================
61729 C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
61730 C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
61731 C...A-Pro, DW-Pro, etc (100-119), and Pro-Q20 (129)
61732 ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
61733 & ITUNE.EQ.109.OR.(ITUNE.GE.110.AND.ITUNE.LE.116).OR.
61734 & ITUNE.EQ.118.OR.ITUNE.EQ.119.OR.ITUNE.EQ.129) THEN
61735 IF (M13.GE.1.AND.ITUNE.NE.106.AND.ITUNE.NE.129) THEN
61736 WRITE(M11,5010) ITUNE, CHNAME
61737 CH60='see R.D. Field, in hep-ph/0610012'
61738 WRITE(M11,5030) CH60
61739 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61740 WRITE(M11,5030) CH60
61741 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
61742 CH60='LEP parameters tuned by Professor'
61743 WRITE(M11,5030) CH60
61745 ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN
61746 WRITE(M11,5010) ITUNE, CHNAME
61747 CH60='See T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61748 WRITE(M11,5030) CH60
61749 CH60='LEP/Tevatron parameters tuned by Professor'
61750 WRITE(M11,5030) CH60
61753 C...Make sure we start from old default fragmentation parameters
61757 C...Use Professor's LEP pars if ITUNE >= 110
61758 C...(i.e., for A-Pro, DW-Pro etc)
61759 IF (ITUNE.LT.110) THEN
61762 C...# Old default flavour parameters
61769 C...# Tuned flavour parameters:
61779 C...# Switch on Bowler:
61781 C...# Fragmentation
61790 C...Remove middle digit now for Professor variants, since identical pars
61792 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
61793 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
61796 C...Multiple interactions on, old framework
61798 C...Fast IR cutoff energy scaling by default
61801 C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
61804 IF (ITUNEB.EQ.105) THEN
61807 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
61813 C...Double Gaussian matter distribution.
61819 C...Fragmentation functions and c and b parameters
61820 C...(only if not using Professor)
61821 IF (ITUNE.LE.109) THEN
61828 IF(ITUNEB.EQ.100.OR.ITUNEB.EQ.101) THEN
61831 c...String drawing almost completely minimizes string length.
61834 C...ISR cutoff, muR scale factor, and phase space size
61838 C...Intrinsic kT, size, and max
61842 C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
61843 IF (ITUNEB.EQ.101) THEN
61850 C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
61851 ELSEIF (ITUNEB.EQ.102) THEN
61854 c...String drawing completely minimizes string length.
61857 C...ISR cutoff, muR scale factor, and phase space size
61861 C...Intrinsic kT, size, and max
61867 ELSEIF (ITUNEB.EQ.103) THEN
61870 c...String drawing completely minimizes string length.
61873 C...ISR cutoff, muR scale factor, and phase space size
61877 C...Intrinsic kT, size, and max
61883 ELSEIF (ITUNEB.EQ.104) THEN
61886 C...Run II ref scale and slow scaling
61889 c...String drawing completely minimizes string length.
61892 C...ISR cutoff, muR scale factor, and phase space size
61896 C...Intrinsic kT, size, and max
61902 ELSEIF(ITUNEB.EQ.105) THEN
61904 WRITE(M11,5030) ' '
61905 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
61906 & 'externally linked'
61907 WRITE(M11,5035) CH70
61911 c...String drawing completely minimizes string length.
61914 C...ISR cutoff, muR scale factor, and phase space size
61918 C...Intrinsic kT, size, and max
61923 C...Tune D6 and D6T
61924 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
61926 WRITE(M11,5030) ' '
61927 CH70='NB! This tune requires CTEQ6L pdfs to be '//
61928 & 'externally linked'
61929 WRITE(M11,5035) CH70
61931 C...The "Rick" proton, double gauss with 0.5/0.4
61935 c...String drawing completely minimizes string length.
61938 IF (ITUNEB.EQ.108) THEN
61939 C...D6: pT0, Run I ref scale, and fast energy scaling
61944 C...D6T: pT0, Run II ref scale, and slow energy scaling
61949 C...ISR cutoff, muR scale factor, and phase space size
61953 C...Intrinsic kT, size, and max
61958 C...Old ATLAS-DC2 5-parameter tune
61959 ELSEIF(ITUNEB.EQ.106) THEN
61961 WRITE(M11,5010) ITUNE, CHNAME
61962 CH60='see A. Moraes et al., SN-ATLAS-2006-057,'
61963 WRITE(M11,5030) CH60
61964 CH60=' R. Field in hep-ph/0610012,'
61965 WRITE(M11,5030) CH60
61966 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61967 WRITE(M11,5030) CH60
61971 C... Different ref and rescaling pacee
61974 C... Parameters of mass distribution
61977 C... Old default string drawing
61980 C... ISR, phase space equivalent to Tune B
61991 C...Professor's Pro-Q20 Tune
61992 ELSEIF(ITUNE.EQ.129) THEN
61994 CH60='see H. Hoeth, Perugia MPI workshop, Oct 2008'
61995 WRITE(M11,5030) CH60
62015 WRITE(M11,5030) ' '
62016 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62017 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62018 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62019 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62020 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62021 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62022 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62023 WRITE(M11,5030) CH60
62024 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62025 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62026 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62027 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62028 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62029 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62030 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62031 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62032 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62033 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62034 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62035 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62036 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62037 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62038 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62039 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62040 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62041 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62042 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62043 IF (MSTJ(11).LE.3) THEN
62044 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62045 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62047 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62049 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62052 C=======================================================================
62053 C... ACR, tune A with new CR (107)
62054 ELSEIF(ITUNE.EQ.107.OR.ITUNE.EQ.117) THEN
62056 WRITE(M11,5010) ITUNE, CHNAME
62057 CH60='Tune A modified with new colour reconnections'
62058 WRITE(M11,5030) CH60
62059 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
62060 WRITE(M11,5030) CH60
62061 CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
62062 WRITE(M11,5030) CH60
62063 CH60=' R. Field, in hep-ph/0610012 (Tune A),'
62064 WRITE(M11,5030) CH60
62065 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62066 WRITE(M11,5030) CH60
62067 IF (ITUNE.EQ.117) THEN
62068 CH60='LEP parameters tuned by Professor'
62069 WRITE(M11,5030) CH60
62072 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
62073 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62074 & ' with tune. Using defaults.')
62078 C...Make sure we start from old default fragmentation parameters
62082 C...Use Professor's LEP pars if ITUNE >= 110
62083 C...(i.e., for A-Pro, DW-Pro etc)
62084 IF (ITUNE.LT.110) THEN
62087 C...# Old default flavour parameters
62094 C...# Tuned flavour parameters:
62104 C...# Switch on Bowler:
62106 C...# Fragmentation
62134 C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
62136 C...Frag functions (only if not using Professor)
62137 IF (ITUNE.LE.109) THEN
62145 WRITE(M11,5030) ' '
62146 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62147 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62148 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62149 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62150 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62151 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62152 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62153 WRITE(M11,5030) CH60
62154 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62155 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62156 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62157 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62158 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62159 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62160 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62161 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62162 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62163 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62164 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62165 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62166 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62167 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62168 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62169 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62170 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62171 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62172 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62173 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62174 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62175 IF (MSTJ(11).LE.3) THEN
62176 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62177 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62179 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62181 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62184 C=======================================================================
62185 C...Intermediate model. Rap tune
62186 C...(retuned to post-6.406 IR factorization)
62187 ELSEIF(ITUNE.EQ.200) THEN
62189 WRITE(M11,5010) ITUNE, CHNAME
62190 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
62191 WRITE(M11,5030) CH60
62193 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62194 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62212 C... ExpOfPow(1.8) overlap profile
62219 C... Default diquark, BR-g-BR supp
62222 C... Final state reconnect.
62225 C...Fragmentation functions and c and b parameters
62231 WRITE(M11,5030) ' '
62232 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62233 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62234 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62235 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62236 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62237 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62238 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62239 WRITE(M11,5030) CH60
62240 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62241 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62242 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62243 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62244 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62245 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62246 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62247 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62248 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
62249 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
62250 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
62251 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
62252 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62253 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62254 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62255 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62256 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62257 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62258 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62259 IF (MSTJ(11).LE.3) THEN
62260 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62261 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62263 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62265 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62268 C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
62269 C...Old model for ISR and UE, new pT-ordered model for FSR
62270 ELSEIF(ITUNE.EQ.201.OR.ITUNE.EQ.211.OR.ITUNE.EQ.221.OR
62271 & .ITUNE.EQ.226) THEN
62273 WRITE(M11,5010) ITUNE, CHNAME
62274 CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
62275 WRITE(M11,5030) CH60
62276 CH60=' R.D. Field, in hep-ph/0610012 (Tune A)'
62277 WRITE(M11,5030) CH60
62278 CH60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62279 WRITE(M11,5030) CH60
62280 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
62281 WRITE(M11,5030) CH60
62282 IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN
62283 CH60='LEP parameters tuned by Professor'
62284 WRITE(M11,5030) CH60
62287 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
62288 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62291 C...First set as if Pythia tune A
62292 C...Multiple interactions on, old framework
62294 C...Fast IR cutoff energy scaling by default
62297 C...Default CTEQ5L (internal)
62300 C...Double Gaussian matter distribution.
62306 c...String drawing almost completely minimizes string length.
62309 C...ISR cutoff, muR scale factor, and phase space size
62313 C...Intrinsic kT, size, and max
62317 C...Use 2 GeV of primordial kT for "Perugia" version
62318 IF (ITUNE.EQ.221) THEN
62322 C...Use pT-ordered FSR
62324 C...Lambda_FSR scale for pT-ordering
62326 C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
62328 C...Fragmentation functions and c and b parameters
62329 C...(overwritten for 211, i.e., if using Professor pars)
62333 C...Use Professor's LEP pars if ITUNE == 211, 221, 226
62334 IF (ITUNE.LT.210) THEN
62337 C...# Old default flavour parameters
62344 C...# Tuned flavour parameters:
62354 C...# Always use pT-ordered shower:
62356 C...# Switch on Bowler:
62358 C...# Fragmentation
62359 PARJ(21) = 3.1327e-01
62360 PARJ(41) = 4.8989e-01
62361 PARJ(42) = 1.2018e+00
62362 PARJ(47) = 1.0000e+00
62363 PARJ(81) = 2.5696e-01
62364 PARJ(82) = 8.0000e-01
62367 C...221, 226 : Perugia-APT and Perugia-APT6
62368 IF (ITUNE.EQ.221.OR.ITUNE.EQ.226) THEN
62374 C...The Perugia variants use Steve's showers off the old MPI
62376 C...And use a lower PARP(71) as suggested by Professor tunings
62377 C...(although not certain that applies to Q2-pT2 hybrid)
62380 C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
62381 IF (ITUNE.EQ.226) THEN
62382 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
62383 & 'externally linked'
62384 WRITE(M11,5035) CH70
62394 WRITE(M11,5030) ' '
62395 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62396 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62397 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62398 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62399 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62400 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62401 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62402 WRITE(M11,5030) CH60
62403 WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
62404 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62405 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62406 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62407 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62408 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62409 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62410 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62411 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62412 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62413 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62414 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62415 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62416 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62417 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62418 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62419 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62420 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62421 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62422 IF (MSTJ(11).LE.3) THEN
62423 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62424 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62426 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62428 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62431 C======================================================================
62432 C...Uppsala models: Generalized Area Law and Soft Colour Interactions
62433 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
62435 WRITE(M11,5010) ITUNE, CHNAME
62436 CH60='see J. Rathsman, PLB452(1999)364'
62437 WRITE(M11,5030) CH60
62438 C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
62439 C ? WRITE(M11,5030)
62440 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62441 WRITE(M11,5030) CH60
62442 WRITE(M11,5030) ' '
62443 CH70='NB! The GAL model must be run with modified '//
62445 WRITE(M11,5035) CH70
62446 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
62447 WRITE(M11,5035) CH70
62448 WRITE(M11,5030) ' '
62450 C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
62463 IF(CHNAME.EQ.'GAL Tune 1') THEN
62464 C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
62470 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62471 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62472 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62473 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62474 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62478 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62479 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
62480 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62485 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62486 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62487 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
62488 CH40='FSI SCI/GAL selection'
62489 WRITE(M11,6040) 1, MSWI(1), CH40
62490 CH40='FSI SCI/GAL sea quark treatment'
62491 WRITE(M11,6040) 2, MSWI(2), CH40
62492 CH40='FSI SCI/GAL sea quark treatment parm'
62493 WRITE(M11,6050) 1, PARSCI(1), CH40
62494 CH40='FSI SCI/GAL string reco probability R_0'
62495 WRITE(M11,6050) 2, PARSCI(2), CH40
62496 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62497 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
62499 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
62501 WRITE(M11,5010) ITUNE, CHNAME
62502 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
62503 WRITE(M11,5030) CH60
62504 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62505 WRITE(M11,5030) CH60
62506 WRITE(M11,5030) ' '
62507 CH70='NB! The SCI model must be run with modified '//
62509 WRITE(M11,5035) CH70
62510 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
62511 WRITE(M11,5035) CH70
62512 WRITE(M11,5030) ' '
62514 C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
62524 IF (CHNAME.EQ.'SCI Tune 1') THEN
62525 C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
62533 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62534 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62535 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62536 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62537 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62541 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62542 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
62543 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62548 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
62549 CH40='FSI SCI/GAL selection'
62550 WRITE(M11,6040) 1, MSWI(1), CH40
62551 CH40='FSI SCI/GAL sea quark treatment'
62552 WRITE(M11,6040) 2, MSWI(2), CH40
62553 CH40='FSI SCI/GAL sea quark treatment parm'
62554 WRITE(M11,6050) 1, PARSCI(1), CH40
62555 CH40='FSI SCI/GAL string reco probability R_0'
62556 WRITE(M11,6050) 2, PARSCI(2), CH40
62557 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
62561 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
62565 100 IF (MSTU(13).GE.1) WRITE(M11,6000)
62569 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
62570 & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
62571 & 20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
62572 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
62573 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
62574 5030 FORMAT(' *',3x,10x,A60,3x,'*')
62575 5035 FORMAT(' *',3x,A70,3x,'*')
62576 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
62577 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
62578 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
62579 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
62580 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
62581 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
62582 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
62583 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
62584 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
62588 C*********************************************************************
62591 C...Administrates the fragmentation and decay chain.
62595 C...Double precision and integer declarations.
62596 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62597 IMPLICIT INTEGER(I-N)
62598 INTEGER PYK,PYCHGE,PYCOMP
62600 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62601 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62602 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62603 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62604 COMMON/PYINT1/MINT(400),VINT(400)
62605 COMMON/PYINT4/MWID(500),WIDS(500,5)
62606 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
62608 DIMENSION PS(2,6),IJOIN(100)
62610 C...Initialize and reset.
62612 IF(MSTU(12).NE.12345) CALL PYLIST(0)
62614 MSTU(31)=MSTU(31)+1
62618 IF(MSTU(17).LE.0) MSTU(90)=0
62621 C...Sum up momentum, energy and charge for starting entries.
62629 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
62631 PS(1,J)=PS(1,J)+P(I,J)
62633 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
62637 C...Start by all decays of coloured resonances involved in shower.
62640 IF(K(I,1).EQ.3) THEN
62642 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
62646 C...Prepare system for subsequent fragmentation/decay.
62648 IF(MINT(51).NE.0) RETURN
62650 C...Loop through jet fragmentation and particle decays.
62656 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
62659 C...Deal with any remaining undecayed resonance
62660 C...(normally the task of PYEVNT, so seldom used).
62661 ELSEIF(MWID(KC).NE.0) THEN
62663 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
62666 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
62667 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
62670 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
62671 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
62674 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
62682 IF(MINT(51).NE.0) RETURN
62684 C...Particle decay if unstable and allowed. Save long-lived particle
62685 C...decays until second pass after Bose-Einstein effects.
62686 ELSEIF(KCHG(KC,2).EQ.0) THEN
62687 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
62688 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
62691 C...Decay products may develop a shower.
62692 IF(MSTJ(92).GT.0) THEN
62694 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
62695 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
62697 CALL PYSHOW(IP1,IP1+1,QMAX)
62699 IF(MINT(51).NE.0) RETURN
62701 ELSEIF(MSTJ(92).LT.0) THEN
62704 CALL PYSHOW(IP1,-3,P(IP,5))
62706 IF(MINT(51).NE.0) RETURN
62710 C...Jet fragmentation: string or independent fragmentation.
62711 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
62713 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
62714 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
62715 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
62716 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
62717 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
62720 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
62721 IF(MFRAG.EQ.2) CALL PYINDF(IP)
62722 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
62723 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
62726 C...Loop back if enough space left in PYJETS and no error abort.
62727 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
62728 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
62730 ELSEIF(IP.LT.N) THEN
62731 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
62734 C...Include simple Bose-Einstein effect parametrization if desired.
62735 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
62740 C...Check that momentum, energy and charge were conserved.
62742 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
62744 PS(2,J)=PS(2,J)+P(I,J)
62746 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
62748 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
62749 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
62750 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
62751 &'(PYEXEC:) four-momentum was not conserved')
62752 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
62753 &'(PYEXEC:) charge was not conserved')
62758 C*********************************************************************
62761 C...Rearranges partons along strings.
62762 C...Special considerations for systems with junctions, with
62763 C...possibility of junction-antijunction annihilation.
62764 C...Allows small systems to collapse into one or two particles.
62765 C...Checks flavours and colour singlet invariant masses.
62767 SUBROUTINE PYPREP(IP)
62769 C...Double precision and integer declarations.
62770 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62771 INTEGER PYK,PYCHGE,PYCOMP
62773 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62774 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62775 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
62776 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62777 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62778 COMMON/PYINT1/MINT(400),VINT(400)
62779 C...The common block of colour tags.
62780 COMMON/PYCTAG/NCT,MCT(4000,2)
62781 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
62786 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
62787 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
62788 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
62789 &IJCP(0:6),TJUOLD(5)
62792 C...Function to give four-product.
62793 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)
62795 C...Rearrange parton shower product listing along strings: begin loop.
62803 DO 100 I=MAX(1,IP),N
62804 C...First store junction positions.
62805 IF(K(I,1).EQ.42) THEN
62813 DO 240 I=MAX(1,IP),N
62814 C...Special treatment for junctions
62815 IF (K(I,1).LE.0) GOTO 240
62816 IF(K(I,1).EQ.42) THEN
62817 C...MQGST=2: Look for junction-junction strings (not detected in the
62818 C...main search below).
62819 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
62820 IF (NJJSTR.EQ.0) THEN
62821 NJJSTR = (3*NJUNC-NPIECE)/2
62823 C...Check how many already identified strings end on this junction
62826 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
62828 C...If less than 3, remaining must be to another junction
62831 C...Multiple j-j connections not handled yet.
62833 & '(PYPREP:) Too many junction-junction strings.')
62837 C...The colour information in the junction is unreadable for the
62838 C...colour space search further down in this routine, so we must
62839 C...start on the colour mother of this junction and then "artificially"
62840 C...prevent the colour mother from connecting here again.
62841 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
62843 IF (MOD(ITJUNC,2).EQ.0) KCS=5
62844 C...Switch colour if the junction-junction leg is presumably a
62845 C...junction mother leg rather than a junction daughter leg.
62846 IF (ITJUNC.GE.3) KCS=9-KCS
62847 IF (MINT(33).EQ.0) THEN
62848 C...Find the unconnected leg and reorder junction daughter pointers so
62849 C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
62851 IA=MOD(K(I,4),MSTU(5))
62852 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
62853 ITMP=MOD(K(I,5),MSTU(5))
62854 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
62855 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
62856 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
62858 K(I,5)=K(I,5)+(IA-ITMP)
62860 K(I,4)=K(I,4)+(ITMP-IA)
62863 IF (ITJUNC.LE.2) THEN
62864 C...Beam baryon junction
62865 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
62866 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
62867 C...Else 1 -> 2 decay junction
62869 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
62870 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
62875 C...Alternatively use colour tag information.
62877 C...Find a final state parton with appropriate dangling colour tag.
62881 DO 140 J1=MAX(1,IP),N
62882 IF (K(J1,1).NE.3) GOTO 140
62883 C...Check for matching final-state colour tag
62885 DO 120 J2=MAX(1,IP),N
62886 IF (K(J2,1).NE.3) GOTO 120
62887 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
62889 IF (IMATCH.EQ.1) GOTO 140
62890 C...Check whether this colour tag belongs to the present junction
62891 C...by seeing whether any parton with this colour tag has the same
62892 C...mother as the junction.
62895 DO 130 J2=MINT(84)+1,N
62897 C...First scattering partons have IMO1 = 3 and 4.
62898 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
62900 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
62903 IF (IMATCH.EQ.0) GOTO 140
62906 C...Check for junction-junction strings without intermediate final state
62907 C...glue (not detected above).
62911 IF (IJU2.EQ.I) GOTO 160
62912 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
62913 C...Only opposite types of junctions can connect to each other.
62914 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
62917 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
62919 IF (IS.EQ.3) GOTO 160
62924 C...Switch to other side of adjacent parton and step from there.
62930 ELSE IF (ILC.NE.3) THEN
62935 C...Look for coloured string endpoint, or (later) leftover gluon.
62936 IF(K(I,1).NE.3) GOTO 240
62938 IF(KC.EQ.0) GOTO 240
62940 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
62942 C...Pick up loose string end.
62944 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
62950 IF(NSTP.GT.4*N) THEN
62951 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
62956 C...Copy undecayed parton. Finished if reached string endpoint.
62957 IF(K(IA,1).EQ.3) THEN
62958 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
62959 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
62966 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
62976 IF(K(I1,1).EQ.1) GOTO 240
62979 C...Also finished (for now) if reached junction; then copy to end.
62980 IF(K(IA,1).EQ.42) THEN
62982 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
62983 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
62988 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
62989 DO 200 ICOPY=1,NCOPY
62991 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
62992 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
62993 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
62997 C...For junction-junction strings, find end leg and reorder junction
62998 C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
62999 C...junction-junction string piece.
63000 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
63001 ITMP=MOD(K(IA,4),MSTU(5))
63002 IF (ITMP.NE.IB) THEN
63003 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
63004 K(IA,5)=K(IA,5)+(ITMP-IB)
63006 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
63008 K(IA,4)=K(IA,4)+(IB-ITMP)
63013 C...0: endpoint in original ER
63016 C...3: Parton immediately next to junction
63019 IPIECE(NPIECE,1)=MSTU32+1
63020 IPIECE(NPIECE,2)=MSTU32+NCOPY
63021 IPIECE(NPIECE,3)=IB
63022 IPIECE(NPIECE,4)=IA
63023 MSTU32=MSTU32+NCOPY
63028 C...GOTO next parton in colour space.
63030 IF (MINT(33).EQ.0) THEN
63031 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
63033 IA=MOD(K(IB,KCS),MSTU(5))
63034 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
63037 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
63038 & MSTU(5)).EQ.0) KCS=9-KCS
63039 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
63040 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
63043 IF(IA.LE.0.OR.IA.GT.N) THEN
63044 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
63045 IF(NERRPR.LT.5) THEN
63047 WRITE(MSTU(11),*) 'started at:', I
63048 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
63049 WRITE(MSTU(11),*) 'MQGST =',MQGST
63055 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
63056 & ,MSTU(5)).EQ.IB) THEN
63057 IF(MREV.EQ.1) KCS=9-KCS
63058 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
63059 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
63061 IF(MREV.EQ.0) KCS=9-KCS
63062 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
63063 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
63065 IF(IA.NE.I) GOTO 170
63066 C...Use colour tag information
63068 C...First create colour tags starting on IB if none already present.
63069 IF (MCT(IB,KCS-3).EQ.0) THEN
63070 CALL PYCTTR(IB,KCS,IB)
63071 IF(MINT(51).NE.0) RETURN
63075 C...Find final state tag partner
63076 DO 210 IT=MAX(1,IP),N
63077 IF (IT.EQ.IB) GOTO 210
63078 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
63084 C...Just copy and goto next if exactly one partner found.
63085 IF (IFOUND.EQ.1) THEN
63087 C...When no match found, match is presumably junction.
63088 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
63089 C...Check whether this colour tag matches a junction
63090 C...by seeing whether any parton with this colour tag has the same
63091 C...mother as a junction.
63092 C...NB: Only type 1 and 2 junctions handled presently.
63094 IJUMO=K(IJUNC(IJU,0),3)
63095 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
63096 C...Colours only connect to junctions, anti-colours to antijunctions:
63097 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
63099 DO 220 J1=MAX(1,IP),N
63100 IF (K(J1,1).LE.0) GOTO 220
63101 C...First scattering partons have IMO1 = 3 and 4.
63103 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
63105 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
63106 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
63108 C...Attempt at handling type > 3 junctions also. Not tested.
63109 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
63112 IF (IMATCH.EQ.0) GOTO 230
63117 IF (IFOUND.EQ.1) THEN
63119 ELSEIF (IFOUND.EQ.0) THEN
63121 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
63123 IF(NERRPR.LT.5) THEN
63130 ELSEIF (IFOUND.GE.2) THEN
63133 & ,'(PYPREP:) too many occurences of colour line: '//
63135 IF(NERRPR.LT.5) THEN
63147 C...Junction systems remain.
63153 260 IJUCNT=IJUCNT+1
63154 IF (IJUCNT.LE.NJUNC) THEN
63155 C...If we are not processing a j-j string, treat this junction as new.
63156 IF (IJJSTR.EQ.0) THEN
63157 IJU=IJUNC(IJUCNT,0)
63159 C...If junction has already been read, ignore it.
63160 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
63161 C...If we are on a j-j string, goto second j-j junction.
63166 C...Mark selected junction read.
63168 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
63170 C...Determine junction type
63171 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
63172 C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
63173 C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
63174 C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
63175 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
63178 C...Find which quarks belong to given junction.
63180 DO 290 IPC=1,NPIECE
63181 IF (IPIECE(IPC,4).EQ.IJU) THEN
63183 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
63185 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
63187 C...IHK = 3 is special. Either normal string piece, or j-j string.
63189 IF (MREV.NE.1) THEN
63190 DO 300 IPC=1,NPIECE
63191 C...If there is a j-j string starting on the present junction which has
63192 C...zero length, insert next junction immediately.
63193 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
63194 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
63200 C...If MREV is 1 and IHK is 3 we are finished with this system.
63207 C...If we've gotten this far, then either IHK < 3, or
63208 C...an interjunction string exists, or just a third normal string.
63209 IJUNC(IJUCNT,IHK)=0
63211 C..Order pieces belonging to this junction. Also look for j-j.
63212 DO 310 IPC=1,NPIECE
63213 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
63214 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
63215 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
63216 IJUNC(IJUCNT,IHK)=IPC
63221 C...Copy back chains in proper order. MREV=0/1 : descending/ascending
63222 IPC=IJUNC(IJUCNT,IHK)
63223 C...Temporary solution to cover for bug.
63225 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
63229 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
63232 K(I1,J)=K(MSTU(4)-ICP,J)
63233 P(I1,J)=P(MSTU(4)-ICP,J)
63234 V(I1,J)=V(MSTU(4)-ICP,J)
63238 C...Mark last quark.
63239 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
63240 C...Do not insert junctions at wrong places.
63241 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
63242 C...Insert junction.
63245 C...Shift to end junction if a j-j string has been processed.
63246 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
63256 K(IJUS,1)=K(IJUS,1)+10
63259 360 IF (IHK.LT.3) GOTO 280
63261 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
63265 IF (IJUCNT.NE.NJUNC) GOTO 260
63269 C...Rearrange three strings from junction, e.g. in case one has been
63270 C...shortened by shower, so the last is the largest-energy one.
63271 IF(NJUNC.GE.1) THEN
63272 C...Find systems with exactly one junction.
63276 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
63277 ELSEIF(K(I,1).EQ.41) THEN
63279 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
63284 C...Sum up energy-momentum in each junction string.
63291 DO 390 I1=NBEG,NEND
63292 IF(K(I1,2).NE.21) THEN
63297 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
63300 C...Find which of them has highest energy (minus mass) in rest frame.
63302 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
63304 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
63307 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
63308 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
63310 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
63311 C...Decide how to rearrange so that new last has highest energy.
63312 IF(PJU(1,6).LT.PJU(2,6)) THEN
63314 IRNG(1,2)=IJUR(2)-1
63316 IRNG(2,2)=IJUR(3)+1
63317 IRNG(4,1)=IJUR(3)-1
63321 IRNG(1,2)=IJUR(3)+1
63323 IRNG(2,2)=IJUR(3)-1
63324 IRNG(4,1)=IJUR(2)-1
63329 C...Copy in correct order below bottom of current event record.
63332 DO 430 I1=IRNG(II,1),IRNG(II,2),
63333 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
63335 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
63337 & '(PYPREP:) no more memory left in PYJETS')
63347 IF(K(I2,1).EQ.1) K(I2,1)=2
63351 C...Copy back up, overwriting but now in correct order.
63352 DO 460 I1=NBEG,NEND
63366 C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
63367 C...to two q-qbar systems.
63368 C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
63369 IF (MSTJ(19).NE.1) THEN
63373 C...Force collapse when MSTJ(19)=2.
63374 IF (MSTJ(19).EQ.2) THEN
63378 C...Find systems with exactly two junctions.
63380 C...Count junctions
63381 IF (K(I,1).EQ.41) THEN
63383 C...Check for interjunction gluons
63384 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
63387 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
63388 C...If end of system reached with either zero or one junction, restart
63389 C...with next system.
63393 ELSEIF(K(I,1).EQ.1) THEN
63394 C...If end of system reached with exactly two junctions, compute string
63395 C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
63396 C...length measure for the (q-qbar)(q-qbar) topology.
63398 C...Loop down through chain.
63400 DO 480 I1=NBEG,NEND
63401 C...Store string piece division locations in event record
63402 IF (K(I1,2).NE.21) THEN
63407 C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
63409 IF (PYR(0).LT.0.5D0) ISW=1
63410 C...Randomly choose which qqbar string gets the jj gluons.
63412 IF (PYR(0).GT.0.5D0) IGS=2
63413 C...Only compute string lengths when no topology forced.
63414 IF (MSTJ(19).EQ.0) THEN
63415 C...Repeat following for each junction
63417 C...Initialize iterative procedure for finding JRF
63423 C...Start iteration. Sum up momenta in string pieces
63425 C...JD=-1 for first junction, +1 for second junction.
63426 C...Find out where piece starts and ends and which direction to go.
63429 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
63430 IB = IJCP((IJU-1)*7 - JD*IJS)
63431 ELSEIF (IJS.EQ.3) THEN
63433 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
63434 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
63436 C...Initialize junction pull 4-vector.
63440 C...Initialize weight
63443 C...Sum up (weighted) momenta along each string piece
63444 DO 530 ISP=IA,IB,JD
63445 C...If present parton not last in chain
63446 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
63447 C...If last parton was a junction, store present weight
63448 IF (K(ISP-JD,2).EQ.88) THEN
63450 C...If last parton was a quark, reset to stored weight.
63451 ELSEIF (K(ISP-JD,2).NE.21) THEN
63455 C...Skip next parton if weight already large
63456 IF (PWT.GT.10D0) GOTO 530
63457 C...Compute momentum in TJUOLD frame:
63458 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
63460 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
63462 TMP=P(ISP,J)+TJUOLD(J)*BFC
63463 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
63466 TMP=TJUOLD(4)*P(ISP,4)+TDP
63467 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
63469 PWT=PWT+TMP/PARJ(48)
63470 C...Put |p| rather than m in 5th slot
63471 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
63478 C...Combine new boost (T) with old boost (TJUOLD)
63479 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
63481 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
63484 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
63486 C...If last boost small, accept JRF, else iterate.
63487 C...Also prevent possibility of infinite loop.
63488 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
63489 & IJRFIT.LT.MSTJ(18))THEN
63491 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
63492 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
63494 C...Store final boost, with change of sign since TJJ motion vector.
63496 TJJ(IJU,IX)=-TJUOLD(IX)
63498 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
63501 C...String length measure for (q-qbar)(q-qbar) topology.
63502 C...Note only momenta of nearest partons used (since rest of system
63504 IF (JJGLUE.EQ.0) THEN
63505 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
63506 & -1,IJCP(5-ISW)+1)
63508 C...Put jj gluons on selected string (IGS selected randomly above).
63510 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
63511 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
63513 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
63514 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
63518 C...String length measure for q-q-j-j-q-q topology.
63527 C...Note only momenta of nearest partons used (since rest of system
63530 IF (IX.EQ.4) ISGN=1
63531 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
63532 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
63533 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
63534 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
63535 IF (JJGLUE.EQ.0) THEN
63536 C...Junction motion vector dot product gives length when inter-junction
63538 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
63540 C...Junction motion vector dot products with gluon momenta give length
63541 C...when inter-junction gluons present.
63542 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
63543 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
63546 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
63547 IF (JJGLUE.EQ.0) THEN
63548 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
63550 DELMJJ=DELMJJ*4D0*T1G1*T2G2
63553 C...If delmjj > delmqq collapse string system to q-qbar q-qbar
63554 C...(Always the case for MSTJ(19)=2 due to initialization above)
63555 IF (DELMJJ.GT.DELMQQ) THEN
63556 C...Put new system at end of event record
63559 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
63562 P(NCOP,IX)=P(ICOP,IX)
63563 K(NCOP,IX)=K(ICOP,IX)
63566 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
63567 C...Insert inter-junction gluon string piece (reversed)
63569 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
63573 P(NCOP,IX)=P(ICOP,IX)
63574 K(NCOP,IX)=K(ICOP,IX)
63579 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
63582 P(NCOP,IX)=P(ICOP,IX)
63583 K(NCOP,IX)=K(ICOP,IX)
63588 C...Copy system back in right order
63589 DO 670 ICOP=NBEG,NEND-2
63591 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
63592 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
63595 C...Shift down rest of event record
63596 DO 690 ICOP=NEND+1,N
63598 P(ICOP-2,IX)=P(ICOP,IX)
63599 K(ICOP-2,IX)=K(ICOP,IX)
63602 C...Update length of event record.
63612 C...Done if no checks on small-mass systems.
63613 IF(MSTJ(14).LT.0) RETURN
63614 IF(MSTJ(14).EQ.0) GOTO 1140
63616 C...Find lowest-mass colour singlet jet system.
63621 DO 770 I=MAX(1,IP),N
63622 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
63623 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
63630 DPS(5)=PYMASS(K(I,2))
63631 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
63633 DPS(J)=DPS(J)+P(I,J)
63636 DPS(5)=DPS(5)+PYMASS(K(I,2))
63637 ELSEIF(K(I,1).EQ.2) THEN
63639 DPS(J)=DPS(J)+P(I,J)
63641 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
63643 DPS(J)=DPS(J)+P(I,J)
63646 DPS(5)=DPS(5)+PYMASS(K(I,2))
63647 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
63649 IF(PD.LT.PDMIN) THEN
63663 C...Done if lowest-mass system above threshold for string frag.
63664 IF(PDMIN.GE.PARJ(32)) GOTO 1140
63666 C...Fill small-mass system as cluster.
63668 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
63678 C...Set up history, assuming cluster -> 2 hadrons.
63684 IF(MSTU(16).NE.2) THEN
63699 C...Find total flavour content - complicated by presence of junctions.
63703 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
63706 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
63710 C...If several diquarks, split up one to give even number of flavours.
63711 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
63713 IF(IABS(KFQ(3)).LT.1000) I1=1
63714 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
63715 KFQ(I1)=KFQ(I1)/1000
63720 C...If four quark ends, join two to diquark.
63721 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
63724 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
63725 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
63726 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
63727 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
63728 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
63729 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
63735 C...If two quark ends, plus quark or diquark, join quarks to diquark.
63739 IF(IABS(KFQ(I1)).GT.1000) I1=3
63740 IF(IABS(KFQ(I2)).GT.1000) I2=3
63741 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
63742 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
63743 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
63744 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
63750 C...Form two particles from flavours of lowest-mass system, if feasible.
63752 790 NTRY = NTRY + 1
63754 C...Open string with two specified endpoint flavours.
63758 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
63759 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
63760 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
63761 IF(KQ1+KQ2.NE.0) GOTO 1140
63762 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
63764 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
63766 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
63767 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
63768 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
63770 C...Open string with four specified flavours.
63771 ELSEIF(NQ.EQ.4) THEN
63776 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
63777 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
63778 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
63779 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
63780 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
63781 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
63782 C...Combine flavours pairwise to form two hadrons.
63785 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
63786 & IABS(KFQ(2)).GT.1000)) I2=3
63787 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
63788 & IABS(KFQ(3)).GT.1000))) I2=4
63792 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
63793 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
63794 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
63798 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
63799 C...No room for popcorn mesons in closed string -> 2 hadrons.
63801 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
63802 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
63803 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
63804 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
63806 P(N+2,5)=PYMASS(K(N+2,2))
63807 P(N+3,5)=PYMASS(K(N+3,2))
63809 C...If it does not work: try again (a number of times), give up (if no
63810 C...place to shuffle momentum or too many flavours), or form one hadron.
63811 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
63812 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
63814 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
63821 C...Perform two-particle decay of jet system.
63822 C...First step: find reference axis in decaying system rest frame.
63823 C...(Borrow slot N+2 for temporary direction.)
63827 DO 850 I=IC1+1,IC2-1
63828 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
63829 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
63830 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
63832 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
63836 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
63838 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
63839 PHI1=PYANGL(P(N+2,1),P(N+2,2))
63841 C...Second step: generate isotropic/anisotropic decay.
63842 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
63843 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
63845 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
63846 PT2=(1D0-UE(3)**2)*PA**2
63847 IF(MSTJ(16).LE.0) THEN
63850 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
63851 PR1=P(N+2,5)**2+PT2
63852 PR2=P(N+3,5)**2+PT2
63853 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
63855 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
63856 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
63858 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
63860 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
63861 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
63866 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
63867 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
63869 C...Third step: move back to event frame and set production vertex.
63870 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
63880 C...Else form one particle, if possible.
63888 C...Select hadron flavour from available quark flavours.
63889 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
63891 ELSEIF(NQ.EQ.2) THEN
63892 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
63894 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
63895 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
63897 IF(K(N+2,2).EQ.0) GOTO 910
63898 P(N+2,5)=PYMASS(K(N+2,2))
63900 C...Use old algorithm for E/p conservation? (EN)
63901 IF (MSTJ(16).LE.0) GOTO 1080
63903 C...Find the string piece closest to the cluster by a loop
63904 C...over the undecayed partons not in present cluster. (EN)
63909 DO 940 I1=MAX(1,IP),N-1
63910 IF(K(I1,1).EQ.1) NJUNC=0
63911 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
63912 IF(K(I1,1).EQ.41) GOTO 940
63913 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
63915 ELSEIF(K(I1,1).EQ.2) THEN
63919 IF(K(I2,1).EQ.41) GOTO 940
63920 IF(K(I2,1).GT.10) GOTO 920
63921 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
63922 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
63923 & NJUNC.EQ.0) GOTO 940
63924 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
63925 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
63926 & K(I2,1).NE.1)) GOTO 940
63928 C...Define velocity vectors e1, e2, ecl and differences e3, e4.
63930 E1(J)=P(I1,J)/P(I1,4)
63931 E2(J)=P(I2,J)/P(I2,4)
63932 ECL(J)=P(N+1,J)/P(N+1,4)
63937 C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
63938 E3S=E3(1)**2+E3(2)**2+E3(3)**2
63939 E4S=E4(1)**2+E4(2)**2+E4(3)**2
63940 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
63941 IF(E34.LE.0D0) THEN
63943 ELSEIF(E34.LT.E3S) THEN
63944 DDMIN=E4S-E34**2/E3S
63946 DDMIN=E4S-2D0*E34+E3S
63949 C...Is this the smallest so far?
63950 IF(DDMIN.LT.DGLOMI) THEN
63955 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
63960 C... Check if there are any strings to connect to the new gluon. (EN)
63961 IF (IBEG.EQ.0) GOTO 1080
63963 C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
63964 IF (P(N+1,5).GE.P(N+2,5)) THEN
63966 C...Construct 'gluon' that is needed to put hadron on the mass shell.
63967 FRAC=P(N+2,5)/P(N+1,5)
63969 P(N+2,J)=FRAC*P(N+1,J)
63970 PG(J)=(1D0-FRAC)*P(N+1,J)
63973 C... Copy string with new gluon put in.
63977 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
63978 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
63999 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
64002 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
64003 C...from string piece endpoints.
64006 C...Begin by copying string that should give energy to cluster.
64010 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
64011 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
64023 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
64026 C...Set initial Phad.
64028 P(NSAV+2,J)=P(NSAV+1,J)
64031 C...Calculate Pg, a part of which will be added to Phad later. (EN)
64032 1020 IF(MSTJ(16).EQ.1) THEN
64036 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
64037 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
64040 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
64042 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
64044 C..Solve 2nd order equation, use the best (smallest) solution. (EN)
64045 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
64047 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
64048 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
64049 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
64051 C...If all gluon energy eaten, zero it and take a step back.
64053 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
64056 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
64062 IF(K(I1,1).EQ.41) ITER=-1
64064 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
64067 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
64073 IF(K(I2,1).EQ.41) ITER=-1
64075 IF(ITER.EQ.1) GOTO 1020
64077 C...If also all endpoint energy eaten, revert to old procedure.
64078 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
64079 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
64090 C... Construct the collapsed hadron and modified string partons.
64092 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
64093 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
64094 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
64096 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
64097 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
64099 C...Finished with string collapse in new scheme.
64103 C... Use old algorithm; by choice or when in trouble.
64105 C...Find parton/particle which combines to largest extra mass.
64110 IF(IR.NE.0) GOTO 1100
64111 DO 1090 I=MAX(1,IP),N
64112 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
64113 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
64114 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
64115 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
64116 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
64117 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
64119 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
64120 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
64121 IF(HSR.GT.HSM) THEN
64129 C...Shuffle energy and momentum to put new particle on mass shell.
64134 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
64135 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
64136 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
64138 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
64139 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
64143 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
64147 C...Mark collapsed system and store daughter pointers. Iterate.
64148 1120 DO 1130 I=IC1,IC2
64149 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
64150 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
64152 IF(MSTU(16).NE.2) THEN
64157 K(I,5)=NSAV+1+NBODY
64160 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
64162 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
64164 C...Check flavours and invariant masses in parton systems.
64172 DO 1180 I=MAX(1,IP),N
64173 IF(K(I,1).EQ.41) NJU=NJU+1
64174 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
64176 IF(KC.EQ.0) GOTO 1180
64177 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
64178 IF(KQ.EQ.0) GOTO 1180
64184 DPS(5)=DPS(5)+PYMASS(K(I,2))
64187 DPS(J)=DPS(J)+P(I,J)
64189 IF(K(I,1).EQ.1) THEN
64191 IF(NJU.EQ.0.AND.NP.NE.1) THEN
64192 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
64193 ELSEIF(NJU.EQ.1) THEN
64194 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
64195 ELSEIF(NJU.EQ.2) THEN
64196 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
64197 ELSEIF(NJU.GE.3) THEN
64200 IF(NFERR.EQ.1) THEN
64201 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
64205 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
64206 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
64207 & '(PYPREP:) too small mass in jet system')
64221 C*********************************************************************
64224 C...Handles the fragmentation of an arbitrary colour singlet
64225 C...jet system according to the Lund string fragmentation model.
64227 SUBROUTINE PYSTRF(IP)
64229 C...Double precision and integer declarations.
64230 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64231 IMPLICIT INTEGER(I-N)
64232 INTEGER PYK,PYCHGE,PYCOMP
64234 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64235 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64236 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64237 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
64238 C...Local arrays. All MOPS variables ends with MO
64239 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
64240 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
64241 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
64242 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
64243 &PBST(3,5),TJUOLD(5)
64245 C...Function: four-product of two vectors.
64246 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)
64247 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
64250 C...Reset counters.
64265 C...Identify parton system.
64268 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
64269 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
64270 IF(MSTU(21).GE.1) RETURN
64272 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
64274 IF(KC.EQ.0) GOTO 110
64275 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
64276 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
64277 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
64278 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
64279 IF(MSTU(21).GE.1) RETURN
64282 C...Take copy of partons to be considered. Check flavour sum.
64287 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
64289 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
64291 IF(KQ.NE.2) KQSUM=KQSUM+KQ
64292 IF(K(I,1).EQ.41) THEN
64293 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
64301 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
64302 IF(MOD(KQSUM,3).NE.0) THEN
64303 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
64304 IF(MSTU(21).GE.1) RETURN
64306 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
64308 C...Boost copied system to CM frame (for better numerical precision).
64309 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
64312 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
64316 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
64318 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
64319 IF(P(I,3).GT.0D0) THEN
64320 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
64321 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
64322 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
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)
64331 C...Search for very nearby partons that may be recombined.
64340 IF(MJU(1).GT.0) NRMIN=NRMIN+2
64341 IF(MJU(2).GT.0) NRMIN=NRMIN+2
64342 140 IF(NR.GT.NRMIN) THEN
64345 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
64347 IF(I.EQ.N+NR) I1=N+1
64348 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
64349 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
64351 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
64353 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
64354 & P(I1,2)**2+P(I1,3)**2))
64355 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
64356 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
64357 IF(PDR.LT.PDRMIN) THEN
64363 C...Recombine very nearby partons to avoid machine precision problems.
64364 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
64366 P(N+1,J)=P(N+1,J)+P(N+NR,J)
64368 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
64372 ELSEIF(PDRMIN.LT.PARU12) THEN
64374 P(IR,J)=P(IR,J)+P(IR+1,J)
64376 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
64378 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
64379 DO 190 I=IR+1,N+NR-1
64386 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
64388 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
64389 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
64395 C...Reset particle counter. Skip ahead if no junctions are present;
64396 C...this is usually the case!
64397 NRS=MAX(5*NR+11,NP)
64400 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64404 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
64405 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64406 IF(MSTU(21).GE.1) RETURN
64410 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
64411 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
64412 & ' junction strings not handled by MSTJ(12)>3 options')
64415 IF(MJU(JT).EQ.0) GOTO 640
64419 C...Find and sum up momentum on three sides of junction.
64420 C...Begin with previous boost = zero.
64425 C...Prevent IJU (specifically IJU(5)) from containing junk below
64431 C...Beginning and end of string system in event record.
64432 I1BEG=N+1+(JT-1)*(NR-1)
64433 I1END=N+NR+(JT-1)*(1-NR)
64434 C...Look for junction string piece end points
64435 DO 230 I1=I1BEG,I1END,JS
64436 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
64437 C...Store junction string piece end points.
64438 C 1-junction systems 2-junction systems
64439 C IU : 1 2 3 4 1 2 3 4 5 6
64440 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
64444 C...Sum over momenta, from junction outwards.
64448 C...Initialize junction drag and string piece 4-vectors.
64453 C...First two branches. Inwards out means opposite direction to JS.
64454 C...(JS is 1 for JT=1, -1 for JT=2)
64459 C...Last branch (gq or gjgqgq). Direction now reversed.
64465 DO 270 I1=I1A,I1B,IDIR
64466 C...Sum up momentum directions with exponential suppression
64467 C...for use in finding junction rest frame below.
64468 IF (K(I1,2).EQ.88) THEN
64469 C...gjgqgq type system encountered. Use current PWT as start
64470 C...for both strings.
64473 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
64474 C...Sum up string piece (boosted) 4-momenta.
64476 PJU(IU,J)=PJU(IU,J)+P(I1,J)
64478 C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
64479 C...boost is zero, see above). Skip parton if suppression factor large.
64480 IF (PWT.GT.10D0) GOTO 270
64481 C...Compute momentum in current frame:
64482 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
64483 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
64485 PTMP=P(I1,J)+TJUOLD(J)*BFC
64486 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
64489 PTMP=TJUOLD(4)*P(I1,4)+TDP
64490 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
64491 PWT=PWT+PTMP/PARJ(48)
64494 C...Put |p| rather than m in 5th slot.
64495 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
64496 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
64499 C...Calculate boost from present frame to next JRF candidate.
64501 CALL PYJURF(PBST,TJU)
64503 C...After some iterations do not take full step in new direction.
64504 IF(IJRFIT.GT.5) THEN
64505 REDUCE=0.8D0**(IJRFIT-5)
64506 TJU(1)=REDUCE*TJU(1)
64507 TJU(2)=REDUCE*TJU(2)
64508 TJU(3)=REDUCE*TJU(3)
64509 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
64512 C...Combine new boost (TJU) with old boost (TJUOLD)
64513 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
64515 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
64517 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
64519 C...If last boost small, accept JRF, else iterate.
64520 C...Also prevent possibility of infinite loop.
64521 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
64522 & IJRFIT.LT.MSTJ(18)) THEN
64524 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
64525 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
64528 C...Now store total boost in TJU and change perception.
64529 C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
64530 C...TJU = junction motion vector in string CM, so the sign changes.
64534 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
64538 C...Calculate string piece energies in junction rest frame.
64540 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
64542 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
64543 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
64546 C...Start preparing for fragmentation of two strings from junction.
64549 320 NTRYER=NTRYER+1
64552 NS=IABS(IJU(IU+1)-IJU(IU))
64554 C...Junction strings: find longitudinal string directions.
64556 IS1=IJU(IU)+JS*(IS-1)
64559 DP(1,J)=0.5D0*P(IS1,J)
64560 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
64561 DP(2,J)=0.5D0*P(IS2,J)
64562 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
64563 & (PJU(IU,5)/PBST(IU,5))
64565 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
64566 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
64570 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
64571 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64572 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64577 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
64578 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
64579 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
64581 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
64583 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
64584 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
64588 C...Junction strings: initialize flavour, momentum and starting pos.
64592 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64596 ELSEIF(NTRY.GT.100) THEN
64597 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64598 IF(MSTU(21).GE.1) RETURN
64603 IE(1)=K(N+1+(JT/2)*(NP-1),3)
64604 IF (MOD(JT+IU,2).NE.0) THEN
64606 IF (NP-NR.NE.0) THEN
64607 C...If gluons have disappeared. Original IJU must be used.
64611 IF (K(IT,2).NE.21) THEN
64614 IF (NE.EQ.IU+4*(JT-1)) THEN
64616 ELSEIF (IT.LE.IP+NP) THEN
64619 CALL PYERRM(14,'(PYSTRF:) '//
64620 & 'Original IJU could not be reconstructed!')
64628 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
64634 KFL(1)=K(IJU(IU),2)
64642 C...Junction strings: find initial transverse directions.
64645 DP(2,J)=P(IN(4)+1,J)
64649 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64650 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64651 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
64652 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
64653 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
64654 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
64655 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
64656 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
64657 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
64659 DHCX1=DFOUR(3,1)/DHC12
64660 DHCX2=DFOUR(3,2)/DHC12
64661 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
64662 DHCY1=DFOUR(4,1)/DHC12
64663 DHCY2=DFOUR(4,2)/DHC12
64664 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
64665 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
64667 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
64669 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
64673 C...Junction strings: produce new particle, origin.
64675 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
64676 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
64677 IF(MSTU(21).GE.1) RETURN
64685 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
64686 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
64687 IF(K(I,2).EQ.0) GOTO 360
64688 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
64689 & IABS(KFL(3)).GT.10) THEN
64690 IF(PYR(0).GT.PARJ(19)) GOTO 440
64692 P(I,5)=PYMASS(K(I,2))
64693 CALL PYPTDI(KFL(1),PX(3),PY(3))
64694 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
64695 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
64696 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
64697 & MSTU(90).LT.8) THEN
64698 MSTU(90)=MSTU(90)+1
64699 MSTU(90+MSTU(90))=I
64700 PARU(90+MSTU(90))=Z
64702 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
64707 C...Junction strings: stepping within 'low' string region.
64708 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
64709 & P(IN(1),5)**2.GE.PR(1)) THEN
64710 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
64711 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
64713 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
64716 C...Has used up energy of junction string, i.e. no more hadrons in it.
64717 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
64722 C...Stepping from 'low' string region
64723 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
64724 P(IN(2)+2,4)=P(IN(2)+2,3)
64727 IF(IN(2).GT.N+NR+4*NS) GOTO 360
64728 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
64729 P(IN(1)+2,4)=P(IN(1)+2,3)
64735 C...Junction strings: find new transverse directions.
64736 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
64737 & IN(1).GT.IN(2)) GOTO 360
64738 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
64745 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64746 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64748 IF(DHC12.LE.1D-2) THEN
64749 P(IN(1)+2,4)=P(IN(1)+2,3)
64755 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
64756 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
64757 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
64758 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
64759 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
64760 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
64761 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
64762 DHCX1=DFOUR(3,1)/DHC12
64763 DHCX2=DFOUR(3,2)/DHC12
64764 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
64765 DHCY1=DFOUR(4,1)/DHC12
64766 DHCY2=DFOUR(4,2)/DHC12
64767 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
64768 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
64770 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
64772 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
64775 C...Express pT with respect to new axes, if sensible.
64776 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
64777 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
64778 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
64784 C...Junction strings: sum up known four-momentum, coefficients for m2.
64787 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
64788 & PY(3)*P(IN(3)+1,J)
64789 DO 510 IN1=IN(4),IN(1)-4,4
64790 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
64792 DO 520 IN2=IN(5),IN(2)-4,4
64793 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
64797 DHM(2)=2D0*FOUR(I,IN(1))
64798 DHM(3)=2D0*FOUR(I,IN(2))
64799 DHM(4)=2D0*FOUR(IN(1),IN(2))
64801 C...Junction strings: find coefficients for Gamma expression.
64802 DO 550 IN2=IN(1)+1,IN(2),4
64803 DO 540 IN1=IN(1),IN2-1,4
64804 DHC=2D0*FOUR(IN1,IN2)
64805 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
64806 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
64807 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
64808 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
64812 C...Junction strings: solve (m2, Gamma) equation system for energies.
64813 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
64814 IF(ABS(DHS1).LT.1D-4) GOTO 360
64815 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
64816 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
64817 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
64818 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
64819 & ABS(DHS1)-DHS2/DHS1)
64820 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
64821 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
64822 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
64824 C...Junction strings: step to new region if necessary.
64825 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
64826 P(IN(2)+2,4)=P(IN(2)+2,3)
64829 IF(IN(2).GT.N+NR+4*NS) GOTO 360
64830 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
64831 P(IN(1)+2,4)=P(IN(1)+2,3)
64836 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
64837 P(IN(1)+2,4)=P(IN(1)+2,3)
64843 C...Junction strings: particle four-momentum, remainder, loop back.
64845 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
64846 & P(IN(2)+2,4)*P(IN(2),J)
64847 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
64849 IF(P(I,4).LT.P(I,5)) GOTO 360
64850 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
64851 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
64852 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
64857 IF(IN(3).NE.IN(6)) THEN
64859 P(IN(6),J)=P(IN(3),J)
64860 P(IN(6)+1,J)=P(IN(3)+1,J)
64865 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
64866 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
64871 C...Junction strings: save quantities left after each string.
64872 IF(IABS(KFL(1)).GT.10) GOTO 360
64876 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
64879 C...Junction strings: loopback if much unused energy in both strings.
64880 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
64881 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
64882 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
64884 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
64885 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
64886 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
64887 & .AND.NTRYER.LT.10) GOTO 320
64889 C...Junction strings: put together to new effective string endpoint.
64891 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
64892 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
64893 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
64894 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
64896 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
64897 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
64899 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
64904 C...Open versus closed strings. Choose breakup region for latter.
64905 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
64908 ELSEIF(MJU(1).NE.0) THEN
64911 ELSEIF(MJU(2).NE.0) THEN
64914 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
64921 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
64922 W2SUM=W2SUM+P(N+NR+IS,1)
64927 W2SUM=W2SUM-P(N+NR+NB,1)
64928 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
64931 C...Find longitudinal string directions (i.e. lightlike four-vectors).
64933 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
64934 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
64937 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
64938 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
64940 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
64941 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
64943 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
64944 & DP(1,2)**2-DP(1,3)**2))
64945 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
64946 & DP(2,2)**2-DP(2,3)**2))
64950 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
64951 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
64952 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
64953 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
64955 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
64957 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
64958 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
64962 C...Begin initialization: sum up energy, set starting position.
64966 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64970 ELSEIF(NTRY.GT.100) THEN
64971 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64972 IF(MSTU(21).GE.1) RETURN
64979 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
64984 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
64985 IF(NS.GT.NR) IRANK(JT)=1
64987 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
64988 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
64989 IN(3*JT+2)=IN(3*JT+1)+1
64990 IN(3*JT+3)=N+NR+4*NS+2*JT-1
64991 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
64998 C.. MOPS variables and switches
65004 C...Initialize flavour and pT variables for open string.
65008 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
65012 KFL(JT)=K(IE(JT),2)
65013 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
65014 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
65016 PMQ(JT)=PYMASS(KFL(JT))
65020 C...Closed string: random initial breakup flavour, pT and vertex.
65022 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65024 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
65025 C.. Closed string: first vertex diq attempt => enforced second
65027 IF(IABS(KFL(1)).GT.10)THEN
65032 IF(IBMO.EQ.1) MSTU(121)=-1
65034 CALL PYPTDI(KFL(1),PX(1),PY(1))
65037 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
65038 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
65039 ZR=PR3/(Z*P(N+NR+1,5)**2)
65040 IF(ZR.GE.1D0) GOTO 780
65043 PMQ(JT)=PYMASS(KFL(JT))
65044 GAM(JT)=PR3*(1D0-Z)/Z
65045 IN1=N+NR+3+4*(JT/2)*(NS-1)
65048 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
65051 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
65057 PM2QMO(JT)=PMQ(JT)**2
65058 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
65061 C...Find initial transverse directions (i.e. spacelike four-vectors).
65063 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
65072 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
65073 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
65074 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
65075 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
65076 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
65077 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
65078 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
65079 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
65080 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
65082 DHCX1=DFOUR(3,1)/DHC12
65083 DHCX2=DFOUR(3,2)/DHC12
65084 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
65085 DHCY1=DFOUR(4,1)/DHC12
65086 DHCY2=DFOUR(4,2)/DHC12
65087 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
65088 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
65090 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
65092 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
65097 P(IN3+2,J)=P(IN3,J)
65098 P(IN3+3,J)=P(IN3+1,J)
65103 C...Remove energy used up in junction string fragmentation.
65104 IF(MJU(1)+MJU(2).GT.0) THEN
65106 IF(NJS(JT).EQ.0) GOTO 860
65108 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
65112 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
65113 WMIN=PARJST+PMQ(1)+PMQ(2)
65114 WREM2=FOUR(N+NRS,N+NRS)
65115 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
65117 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
65122 C...Produce new particle: side, origin.
65124 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
65125 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
65126 IF(MSTU(21).GE.1) RETURN
65128 C.. New side priority for popcorn systems
65129 IF(MSTU(121).LE.0)THEN
65131 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
65132 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
65136 IRANK(JT)=IRANK(JT)+1
65141 C...Generate flavour, hadron and pT.
65143 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
65144 IF(K(I,2).EQ.0) GOTO 710
65146 IF(MSTU(121).EQ.-1) GOTO 910
65147 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
65148 &IABS(KFL(3)).GT.10) THEN
65149 IF(PYR(0).GT.PARJ(19)) GOTO 880
65151 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65153 P(I,5)=PYMASS(K(I,2))
65154 CALL PYPTDI(KFL(JT),PX(3),PY(3))
65155 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
65157 C...Final hadrons for small invariant mass.
65159 PMQ(3)=PYMASS(KFL(3))
65161 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
65162 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
65163 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
65164 &WMIN-0.5D0*PARJ(36)*PMQ(3)
65165 WREM2=FOUR(N+NRS,N+NRS)
65166 IF(WREM2.LT.0.10D0) GOTO 710
65167 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
65168 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
65170 C...Choose z, which gives Gamma. Shift z for heavy flavours.
65171 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
65172 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
65173 &MSTU(90).LT.8) THEN
65174 MSTU(90)=MSTU(90)+1
65175 MSTU(90+MSTU(90))=I
65176 PARU(90+MSTU(90))=Z
65180 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
65181 &MOD(KFL2A/1000,10)).GE.4) THEN
65182 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65183 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
65184 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
65185 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65186 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
65188 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
65190 C.. MOPS baryon model modification
65191 XTMO3=(1D0-Z)*XTMO(JT)
65192 IF(IABS(KFL(3)).LE.10) NRVMO=0
65193 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
65197 IF(IABS(KFL(JT)).LE.10)THEN
65198 XBMO=MIN(XTMO3,1D0-(2D-10))
65201 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
65202 GTSTMO=1D0-PARF(192)**PGMO
65204 IF(IRANK(JT).EQ.1) THEN
65209 IF(XBMO.LT.1D0-(1D-10))THEN
65210 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
65211 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
65214 IF(MSTJ(12).GE.5)THEN
65215 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
65216 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
65217 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
65222 C.. MOPS Accepting popcorn system hadron.
65223 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
65224 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
65226 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
65228 & '(PYSTRF:) no more memory left in PYJETS')
65229 IF(MSTU(21).GE.1) RETURN
65241 DO 890 LINE=1,I-N-NR
65242 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
65243 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
65250 C..Reject popcorn system, flag=-1 if enforcing new one
65252 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
65257 C..Lift restoring string outside MOPS block
65258 910 IF(MSTU(121).LT.0) THEN
65259 IF(MSTU(121).EQ.-2) MSTU(121)=0
65262 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
65273 DO 920 LINE=1,I-N-NR
65274 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
65275 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
65283 C.. MOPS end of modification
65289 C...Stepping within or from 'low' string region easy.
65290 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
65291 &P(IN(1),5)**2.GE.PR(JT)) THEN
65292 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
65293 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
65295 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
65298 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
65299 P(IN(JR)+2,4)=P(IN(JR)+2,3)
65302 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
65303 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
65304 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65310 C...Find new transverse directions (i.e. spacelike string vectors).
65311 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
65312 &IN(1).GT.IN(2)) GOTO 710
65313 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
65320 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
65321 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
65323 IF(DHC12.LE.1D-2) THEN
65324 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65330 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
65331 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
65332 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
65333 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
65334 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
65335 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
65336 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
65337 DHCX1=DFOUR(3,1)/DHC12
65338 DHCX2=DFOUR(3,2)/DHC12
65339 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
65340 DHCY1=DFOUR(4,1)/DHC12
65341 DHCY2=DFOUR(4,2)/DHC12
65342 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
65343 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
65345 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
65347 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
65350 C...Express pT with respect to new axes, if sensible.
65351 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
65352 & FOUR(IN(3*JT+3)+1,IN(3)))
65353 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
65354 & FOUR(IN(3*JT+3)+1,IN(3)+1))
65355 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
65361 C...Sum up known four-momentum. Gives coefficients for m2 expression.
65364 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
65365 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
65366 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
65367 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
65369 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
65370 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
65374 DHM(2)=2D0*FOUR(I,IN(1))
65375 DHM(3)=2D0*FOUR(I,IN(2))
65376 DHM(4)=2D0*FOUR(IN(1),IN(2))
65378 C...Find coefficients for Gamma expression.
65379 DO 1030 IN2=IN(1)+1,IN(2),4
65380 DO 1020 IN1=IN(1),IN2-1,4
65381 DHC=2D0*FOUR(IN1,IN2)
65382 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
65383 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
65384 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
65385 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
65389 C...Solve (m2, Gamma) equation system for energies taken.
65390 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
65391 IF(ABS(DHS1).LT.1D-4) GOTO 710
65392 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
65393 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
65394 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
65395 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
65396 &ABS(DHS1)-DHS2/DHS1)
65397 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
65398 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
65399 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
65401 C...Step to new region if necessary.
65402 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
65403 P(IN(JR)+2,4)=P(IN(JR)+2,3)
65406 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
65407 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
65408 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65413 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
65414 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65420 C...Four-momentum of particle. Remaining quantities. Loop back.
65422 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
65423 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
65425 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
65426 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
65428 IF(P(I,4).LT.P(I,5)) GOTO 710
65434 IF(IN(3).NE.IN(3*JT+3)) THEN
65436 P(IN(3*JT+3),J)=P(IN(3),J)
65437 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
65442 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
65443 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
65445 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65449 C...Final hadron: side, flavour, hadron, mass.
65455 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
65456 IF(K(I,2).EQ.0) GOTO 710
65457 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
65459 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65461 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65463 P(I,5)=PYMASS(K(I,2))
65464 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65466 C...Final two hadrons: find common setup of four-vectors.
65468 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
65469 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
65470 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
65471 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
65472 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
65473 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
65474 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
65475 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
65476 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
65477 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
65480 C...Solve kinematics for final two hadrons, if possible.
65481 WREM2=2D0*DHR1*DHR2*DHC12
65482 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
65483 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
65484 IF(FD.GE.1D0) GOTO 710
65485 FA=WREM2+PR(JT)-PR(JR)
65486 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
65488 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
65489 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
65490 FB=SIGN(FB,JS*(PYR(0)-PREV))
65493 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
65494 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
65495 &4D0*WREM2*PR(JT))),DBLE(JS))
65497 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
65498 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
65499 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
65500 P(I,J)=P(N+NRS,J)-P(I-1,J)
65502 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
65503 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
65504 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
65505 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
65507 IF(NTRYFN.LT.100) GOTO 140
65508 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
65511 C...Mark jets as fragmented and give daughter pointers.
65513 DO 1100 I=NSAV+1,NSAV+NP
65516 IF(MSTU(16).NE.2) THEN
65525 C...Document string system. Move up particles.
65536 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
65540 K(I,J)=K(I+NRS-1,J)
65541 P(I,J)=P(I+NRS-1,J)
65546 DO 1140 IZ=MSTU90+1,MSTU91
65547 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
65548 PARU9T(IZ)=PARU(90+IZ)
65552 C...Order particles in rank along the chain. Update mother pointer.
65555 K(I-NSAV+N,J)=K(I,J)
65556 P(I-NSAV+N,J)=P(I,J)
65560 DO 1190 I=N+1,2*N-NSAV
65561 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
65567 IF(MSTU(16).NE.2) K(I1,3)=NSAV
65568 DO 1180 IZ=MSTU90+1,MSTU91
65569 IF(MSTU9T(IZ).EQ.I) THEN
65570 MSTU(90)=MSTU(90)+1
65571 MSTU(90+MSTU(90))=I1
65572 PARU(90+MSTU(90))=PARU9T(IZ)
65576 DO 1220 I=2*N-NSAV,N+1,-1
65577 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
65583 IF(MSTU(16).NE.2) K(I1,3)=NSAV
65584 DO 1210 IZ=MSTU90+1,MSTU91
65585 IF(MSTU9T(IZ).EQ.I) THEN
65586 MSTU(90)=MSTU(90)+1
65587 MSTU(90+MSTU(90))=I1
65588 PARU(90+MSTU(90))=PARU9T(IZ)
65593 C...Boost back particle system. Set production vertices.
65596 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
65600 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
65601 IF(P(I,3).GT.0D0) THEN
65602 HHPEZ=(P(I,4)+P(I,3))*HHBZ
65603 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
65604 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
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)
65621 C*********************************************************************
65624 C...From three given input vectors in PJU the boost VJU from
65625 C...the "lab frame" to the junction rest frame is constructed.
65627 SUBROUTINE PYJURF(PJU,VJU)
65629 C...Double precision and integer declarations.
65630 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65631 IMPLICIT INTEGER(I-N)
65633 C...Input, output and local arrays.
65634 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
65635 DATA TWOPI/6.283186D0/
65637 C...Calculate masses and other invariants.
65639 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
65641 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
65642 PSUM(5)=SQRT(PSUM2)
65645 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
65646 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
65650 C...Pick I to be most massive parton and J to be the one closest to I.
65653 IF(A(2,2).GT.A(1,1)) I=2
65654 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
65658 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
65669 C...Trivial find new parton energies if all three partons are massless.
65670 IF(PMI2.LT.1D-4) THEN
65671 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
65672 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
65673 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
65675 C...Else find momentum range for parton I and values at extremes.
65681 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
65682 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
65683 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
65684 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
65685 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
65686 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
65687 HI=PEIMAX**2-0.25D0*PAIMAX**2
65688 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
65689 & 0.5D0*PAIMAX*AIJ)/HI
65690 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
65691 & 0.5D0*PAIMAX*AIK)/HI
65692 PEJMAX=SQRT(PAJMAX**2+PMJ2)
65693 PEKMAX=SQRT(PAKMAX**2+PMK2)
65694 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
65696 C...If unexpected values at upper endpoint then pick another parton.
65697 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
65699 IF(A(I1,I1).GE.1D-4) THEN
65705 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
65711 C..Start binary + linear search to find solution inside range.
65715 PAI=0.5D0*(PAIMIN+PAIMAX)
65718 C...Derive momentum of other two partons and distance to root.
65719 PEI=SQRT(PAI**2+PMI2)
65720 HI=PEI**2-0.25D0*PAI**2
65721 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
65722 PEJ=SQRT(PAJ**2+PMJ2)
65723 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
65724 PEK=SQRT(PAK**2+PMK2)
65725 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
65727 C...Pick next I momentum to explore, hopefully closer to root.
65728 IF(FNOW.GT.0D0) THEN
65737 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
65739 PAI=0.5D0*(PAIMIN+PAIMAX)
65741 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
65742 & ABS(FNOW).GT.1D-12*PSUM2) THEN
65743 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
65748 C...Now know energies in junction rest frame.
65753 C...Boost (copy of) partons to their rest frame.
65754 VXCM=-PSUM(1)/PSUM(5)
65755 VYCM=-PSUM(2)/PSUM(5)
65756 VZCM=-PSUM(3)/PSUM(5)
65757 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
65759 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
65760 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
65761 PCM(I,1)=PJU(I,1)+FAC2*VXCM
65762 PCM(I,2)=PJU(I,2)+FAC2*VYCM
65763 PCM(I,3)=PJU(I,3)+FAC2*VZCM
65764 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
65765 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
65768 C...Construct difference vectors and boost to junction rest frame.
65770 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
65771 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
65773 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
65774 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
65775 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
65776 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
65777 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
65778 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
65779 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
65780 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
65781 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
65782 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
65783 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
65785 C...Add two boosts, giving final result.
65786 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
65787 VJU(1)=VXJU+FCM*VXCM
65788 VJU(2)=VYJU+FCM*VYCM
65789 VJU(3)=VZJU+FCM*VZCM
65790 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
65793 C...In case of error in reconstruction: revert to CM frame of system.
65794 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
65795 &(PCM(1,5)*PCM(2,5))
65796 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
65797 &(PCM(1,5)*PCM(3,5))
65798 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
65799 &(PCM(2,5)*PCM(3,5))
65800 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
65801 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
65803 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
65804 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
65805 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
65806 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
65807 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
65808 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
65809 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
65811 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
65812 &(PCM(1,5)*PCM(2,5))
65813 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
65814 &(PCM(1,5)*PCM(3,5))
65815 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
65816 &(PCM(2,5)*PCM(3,5))
65817 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
65818 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
65819 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
65829 C*********************************************************************
65832 C...Handles the fragmentation of a jet system (or a single
65833 C...jet) according to independent fragmentation models.
65835 SUBROUTINE PYINDF(IP)
65837 C...Double precision and integer declarations.
65838 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65839 IMPLICIT INTEGER(I-N)
65840 INTEGER PYK,PYCHGE,PYCOMP
65842 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65843 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65844 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65845 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
65847 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
65848 &KFLO(2),PXO(2),PYO(2),WO(2)
65850 C.. MOPS error message
65851 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
65852 &' are not treated as expected in independent fragmentation')
65854 C...Reset counters. Identify parton system and take copy. Check flavour.
65864 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
65865 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
65866 IF(MSTU(21).GE.1) RETURN
65868 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
65870 IF(KC.EQ.0) GOTO 110
65871 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
65872 IF(KQ.EQ.0) GOTO 110
65874 IF(KQ.NE.2) KQSUM=KQSUM+KQ
65876 K(NSAV+NJET,J)=K(I,J)
65877 P(NSAV+NJET,J)=P(I,J)
65878 DPS(J)=DPS(J)+P(I,J)
65881 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
65882 &K(I+1,1).EQ.2)) GOTO 110
65883 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
65884 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
65885 IF(MSTU(21).GE.1) RETURN
65888 C...Boost copied system to CM frame. Find CM energy and sum flavours.
65891 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
65892 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
65898 DO 140 I=NSAV+1,NSAV+NJET
65902 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
65903 ELSEIF(KFA.GT.1000) THEN
65904 KFLA=MOD(KFA/1000,10)
65905 KFLB=MOD(KFA/100,10)
65906 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
65907 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
65911 C...Loop over attempts made. Reset counters.
65914 IF(NTRY.GT.200) THEN
65915 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
65916 IF(MSTU(21).GE.1) RETURN
65926 C...Loop over jets to be fragmented.
65927 DO 230 IP1=NSAV+1,NSAV+NJET
65932 C...Initial flavour and momentum values. Jet along +z axis.
65933 KFLH=IABS(K(IP1,2))
65934 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
65936 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
65938 C...Initial values for quark or diquark jet.
65939 170 IF(IABS(K(IP1,2)).NE.21) THEN
65942 CALL PYPTDI(0,PXO(1),PYO(1))
65945 C...Initial values for gluon treated like random quark jet.
65946 ELSEIF(MSTJ(2).LE.2) THEN
65948 IF(MSTJ(2).EQ.2) MSTJ(91)=1
65949 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65950 CALL PYPTDI(0,PXO(1),PYO(1))
65953 C...Initial values for gluon treated like quark-antiquark jet pair,
65954 C...sharing energy according to Altarelli-Parisi splitting function.
65957 IF(MSTJ(2).EQ.4) MSTJ(91)=1
65958 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65960 CALL PYPTDI(0,PXO(1),PYO(1))
65963 WO(1)=WF*PYR(0)**(1D0/3D0)
65967 C...Initial values for rank, flavour, pT and W+.
65977 C...New hadron. Generate flavour and hadron species.
65979 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
65980 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
65981 IF(MSTU(21).GE.1) RETURN
65988 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
65989 IF(K(I,2).EQ.0) GOTO 180
65990 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
65991 IF(PYR(0).GT.PARJ(19)) GOTO 200
65994 C...Find hadron mass. Generate four-momentum.
65995 P(I,5)=PYMASS(K(I,2))
65996 CALL PYPTDI(KFL1,PX2,PY2)
65999 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
66000 CALL PYZDIS(KFL1,KFL2,PR,Z)
66002 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
66004 MSTU(90)=MSTU(90)+1
66005 MSTU(90+MSTU(90))=I
66006 PARU(90+MSTU(90))=Z
66008 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
66009 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
66010 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
66011 & P(I,3).LE.0.001D0) THEN
66012 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
66018 C...Remaining flavour and momentum.
66027 C...Check if pL acceptable. Go back for new hadron if enough energy.
66028 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
66030 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
66032 IF(W.GT.PARJ(31)) GOTO 190
66035 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
66036 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
66038 C...Rotate jet to new direction.
66039 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
66040 PHI=PYANGL(P(IP1,1),P(IP1,2))
66042 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
66043 K(K(IP1,3),4)=NSAV1+1
66046 C...End of jet generation loop. Skip conservation in some cases.
66048 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
66049 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
66051 C...Subtract off produced hadron flavours, finished if zero.
66052 DO 240 I=NSAV+NJET+1,N
66054 KFLA=MOD(KFA/1000,10)
66055 KFLB=MOD(KFA/100,10)
66056 KFLC=MOD(KFA/10,10)
66058 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
66059 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
66061 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
66062 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
66063 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
66066 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66067 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66068 IF(NREQ.EQ.0) GOTO 320
66070 C...Take away flavour of low-momentum particles until enough freedom.
66074 DO 260 I=NSAV+NJET+1,N
66075 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
66076 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
66077 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
66079 IF(IREM.EQ.0) GOTO 150
66081 KFA=IABS(K(IREM,2))
66082 KFLA=MOD(KFA/1000,10)
66083 KFLB=MOD(KFA/100,10)
66084 KFLC=MOD(KFA/10,10)
66085 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
66086 IF(K(IREM,1).EQ.8) GOTO 250
66088 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
66089 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
66090 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
66092 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
66093 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
66094 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
66097 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66098 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66099 IF(NREQ.GT.NREM) GOTO 250
66100 DO 270 I=NSAV+NJET+1,N
66101 IF(K(I,1).EQ.8) K(I,1)=1
66104 C...Find combination of existing and new flavours for hadron.
66106 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
66107 IF(NREQ.LT.NREM) NFET=1
66108 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
66110 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
66111 KFLF(J)=ISIGN(1,NFL(1))
66112 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
66113 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
66115 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
66117 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
66118 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
66119 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
66120 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
66121 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
66122 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
66123 IF(NFET.LE.2) KFLF(3)=0
66124 IF(KFLF(3).NE.0) THEN
66125 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
66126 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
66127 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
66128 & KFLFC=KFLFC+ISIGN(2,KFLFC)
66132 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
66133 IF(KF.EQ.0) GOTO 280
66134 DO 300 J=1,MAX(2,NFET)
66135 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
66138 C...Store hadron at random among free positions.
66139 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
66140 DO 310 I=NSAV+NJET+1,N
66141 IF(K(I,1).EQ.7) NPOS=NPOS-1
66142 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
66145 P(I,5)=PYMASS(K(I,2))
66146 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66149 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66150 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66151 IF(NREM.GT.0) GOTO 280
66153 C...Compensate for missing momentum in global scheme (3 options).
66154 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
66157 DO 330 I=NSAV+NJET+1,N
66158 PSI(J)=PSI(J)+P(I,J)
66161 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
66163 DO 350 I=NSAV+NJET+1,N
66164 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
66165 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
66166 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
66167 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
66169 DO 370 I=NSAV+NJET+1,N
66170 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
66171 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
66172 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
66173 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
66175 P(I,J)=P(I,J)-PSI(J)*PW/PWS
66177 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66180 C...Compensate for missing momentum withing each jet separately.
66181 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
66182 DO 390 I=N+1,N+NJET
66188 DO 410 I=NSAV+NJET+1,N
66191 K(IR2,1)=K(IR2,1)+1
66192 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
66193 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
66195 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
66197 P(IR2,4)=P(IR2,4)+P(I,4)
66198 P(IR2,5)=P(IR2,5)+PLS
66201 DO 420 I=N+1,N+NJET
66202 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
66204 DO 440 I=NSAV+NJET+1,N
66207 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
66208 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
66210 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
66213 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66217 C...Scale momenta for energy conservation.
66218 IF(MOD(MSTJ(3),5).NE.0) THEN
66222 DO 450 I=NSAV+NJET+1,N
66225 PQS=PQS+P(I,5)**2/P(I,4)
66227 IF(PMS.GE.PECM) GOTO 150
66230 PFAC=(PECM-PQS)/(PES-PQS)
66233 DO 480 I=NSAV+NJET+1,N
66237 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66239 PQS=PQS+P(I,5)**2/P(I,4)
66241 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
66244 C...Origin of produced particles and parton daughter pointers.
66245 490 DO 500 I=NSAV+NJET+1,N
66246 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
66247 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
66249 DO 510 I=NSAV+1,NSAV+NJET
66252 IF(MSTU(16).NE.2) THEN
66256 K(I1,4)=K(I1,4)-NJET+1
66257 K(I1,5)=K(I1,5)-NJET+1
66258 IF(K(I1,5).LT.K(I1,4)) THEN
66265 C...Document independent fragmentation system. Remove copy of jets.
66276 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
66278 DO 540 I=NSAV+NJET,N
66280 K(I-NJET+1,J)=K(I,J)
66281 P(I-NJET+1,J)=P(I,J)
66282 V(I-NJET+1,J)=V(I,J)
66286 DO 550 IZ=MSTU90+1,MSTU(90)
66287 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
66290 C...Boost back particle system. Set production vertices.
66291 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
66292 &DPS(2)/DPS(4),DPS(3)/DPS(4))
66302 C*********************************************************************
66305 C...Handles the decay of unstable particles.
66307 SUBROUTINE PYDECY(IP)
66309 C...Double precision and integer declarations.
66310 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
66311 IMPLICIT INTEGER(I-N)
66312 INTEGER PYK,PYCHGE,PYCOMP
66314 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
66315 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
66316 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
66317 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
66318 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
66320 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
66321 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
66323 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
66325 C...Functions: momentum in two-particle decays and four-product.
66326 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
66327 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)
66329 C...Initial values.
66333 KFS=ISIGN(1,K(IP,2))
66337 C...Choose lifetime and determine decay vertex.
66338 IF(K(IP,1).EQ.5) THEN
66340 ELSEIF(K(IP,1).NE.4) THEN
66341 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
66344 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
66347 C...Determine whether decay allowed or not.
66349 IF(MSTJ(22).EQ.2) THEN
66350 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
66351 ELSEIF(MSTJ(22).EQ.3) THEN
66352 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
66353 ELSEIF(MSTJ(22).EQ.4) THEN
66354 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
66355 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
66357 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
66362 C...Interface to external tau decay library (for tau polarization).
66363 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
66365 C...Starting values for pointers and momenta.
66369 PCMTAU(J)=P(ITAU,J)
66372 C...Iterate to find position and code of mother of tau.
66374 120 IMTAU=K(IMTAU,3)
66376 IF(IMTAU.EQ.0) THEN
66377 C...If no known origin then impossible to do anything further.
66381 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
66382 C...If tau -> tau + gamma then add gamma energy and loop.
66383 IF(K(K(IMTAU,4),2).EQ.22) THEN
66385 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
66387 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
66389 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
66394 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
66395 C...If coming from weak decay of hadron then W is not stored in record,
66396 C...but can be reconstructed by adding neutrino momentum.
66397 KFORIG=-ISIGN(24,K(ITAU,2))
66399 DO 160 II=K(IMTAU,4),K(IMTAU,5)
66400 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
66402 PCMTAU(J)=PCMTAU(J)+P(II,J)
66408 C...If coming from resonance decay then find latest copy of this
66409 C...resonance (may not completely agree).
66412 DO 170 II=IMTAU+1,IP-1
66413 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
66414 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
66417 PCMTAU(J)=P(IORIG,J)
66421 C...Boost tau to rest frame of production process (where known)
66422 C...and rotate it to sit along +z axis.
66424 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
66426 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
66427 & -DBETAU(2),-DBETAU(3))
66428 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
66429 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
66430 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
66431 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
66433 C...Call tau decay routine (if meaningful) and fill extra info.
66434 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
66435 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
66436 DO 200 II=NSAV+1,NSAV+NDECAY
66445 C...Boost back decay tau and decay products.
66449 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
66450 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
66451 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
66452 & DBETAU(2),DBETAU(3))
66454 C...Skip past ordinary tau decay treatment.
66462 C...B-Bbar mixing: flip sign of meson appropriately.
66464 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
66466 IF(KFA.EQ.531) XBBMIX=PARJ(77)
66467 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
66468 IF(MMIX.EQ.1) KFS=-KFS
66471 C...Check existence of decay channels. Particle/antiparticle rules.
66473 IF(MDCY(KC,2).GT.0) THEN
66474 MDMDCY=MDME(MDCY(KC,2),2)
66475 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
66477 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
66478 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
66481 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
66482 IF(KCHG(KC,3).EQ.0) THEN
66485 IF(PYR(0).GT.0.5D0) KFS=-KFS
66486 ELSEIF(KFS.GT.0) THEN
66494 C...Sum branching ratios of allowed decay channels.
66497 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
66498 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
66499 & KFSN*MDME(IDL,1).NE.3) GOTO 230
66500 IF(MDME(IDL,2).GT.100) GOTO 230
66502 BRSU=BRSU+BRAT(IDL)
66505 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
66509 C...Select decay channel among allowed ones.
66510 240 RBR=BRSU*PYR(0)
66513 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
66514 &KFSN*MDME(IDL,1).NE.3) THEN
66515 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
66516 ELSEIF(MDME(IDL,2).GT.100) THEN
66517 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
66521 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
66524 C...Start readout of decay channel: matrix element, reset counters.
66527 IF(MOD(NTRY,200).EQ.0) THEN
66528 WRITE(CIDC,'(I4)') IDC
66529 C...Do not print warning for some well-known special cases.
66530 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
66531 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
66535 IF(NTRY.GT.1000) THEN
66536 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
66537 IF(MSTU(21).GE.1) RETURN
66543 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
66546 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
66548 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
66554 IF(KFA.GT.80) MHADDY=1
66555 C.. Random flavour and popcorn system memory.
66561 C...Read out decay products. Convert to standard flavour code.
66563 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
66565 IF(JT.LE.5) KP=KFDP(IDC,JT)
66566 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
66567 IF(KP.EQ.0) GOTO 280
66570 IF(KPA.GT.80) MHADDY=1
66571 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
66573 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
66575 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
66576 KFP=-KFS*MOD(KFA/10,10)
66577 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
66578 KFP=KFS*(100*MOD(KFA/10,100)+3)
66579 ELSEIF(KPA.EQ.81) THEN
66580 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
66581 ELSEIF(KP.EQ.82) THEN
66582 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
66583 IF(KFP.EQ.0) GOTO 260
66587 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
66588 ELSEIF(KP.EQ.-82) THEN
66591 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
66593 C...Add decay product to event record or to quark flavour list.
66596 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
66599 C...set rndmflav popcorn system pointer
66600 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
66602 PSQ=PSQ+PYMASS(KFLO(NQ))
66603 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
66604 & MOD(NQ,2).EQ.1) THEN
66609 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
66610 IF(K(I,2).EQ.0) GOTO 260
66612 P(I,5)=PYMASS(K(I,2))
66617 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
66618 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
66620 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
66621 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
66631 C...Check masses for resonance decays.
66632 IF(MHADDY.EQ.0) THEN
66633 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
66636 C...Choose decay multiplicity in phase space model.
66637 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
66639 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
66640 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
66642 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
66643 IF(IRNDMO.EQ.0) THEN
66646 ELSEIF(IRNDMO.EQ.1) THEN
66651 IF(NTRY.GT.1000) THEN
66652 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
66653 IF(MSTU(21).GE.1) RETURN
66655 IF(MMAT.LE.20) THEN
66656 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
66657 & SIN(PARU(2)*PYR(0))
66658 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
66659 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
66660 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
66661 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
66662 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
66666 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
66668 IF(MSTU(121).GT.MSTU(125)) GOTO 300
66670 C...Form hadrons from flavour content.
66674 IF(ND.EQ.NP+NQ/2) GOTO 330
66675 DO 320 I=N+NP+1,N+ND-NQ/2
66676 C.. Stick to started popcorn system, else pick side at random
66678 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
66679 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
66680 IF(K(I,2).EQ.0) GOTO 300
66681 MSTU(125)=MSTU(125)-1
66683 IF(MSTU(121).GT.0) JTMO=JT
66689 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
66690 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
66691 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
66694 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
66695 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
66696 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
66697 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
66699 C...Check that sum of decay product masses not too large.
66701 DO 340 I=N+NP+1,N+ND
66706 P(I,5)=PYMASS(K(I,2))
66709 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
66711 C...Rescale energy to subtract off spectator quark mass.
66712 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
66713 & .AND.NP.GE.3) THEN
66715 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
66717 P(N+NP,J)=PQT*PV(1,J)
66718 PV(1,J)=(1D0-PQT)*PV(1,J)
66720 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
66724 C...Fully specified final state: check mass broadening effects.
66726 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
66730 C...Determine position of grandmother, number of sisters.
66736 IF(IM.LT.0.OR.IM.GE.IP) IM=0
66737 IF(IM.NE.0) KFAM=IABS(K(IM,2))
66739 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
66740 IF(K(IL,3).EQ.IM) NM=NM+1
66741 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
66743 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
66744 & MOD(KFAM/1000,10).NE.0) NM=0
66746 KFAS=IABS(K(ISIS,2))
66747 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
66748 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
66753 C...Kinematics of one-particle decays.
66761 C...Calculate maximum weight ND-particle decay.
66764 WTMAX=1D0/WTCOR(ND-2)
66765 PMAX=PV(1,5)-PS+P(N+ND,5)
66767 DO 380 IL=ND-1,1,-1
66768 PMAX=PMAX+P(N+IL,5)
66769 PMIN=PMIN+P(N+IL+1,5)
66770 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
66774 C...Find virtual gamma mass in Dalitz decay.
66775 390 IF(ND.EQ.2) THEN
66776 ELSEIF(MMAT.EQ.2) THEN
66777 PMES=4D0*PMAS(11,1)**2
66778 PMRHO2=PMAS(131,1)**2
66779 PGRHO2=PMAS(131,2)**2
66780 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
66781 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
66782 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
66783 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
66784 IF(WT.LT.PYR(0)) GOTO 400
66785 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
66787 C...M-generator gives weight. If rejected, try again.
66792 DO 420 IL2=IL1-1,1,-1
66793 IF(RSAV.LE.RORD(IL2)) GOTO 430
66794 RORD(IL2+1)=RORD(IL2)
66796 430 RORD(IL2+1)=RSAV
66800 DO 450 IL=ND-1,1,-1
66801 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
66803 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
66805 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
66808 C...Perform two-particle decays in respective CM frame.
66809 460 DO 480 IL=1,ND-1
66810 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
66811 UE(3)=2D0*PYR(0)-1D0
66813 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
66814 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
66817 PV(IL+1,J)=-PA*UE(J)
66819 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
66820 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
66823 C...Lorentz transform decay products to lab frame.
66827 DO 530 IL=ND-1,1,-1
66829 BE(J)=PV(IL,J)/PV(IL,4)
66831 GA=PV(IL,4)/PV(IL,5)
66833 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
66835 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
66837 P(I,4)=GA*(P(I,4)+BEP)
66841 C...Check that no infinite loop in matrix element weight.
66843 IF(NTRY.GT.800) GOTO 560
66845 C...Matrix elements for omega and phi decays.
66847 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
66848 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
66849 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
66850 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
66852 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
66853 ELSEIF(MMAT.EQ.2) THEN
66854 FOUR12=FOUR(N+1,N+2)
66855 FOUR13=FOUR(N+1,N+3)
66856 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
66857 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
66858 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
66860 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
66861 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
66862 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
66863 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
66865 FOUR12=FOUR(IP,N+1)
66866 FOUR02=FOUR(IM,N+1)
66870 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
66871 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
66872 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
66873 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
66874 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
66875 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
66877 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
66878 ELSEIF(MMAT.EQ.4) THEN
66879 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
66880 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
66881 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
66882 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
66883 & ((1D0-HX3)/(HX1*HX2))**2
66884 IF(WT.LT.2D0*PYR(0)) GOTO 390
66885 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
66888 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
66889 ELSEIF(MMAT.EQ.41) THEN
66890 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
66891 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
66892 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
66893 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
66895 C...Matrix elements for weak decays (only semileptonic for c and b)
66896 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
66897 & .AND.ND.EQ.3) THEN
66898 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
66899 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
66900 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
66901 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
66905 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
66908 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
66909 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
66910 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
66913 C...Scale back energy and reattach spectator.
66914 560 IF(MREM.EQ.1) THEN
66916 PV(1,J)=PV(1,J)/(1D0-PQT)
66922 C...Low invariant mass for system with spectator quark gives particle,
66923 C...not two jets. Readjust momenta accordingly.
66924 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
66926 PM2=PYMASS(K(N+2,2))
66928 PM3=PYMASS(K(N+3,2))
66929 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
66930 & (PARJ(32)+PM2+PM3)**2) GOTO 630
66933 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
66934 IF(K(N+2,2).EQ.0) GOTO 260
66935 P(N+2,5)=PYMASS(K(N+2,2))
66936 PS=P(N+1,5)+P(N+2,5)
66941 ELSEIF(MMAT.EQ.44) THEN
66943 PM3=PYMASS(K(N+3,2))
66945 PM4=PYMASS(K(N+4,2))
66946 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
66947 & (PARJ(32)+PM3+PM4)**2) GOTO 600
66950 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
66951 IF(K(N+3,2).EQ.0) GOTO 260
66952 P(N+3,5)=PYMASS(K(N+3,2))
66954 P(N+3,J)=P(N+3,J)+P(N+4,J)
66956 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)
66957 HA=P(N+1,4)**2-P(N+2,4)**2
66958 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
66959 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
66960 & (P(N+1,3)-P(N+2,3))**2
66961 HD=(PV(1,4)-P(N+3,4))**2
66962 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
66965 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
66967 PCOR=HH*(P(N+1,J)-P(N+2,J))
66968 P(N+1,J)=P(N+1,J)+PCOR
66969 P(N+2,J)=P(N+2,J)-PCOR
66971 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)
66972 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)
66976 C...Check invariant mass of W jets. May give one particle or start over.
66977 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
66978 &.AND.IABS(K(N+1,2)).LT.10) THEN
66979 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
66981 PM1=PYMASS(K(N+1,2))
66983 PM2=PYMASS(K(N+2,2))
66984 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
66985 KFLDUM=INT(1.5D0+PYR(0))
66986 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
66987 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
66988 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
66989 PSM=PYMASS(KF1)+PYMASS(KF2)
66990 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
66991 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
66992 IF(MMAT.EQ.48) GOTO 390
66993 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
66996 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
66997 IF(K(N+1,2).EQ.0) GOTO 260
66998 P(N+1,5)=PYMASS(K(N+1,2))
67001 PS=P(N+1,5)+P(N+2,5)
67002 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
67009 C...Phase space decay of partons from W decay.
67010 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
67016 PV(1,J)=P(N+1,J)+P(N+2,J)
67025 PSQ=PYMASS(KFLO(1))
67027 PSQ=PSQ+PYMASS(KFLO(2))
67032 C...Boost back for rapidly moving particle.
67036 BE(J)=P(IP,J)/P(IP,4)
67040 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
67042 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
67044 P(I,4)=GA*(P(I,4)+BEP)
67048 C...Fill in position of decay vertex.
67056 C...Set up for parton shower evolution from jets.
67057 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
67061 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
67062 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
67063 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
67064 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
67065 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
67066 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
67068 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
67071 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
67072 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
67073 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
67074 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
67076 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
67077 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
67080 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
67081 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
67082 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
67083 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
67085 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
67086 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
67088 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
67093 KCP=PYCOMP(K(NSAV+1,2))
67094 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
67096 IF(KQP.LT.0) JCON=5
67097 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
67098 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
67099 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
67100 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
67102 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
67105 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
67106 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
67107 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
67108 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
67112 C...Mark decayed particle; special option for B-Bbar mixing.
67113 IF(K(IP,1).EQ.5) K(IP,1)=15
67114 IF(K(IP,1).LE.10) K(IP,1)=11
67115 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
67123 C*********************************************************************
67126 C...Handles flavour production in the decay of unstable particles
67127 C...and small string clusters.
67129 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
67131 C...Double precision and integer declarations.
67132 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67133 IMPLICIT INTEGER(I-N)
67134 INTEGER PYK,PYCHGE,PYCOMP
67136 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67137 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67138 SAVE /PYDAT1/,/PYDAT2/
67141 C.. Call PYKFDI directly if no popcorn option is on
67142 IF(MSTJ(12).LT.2) THEN
67143 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
67150 IF(KFL1.EQ.0) RETURN
67155 NMAX=MIN(MSTU(125),10)
67157 C.. Identify rank 0 cluster qq
67159 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
67162 C.. Join jets: Fails if store not empty
67163 IF(MSTU(121).GT.0) THEN
67167 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
67168 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
67169 C.. Pick popcorn meson from store, return same qq, decrease store
67170 KF=MSTU(NSTO+MSTU(121))
67172 MSTU(121)=MSTU(121)-1
67174 C.. Generate new flavour. Then done if no diquark is generated
67175 100 CALL PYKFDI(KFL1,0,KFL3,KF)
67176 IF(MSTU(121).EQ.-1) GOTO 100
67178 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
67180 C.. Simple case if no dynamical popcorn suppressions are considered
67181 IF(MSTJ(12).LT.4) THEN
67182 IF(MSTU(121).EQ.0) RETURN
67185 CALL PYKFDI(KFPREV,0,KFL3,KFM)
67186 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
67187 IF(IABS(KFL3).LE.10)THEN
67194 C test output qq against fake Gamma, then return if no popcorn.
67197 CALL PYZDIS(1,2103,5D0,Z)
67199 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
67204 IF(MSTU(121).EQ.0) RETURN
67206 C..Set store size memory. Pick fake dynamical variables of qq.
67208 CALL PYPTDI(1,PX3,PY3)
67214 C.. Pick next popcorn meson, test with fake dynamical variables
67218 CALL PYKFDI(KFPREV,0,KFL3,KFM)
67219 IF(MSTU(121).EQ.-1) GOTO 100
67220 CALL PYPTDI(KFL3,PX3,PY3)
67221 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
67222 CALL PYZDIS(KFPREV,KFL3,PM,Z)
67229 IF(MSTJ(12).GT.4)THEN
67230 POPMN=SQRT((1D0-X)*(G/X-GB))
67231 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
67232 PTST=EXP((POPM-POPMN)*PARF(193))
67237 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
67240 IF(RTST.GT.PTST*GTST)THEN
67242 IF(RTST.GT.PTST) MSTU(121)=-1
67247 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
67248 IF(MSTU(121).GT.0) GOTO 110
67250 C.. Test accepted system size. If OK set global popcorn size variable.
67251 IF(NMES.GT.NMAX)THEN
67262 C********************************************************************
67265 C...Generates a new flavour pair and combines off a hadron
67267 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
67269 C...Double precision and integer declarations.
67270 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67271 IMPLICIT INTEGER(I-N)
67272 INTEGER PYK,PYCHGE,PYCOMP
67274 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67275 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67276 SAVE /PYDAT1/,/PYDAT2/
67280 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
67282 C...Default flavour values. Input consistency checks.
67287 IF(KF1A.EQ.0) RETURN
67289 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
67290 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
67291 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
67294 C...Check if tabulated flavour probabilities are to be used.
67295 IF(MSTJ(15).EQ.1) THEN
67296 IF(MSTJ(12).GE.5) CALL PYERRM(29,
67297 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
67298 & ' together with MSTJ(12)>=5 modification')
67300 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
67301 KFL1A=MOD(KF1A/1000,10)
67302 KFL1B=MOD(KF1A/100,10)
67304 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
67305 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
67306 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
67307 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
67311 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
67312 KFL2A=MOD(KF2A/1000,10)
67313 KFL2B=MOD(KF2A/100,10)
67315 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
67316 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
67317 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
67319 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
67322 C.. Recognize rank 0 diquark case
67324 KFDIQ=MAX(KF1A,KF2A)
67325 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
67327 C.. Join two flavours to meson or baryon. Test for popcorn.
67330 IF(KFDIQ.GT.10) THEN
67331 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
67332 & CALL PYNMES(KFDIQ)
67333 IF(MSTU(121).NE.0) THEN
67344 C.. Separate incoming flavours, curtain flavour consistency check
67350 KFL1A=MOD(KF1A/1000,10)
67351 KFL1B=MOD(KF1A/100,10)
67354 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
67355 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
67356 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
67358 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
67362 KFQOLD=KFL1A+KFL1B-KFQPOP
67365 C...Meson/baryon choice. Set number of mesons if starting a popcorn
67368 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
67369 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
67373 ELSEIF(KF1A.GT.10)THEN
67375 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
67376 IF(MSTU(121).GT.0) MBARY=-1
67379 C..x->H+q: Choose single vertex quark. Jump to form hadron.
67380 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
67381 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
67382 KFL3=ISIGN(KFQVER,-KFIN)
67386 C..x->H+qq: (IDW=proper PARF position for diquark weights)
67389 IF(MSTU(121).EQ.0) IDW=150
67391 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
67392 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
67393 C.. Shift to s-curtain parameters if needed
67394 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
67395 PARF(194)=PARF(138)*PARF(139)
67396 PARF(193)=PARJ(8)+PARJ(9)
67400 C.. x->H+qq: Get vertex quark
67401 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
67403 MSTU(121)=MSTU(121)-1
67404 IF(IDW.EQ.170) THEN
67405 IF(MSTU(121).EQ.0)THEN
67406 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
67408 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
67411 IF(MSTU(121).EQ.0)THEN
67412 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
67414 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
67420 RMES=PYR(0)*PARF(194)
67422 RMES=RMES-PARF(IPOS+IMES)
67423 IF(IMES.EQ.30) THEN
67428 IF(RMES.GT.0D0) GOTO 120
67431 IF(KMUL.EQ.2) KFJ=10003
67432 IF(KMUL.EQ.3) KFJ=10001
67433 IF(KMUL.EQ.4) KFJ=20003
67434 IF(KMUL.EQ.5) KFJ=5
67436 KFQVER=MOD(IMES,5)+1
67437 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
67438 IF(KFQVER.GT.3)THEN
67443 IF(MBARY.EQ.-1) IDW=170
67445 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
67446 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
67447 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
67448 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
67450 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
67454 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
67456 IF(KFQPOP.NE.KFQVER)THEN
67458 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
67459 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
67460 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
67462 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
67464 KFL3=ISIGN(KFDIQ,KFIN)
67466 C..x->M+y: flavour for meson.
67467 130 IF(MBARY.LE.0)THEN
67468 KFLA=MAX(KFQOLD,KFQVER)
67469 KFLB=MIN(KFQOLD,KFQVER)
67471 IF(KFLA.NE.KFQOLD) KFS=-KFS
67472 C... Form meson, with spin and flavour mixing for diagonal states.
67473 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
67474 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
67475 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
67478 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
67479 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
67480 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
67481 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
67482 IF(PYR(0).LT.PARJ(14)) KMUL=2
67483 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
67485 IF(RMUL.LT.PARJ(15)) KMUL=3
67486 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
67487 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
67490 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
67491 IF(KMUL.EQ.5) KFLS=5
67492 IF(KFLA.NE.KFLB)THEN
67493 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
67496 IMIX=2*KFLA+10*KMUL
67497 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
67498 & INT(RMIX+PARF(IMIX)))+KFLS
67499 IF(KFLA.GE.4) KF=110*KFLA+KFLS
67501 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
67502 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
67504 C..Optional extra suppression of eta and eta'.
67505 C..Allow shift to qq->B+q in old version (set IRANK to 0)
67506 IF(KF.EQ.221.OR.KF.EQ.331)THEN
67507 IF(PYR(0).GT.PARJ(25+KF/300))THEN
67508 IF(KF2A.GT.0) GOTO 130
67509 IF(MSTJ(12).LT.4) IRANK=0
67515 C.. x->B+y: Flavour for baryon
67518 IF(KF1A.LE.10) KFLA=KFQOLD
67519 KFLB=MOD(KFDIQ/1000,10)
67520 KFLC=MOD(KFDIQ/100,10)
67521 KFLDS=MOD(KFDIQ,10)
67522 KFLD=MAX(KFLA,KFLB,KFLC)
67523 KFLF=MIN(KFLA,KFLB,KFLC)
67524 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
67526 C... SU(6) factors for formation of baryon.
67530 IF(KFLB.NE.KFLC)THEN
67533 IF(KFLB.GT.2) KDMAX=KDMAX+2
67535 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
67540 SU6MAX=PARF(140+KDMAX)
67543 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
67548 SU6OCT=PARF(60+KBARY)
67549 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
67550 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
67551 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
67553 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
67555 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
67557 C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
67558 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
67560 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
67564 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
67567 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
67568 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
67570 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
67572 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
67573 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
67577 C...Use tabulated probabilities to select new flavour and hadron.
67578 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
67581 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
67584 ELSEIF(KTAB2.EQ.0) THEN
67593 DO 150 KT3=KT3L,KT3U
67594 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
67600 DO 170 KT3=KT3L,KT3U
67602 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
67603 IF(RFL.LE.0D0) GOTO 190
67608 C...Reconstruct flavour of produced quark/diquark.
67609 IF(KTAB3.LE.6) THEN
67612 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
67615 IF(KTAB3.GE.8) KFL3A=2
67616 IF(KTAB3.GE.11) KFL3A=3
67617 IF(KTAB3.GE.16) KFL3A=4
67618 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
67619 KFL3=1000*KFL3A+100*KFL3B+1
67620 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
67622 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
67625 C...Reconstruct meson code.
67626 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
67628 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
67629 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
67631 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
67632 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
67633 & 25*KTABS)) KF=330+2*KTABS+1
67634 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
67635 KFLA=MAX(KTAB1,KTAB3)
67636 KFLB=MIN(KTAB1,KTAB3)
67638 IF(KFLA.NE.KF1A) KFS=-KFS
67639 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
67640 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
67642 IF(KFL1A.EQ.KFL3A) THEN
67643 KFLA=MAX(KFL1B,KFL3B)
67644 KFLB=MIN(KFL1B,KFL3B)
67645 IF(KFLA.NE.KFL1B) KFS=-KFS
67646 ELSEIF(KFL1A.EQ.KFL3B) THEN
67650 ELSEIF(KFL1B.EQ.KFL3A) THEN
67653 ELSEIF(KFL1B.EQ.KFL3B) THEN
67654 KFLA=MAX(KFL1A,KFL3A)
67655 KFLB=MIN(KFL1A,KFL3A)
67656 IF(KFLA.NE.KFL1A) KFS=-KFS
67658 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
67661 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
67663 C...Reconstruct baryon code.
67665 IF(KTAB1.GE.7) THEN
67674 KFLD=MAX(KFLA,KFLB,KFLC)
67675 KFLF=MIN(KFLA,KFLB,KFLC)
67676 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
67677 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
67678 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
67681 C...Check that constructed flavour code is an allowed one.
67682 IF(KFL2.NE.0) KFL3=0
67685 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
67693 C*********************************************************************
67696 C...Generates number of popcorn mesons and stores some relevant
67699 SUBROUTINE PYNMES(KFDIQ)
67701 C...Double precision and integer declarations.
67702 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67703 IMPLICIT INTEGER(I-N)
67704 INTEGER PYK,PYCHGE,PYCOMP
67706 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67707 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67708 SAVE /PYDAT1/,/PYDAT2/
67711 IF(MSTJ(12).LT.2) RETURN
67713 C..Old version: Get 1 or 0 popcorn mesons
67714 IF(MSTJ(12).LT.5)THEN
67716 IF(KFDIQ.NE.0) THEN
67718 KFA=MOD(KFDIQA/1000,10)
67719 KFB=MOD(KFDIQA/100,10)
67722 IF(KFA.EQ.3) POPWT=PARF(133)
67723 IF(KFB.EQ.3) POPWT=PARF(134)
67724 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
67726 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
67730 C..New version: Store popcorn- or rank 0 diquark parameters
67733 PARF(194)=PARF(139)
67734 IF(KFDIQ.NE.0) THEN
67737 PARF(194)=PARF(140)
67739 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
67740 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
67741 & '(PYNMES:) Neglecting too large popcorn possibility')
67745 C..New version: Get number of popcorn mesons
67748 110 MSTU(121)=MSTU(121)+1
67749 RTST=RTST/PARF(194)
67750 IF(RTST.LT.1D0) GOTO 110
67751 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
67752 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
67756 C***************************************************************
67759 C...Precalculates a set of diquark and popcorn weights.
67763 C...Double precision and integer declarations.
67764 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67765 IMPLICIT INTEGER(I-N)
67766 INTEGER PYK,PYCHGE,PYCOMP
67768 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67769 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67770 SAVE /PYDAT1/,/PYDAT2/
67772 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
67776 C..Diquark indices for dimensional variables
67785 C.. *** SU(6) factors **
67786 C..Modify with decuplet- (and Sigma/Lambda-) suppression.
67788 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
67789 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
67790 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
67793 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
67795 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
67796 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
67798 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
67799 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
67802 C..SU(6)max q q' s,c,b
67803 SU6MUD =MAX(SU6(1) , SU6(8) )
67804 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
67805 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
67806 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
67807 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
67808 SU6M(IUS0)=SU6M(ISU0)
67809 SU6M(ISS1)=SU6M(IUU1)
67810 SU6M(IUS1)=SU6M(ISU1)
67812 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
67814 PARF(142)=SU6M(IUD1)
67815 PARF(143)=SU6M(ISU0)
67816 PARF(144)=SU6M(ISU1)
67817 PARF(145)=SU6M(ISS1)
67819 C..diquark SU(6) survival =
67820 C..sum over quark (quark tunnel weight)*(SU(6)).
67821 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
67822 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
67823 DMB(IUS0)=DMB(ISU0)
67824 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
67825 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
67826 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
67827 DMB(IUS1)=DMB(ISU1)
67828 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
67830 C.. *** Tunneling factors for Diquark production***
67831 C.. T: half a curtain pair = sqrt(curtain pair factor)
67832 IF(MSTJ(12).GE.5) THEN
67834 PMUD1=PYMASS(2103)-PMUD0
67835 PMUS0=PYMASS(3201)-PMUD0
67836 PMUS1=PYMASS(3203)-PMUS0-PMUD0
67837 PMSS1=PYMASS(3303)-PMUS0-PMUD0
67838 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
67839 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
67840 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
67841 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
67842 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
67843 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
67844 QBB(IUD1)=QBB(IUU1)
67846 PAR2M=SQRT(PARJ(2))
67847 PAR3M=SQRT(PARJ(3))
67848 PAR4M=SQRT(PARJ(4))
67849 QBB(ISU0)=PAR2M*PAR3M
67851 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
67853 QBB(ISU1)=PAR4M*QBB(ISU0)
67854 QBB(IUS1)=PAR4M*QBB(IUS0)
67858 C.. tau: spin*(vertex factor)*(T = half-curtain factor)
67859 QBM(ISU0)=QBB(ISU0)
67860 QBM(IUS0)=PARJ(2)*QBB(IUS0)
67861 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
67862 QBM(IUU1)=6D0*QBB(IUU1)
67863 QBM(ISU1)=3D0*QBB(ISU1)
67864 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
67865 QBM(IUD1)=3D0*QBB(IUD1)
67867 C.. Combine T and tau to diquark weight for q-> B+B+..
67869 QBB(I)=QBB(I)*QBM(I)
67872 IF(MSTJ(12).GE.5)THEN
67873 C..New version: tau for rank 0 diquark.
67874 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
67875 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
67876 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
67877 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
67878 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
67879 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
67880 DMB(7+IUD1)=DMB(7+IUU1)/2D0
67882 C..New version: curtain flavour ratios.
67883 C.. s/u for q->B+M+...
67884 C.. s/u for rank 0 diquark: su -> ...M+B+...
67885 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67886 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
67887 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
67888 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
67889 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
67890 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
67891 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
67893 C..Old version: reset unused rank 0 diquark weights and
67894 C.. unused diquark SU(6) survival weights
67896 IF(MSTJ(12).LT.3) DMB(I)=1D0
67900 C..Old version: Shuffle PARJ(7) into tau
67901 QBM(IUS0)=QBM(IUS0)*PARJ(7)
67902 QBM(ISS1)=QBM(ISS1)*PARJ(7)
67903 QBM(IUS1)=QBM(IUS1)*PARJ(7)
67905 C..Old version: curtain flavour ratios.
67906 C.. s/u for q->B+M+...
67907 C.. s/u for rank 0 diquark: su -> ...M+B+...
67908 C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67909 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
67910 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
67911 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
67912 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
67915 C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
67916 C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
67918 DMB(7+I)=DMB(7+I)*DMB(I)
67919 DMB(I)=DMB(I)*QBM(I)
67920 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
67921 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
67924 C.. *** Popcorn factors ***
67926 IF(MSTJ(12).LT.5)THEN
67927 C.. Old version: Resulting popcorn weights.
67929 WS=PARF(135)*PARF(138)
67931 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
67933 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
67934 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
67935 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
67936 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
67937 & (1D0+QBB(IUD1)+QBB(IUU1)+
67938 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
67940 C..New version: Store weights for popcorn mesons,
67941 C..get prel. popcorn weights.
67942 DO 150 IPOS=201,1400
67951 IF(MR.EQ.7) PARF(193)=PARJ(10)
67952 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
67953 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
67954 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
67956 IF(NMES.EQ.1) SQWT=PARJ(2)
67958 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
67959 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
67960 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
67962 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
67963 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
67966 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
67968 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
67969 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
67975 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
67976 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
67977 IF(PJWT.LE.0D0) GOTO 190
67978 IF(PJWT.GT.1D0) PJWT=1D0
67980 IMIX=2*KFQOLD+10*KMUL
67982 IF(KMUL.EQ.2) KFJ=10003
67983 IF(KMUL.EQ.3) KFJ=10001
67984 IF(KMUL.EQ.4) KFJ=20003
67985 IF(KMUL.EQ.5) KFJ=5
67987 KFLA=MAX(KFQOLD,KFQVER)
67988 KFLB=MIN(KFQOLD,KFQVER)
67989 SWT=PARJ(11+KFLA/3+KFLA/4)
67990 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
67992 QWT=SQWT/(2D0+SQWT)
67993 IF(KFQVER.LT.3)THEN
67994 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
67995 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
67997 IF(KFQVER.NE.KFQOLD)THEN
67999 KFM=100*KFLA+10*KFLB+KFJ
68000 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68001 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
68002 WTTOT=WTTOT+PARF(IPOS+IMES)
68005 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
68006 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
68007 IF(ID.EQ.5) DWT=PARF(IMIX)
68009 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68010 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
68011 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
68012 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
68013 PARF(IPOS+5*KMUL+ID)=
68014 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
68016 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
68022 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
68024 IF(MR.EQ.7) PARF(140)=
68025 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
68026 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
68027 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
68033 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
68038 C..Recombine diquark weights to flavour and spin ratios
68039 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
68040 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
68041 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
68042 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
68043 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
68044 PARF(155)=QBB(ISU1)/QBB(ISU0)
68045 PARF(156)=QBB(IUS1)/QBB(IUS0)
68046 PARF(157)=QBB(IUD1)
68048 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
68049 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
68050 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
68051 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
68052 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
68053 PARF(165)=QBM(ISU1)/QBM(ISU0)
68054 PARF(166)=QBM(IUS1)/QBM(IUS0)
68055 PARF(167)=QBM(IUD1)
68057 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
68058 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
68059 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
68060 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
68061 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
68062 PARF(175)=DMB(ISU1)/DMB(ISU0)
68063 PARF(176)=DMB(IUS1)/DMB(IUS0)
68064 PARF(177)=DMB(IUD1)
68066 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
68067 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
68068 PARF(187)=DMB(7+IUD1)
68074 C*********************************************************************
68077 C...Generates transverse momentum according to a Gaussian.
68079 SUBROUTINE PYPTDI(KFL,PX,PY)
68081 C...Double precision and integer declarations.
68082 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68083 IMPLICIT INTEGER(I-N)
68084 INTEGER PYK,PYCHGE,PYCOMP
68086 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68089 C...Generate p_T and azimuthal angle, gives p_x and p_y.
68091 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
68092 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
68093 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
68094 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
68102 C*********************************************************************
68105 C...Generates the longitudinal splitting variable z.
68107 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
68109 C...Double precision and integer declarations.
68110 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68111 IMPLICIT INTEGER(I-N)
68112 INTEGER PYK,PYCHGE,PYCOMP
68114 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68115 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68116 SAVE /PYDAT1/,/PYDAT2/
68118 C...Check if heavy flavour fragmentation.
68122 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
68124 C...Lund symmetric scaling function: determine parameters of shape.
68125 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
68126 &MSTJ(11).GE.4) THEN
68128 IF(MSTJ(91).EQ.1) FA=PARJ(43)
68129 IF(KFLB.GE.10) FA=FA+PARJ(45)
68131 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
68134 IF(KFLA.GE.10) FC=FC-PARJ(45)
68135 IF(KFLB.GE.10) FC=FC+PARJ(45)
68136 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
68138 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
68139 FC=FC+FRED*FBB*PARF(100+KFLH)**2
68142 IF(ABS(FC-1D0).GT.0.01D0) MC=2
68144 C...Determine position of maximum. Special cases for a = 0 or a = c.
68145 IF(FA.LT.0.02D0) THEN
68148 IF(FC.GT.FB) ZMAX=FB/FC
68149 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
68154 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
68155 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
68158 C...Subdivide z range if distribution very peaked near endpoint.
68160 IF(ZMAX.LT.0.1D0) THEN
68166 ZDIVC=ZDIV**(1D0-FC)
68167 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
68169 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
68171 FSCB=SQRT(4D0+(FC/FB)**2)
68172 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
68173 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
68174 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
68175 FINT=1D0+FB*(1D0-ZDIV)
68178 C...Choice of z, preweighted for peaks at low or high z.
68182 IF(FINT*PYR(0).LE.1D0) THEN
68184 ELSEIF(MC.EQ.1) THEN
68188 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
68191 ELSEIF(MMAX.EQ.3) THEN
68192 IF(FINT*PYR(0).LE.1D0) THEN
68194 FPRE=EXP(FB*(Z-ZDIV))
68196 Z=ZDIV+Z*(1D0-ZDIV)
68200 C...Weighting according to correct formula.
68201 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
68202 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
68203 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
68204 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
68205 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
68207 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
68209 FC=PARJ(50+MAX(1,KFLH))
68210 IF(MSTJ(91).EQ.1) FC=PARJ(59)
68212 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
68213 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
68214 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
68215 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
68218 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
68219 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
68226 C*********************************************************************
68229 C...Generates timelike parton showers from given partons.
68231 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
68233 C...Double precision and integer declarations.
68234 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68235 IMPLICIT INTEGER(I-N)
68236 INTEGER PYK,PYCHGE,PYCOMP
68237 C...Parameter statement to help give large particle numbers.
68238 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
68239 &KEXCIT=4000000,KDIMEN=5000000)
68240 PARAMETER (MAXNUR=1000)
68242 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
68243 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
68244 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68245 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68246 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
68247 COMMON/PYINT1/MINT(400),VINT(400)
68248 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
68250 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
68251 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
68252 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
68253 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
68256 C...Check that QMAX not too low.
68257 IF(MSTJ(41).LE.0) THEN
68259 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
68260 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
68262 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
68266 C...Store positions of shower initiating partons.
68268 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
68271 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
68276 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
68277 & .AND.IP2.GE.-80) THEN
68282 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
68290 & '(PYSHOW:) failed to reconstruct showering system')
68291 IF(MSTU(21).GE.1) RETURN
68294 C...Send off to PYPTFS for pT-ordered evolution if requested,
68295 C...if at least 2 partons, and without predefined shower branchings.
68296 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
68301 PTPART(II)=0.5D0*QMAX
68303 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
68307 C...Initialization of cutoff masses etc.
68315 PMTH(1,21)=PYMASS(21)
68316 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
68317 PMTH(3,21)=2D0*PMTH(2,21)
68318 PMTH(4,21)=PMTH(3,21)
68319 PMTH(5,21)=PMTH(3,21)
68320 PMTH(1,22)=PYMASS(22)
68321 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
68322 PMTH(3,22)=2D0*PMTH(2,22)
68323 PMTH(4,22)=PMTH(3,22)
68324 PMTH(5,22)=PMTH(3,22)
68326 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
68327 PMQT1E=MIN(PMQTH1,PARJ(90))
68329 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
68330 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
68333 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
68335 PMTH(1,IFL)=PYMASS(IFL)
68336 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
68337 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
68338 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
68339 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
68342 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
68343 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
68344 PMTH(1,IFL)=PYMASS(IFL)
68345 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
68346 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
68347 PMTH(4,IFL)=PMTH(3,IFL)
68348 PMTH(5,IFL)=PMTH(3,IFL)
68350 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
68352 ALFM=LOG(PT2MIN/ALAMS)
68354 C...Check on phase space available for emission.
68362 KFLA(I)=IABS(K(IPA(I),2))
68364 C...Special cutoff masses for initial partons (may be a heavy quark,
68365 C...squark, ..., and need not be on the mass shell).
68367 IF(NPA.LE.1) IREF(I)=IR
68368 IF(NPA.GE.2) IREF(I+1)=IR
68372 IF(KFLA(I).LE.8) THEN
68374 IF(MSTJ(41).GE.2) ISCHG(IR)=1
68375 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
68376 & KFLA(I).EQ.17) THEN
68377 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
68378 ELSEIF(KFLA(I).EQ.21) THEN
68380 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
68381 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
68383 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
68386 C...same for QQ~[3S18]
68387 ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
68388 & KFLA(I).EQ.9900553)) THEN
68393 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
68394 C...(only intended for studying the effects of switching such rad on/off)
68395 IF (MSTJ(39).GT.0.AND.KFLA(I).EQ.MSTJ(39)) THEN
68400 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
68402 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
68403 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
68404 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
68405 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
68406 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
68407 ELSEIF(ISCOL(IR).EQ.1) THEN
68408 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
68409 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
68410 PMTH(4,IR)=PMTH(3,IR)
68411 PMTH(5,IR)=PMTH(3,IR)
68412 ELSEIF(ISCHG(IR).EQ.1) THEN
68413 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
68414 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
68415 PMTH(4,IR)=PMTH(3,IR)
68416 PMTH(5,IR)=PMTH(3,IR)
68418 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
68420 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
68422 PS(J)=PS(J)+P(IPA(I),J)
68425 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
68426 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
68427 IF(NPA.EQ.1) PS(5)=PS(4)
68428 IF(PS(5).LE.PM+PMQT1E) RETURN
68430 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
68433 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
68434 KFSRCE=IABS(K(K(IP1,3),2))
68436 IPAR1=MAX(1,K(IP1,3))
68437 IPAR2=MAX(1,K(IP2,3))
68438 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
68439 & KFSRCE=IABS(K(K(IPAR1,3),2))
68442 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
68443 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
68444 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
68445 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
68446 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
68447 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
68448 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
68449 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
68451 C...Identify two primary showerers.
68453 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
68454 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
68455 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
68456 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
68457 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
68458 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
68459 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
68460 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
68462 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
68463 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
68464 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
68465 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
68466 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
68467 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
68468 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
68469 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
68471 C...Order of showerers. Presence of gluino.
68472 ITYPMN=MIN(ITYPE1,ITYPE2)
68473 ITYPMX=MAX(ITYPE1,ITYPE2)
68475 IF(ITYPE1.GT.ITYPE2) IORD=2
68477 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
68479 C...Check if 3-jet matrix elements to be used.
68482 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
68483 IF(MSTJ(38).NE.0) THEN
68487 ELSEIF(MSTJ(47).GE.6) THEN
68493 C...Vector/axial vector -> q + qbar; q -> q + V.
68494 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
68495 & ITYPES.EQ.3)) THEN
68497 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
68499 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
68500 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
68501 C...gamma*/Z0: assume e+e- initial state if unknown.
68503 IF(KFSRCE.EQ.23) THEN
68504 IANNFL=K(K(IP1,3),3)
68505 IF(IANNFL.NE.0) THEN
68506 KANNFL=IABS(K(IANNFL,2))
68507 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
68510 AI=SIGN(1D0,EI+0.1D0)
68511 VI=AI-4D0*EI*PARU(102)
68512 EF=KCHG(KFLA(1),1)/3D0
68513 AF=SIGN(1D0,EF+0.1D0)
68514 VF=AF-4D0*EF*PARU(102)
68515 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
68518 SQWZ=PS(5)*PMAS(23,2)
68519 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
68520 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
68521 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
68522 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
68524 ALPHA=VECT/(VECT+AXIV)
68525 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
68528 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
68529 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
68531 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
68532 & ITYPES.EQ.1)) THEN
68535 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
68536 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
68538 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
68540 ELSEIF(KFSRCE.EQ.36) THEN
68543 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
68544 & ITYPES.EQ.1)) THEN
68547 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
68548 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
68549 & ITYPES.EQ.3)) THEN
68551 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
68552 & ITYPES.EQ.2)) THEN
68554 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
68556 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
68557 & ITYPES.EQ.2)) THEN
68560 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
68561 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
68562 & ITYPES.EQ.5)) THEN
68564 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
68565 & ITYPES.EQ.2)) THEN
68567 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
68568 & ITYPES.EQ.1)) THEN
68571 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
68572 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
68574 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
68575 & ITYPES.EQ.2)) THEN
68577 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
68578 & ITYPES.EQ.1)) THEN
68581 C...g -> ~g + ~g (eikonal approximation).
68582 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
68585 M3JC=5*ICLASS+ICOMBI
68589 C...Find if interference with initial state partons.
68591 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
68592 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
68593 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
68598 KCA=PYCOMP(KFLA(I))
68599 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
68601 IF(KCII(I).NE.0) THEN
68603 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
68604 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
68605 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
68607 IIIS(I,NIIS(I))=ICSI
68612 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
68615 C...Boost interfering initial partons to rest frame
68616 C...and reconstruct their polar and azimuthal angles.
68620 K(N+I,J)=K(IPA(I),J)
68621 P(N+I,J)=P(IPA(I),J)
68625 DO 230 I=3,2+NIIS(1)
68627 K(N+I,J)=K(IIIS(1,I-2),J)
68628 P(N+I,J)=P(IIIS(1,I-2),J)
68632 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
68634 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
68635 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
68639 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
68640 & -PS(2)/PS(4),-PS(3)/PS(4))
68641 PHI=PYANGL(P(N+1,1),P(N+1,2))
68642 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
68643 THE=PYANGL(P(N+1,3),P(N+1,1))
68644 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
68645 DO 260 I=3,2+NIIS(1)
68646 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
68647 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
68649 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
68650 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
68651 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
68652 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
68656 C...Boost 3 or more partons to their rest frame.
68657 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
68658 &-PS(2)/PS(4),-PS(3)/PS(4))
68660 C...Define imagined single initiator of shower for parton system.
68662 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
68663 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
68664 IF(MSTU(21).GE.1) RETURN
68683 C...Loop over partons that may branch.
68686 IF(NPA.EQ.1) IM=NS-1
68689 IF(IM.GT.N) GOTO 600
68692 IF(KSH(IR).EQ.0) GOTO 290
68693 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
68698 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
68699 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
68700 IF(MSTU(21).GE.1) RETURN
68703 C...Position of aunt (sister to branching parton).
68704 C...Origin and flavour of daughters.
68707 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
68708 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
68720 K(N+I,2)=K(IPA(I),2)
68722 ELSEIF(KFLM.NE.21) THEN
68725 IREF(N+1-NS)=IREF(IM-NS)
68726 IREF(N+2-NS)=IABS(K(N+2,2))
68727 ELSEIF(K(IM,5).EQ.21) THEN
68735 IREF(N+1-NS)=IABS(K(N+1,2))
68736 IREF(N+2-NS)=IABS(K(N+2,2))
68739 C...Reset flags on daughters and tries made.
68744 KFLD(IP)=IABS(K(N+IP,2))
68745 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
68749 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
68753 C...Maximum virtuality of daughters.
68756 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
68757 P(N+I,5)=MIN(QMAX,PS(5))
68759 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
68760 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
68763 IF(MSTJ(43).LE.2) PEM=V(IM,2)
68764 IF(MSTJ(43).GE.3) PEM=P(IM,4)
68765 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
68766 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
68767 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
68771 IF(ISI(I).EQ.1) THEN
68773 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
68775 V(N+I,5)=P(N+I,5)**2
68778 C...Choose one of the daughters for evolution.
68780 IF(NEP.EQ.1) INUM=1
68782 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
68785 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
68787 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
68793 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
68794 RPM=P(N+I,5)/PMSD(I)
68796 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
68804 C...Cancel choice of predetermined daughter already treated.
68807 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
68808 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
68809 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
68810 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
68811 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
68814 C...Store information on choice of evolving daughter.
68818 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
68821 KFL(I)=IABS(K(IEP(I),2))
68823 ITRY(INUM)=ITRY(INUM)+1
68824 IF(ITRY(INUM).GT.200) THEN
68825 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
68826 IF(MSTU(21).GE.1) RETURN
68830 IF(KSH(IR).EQ.0) GOTO 450
68831 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
68833 C...Check if evolution already predetermined for daughter.
68835 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
68836 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
68837 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
68838 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
68839 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
68841 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
68843 IF(IPSPD.NE.0) ISSET(INUM)=1
68846 C...Select side for interference with initial state partons.
68847 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
68850 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
68852 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
68853 IF(PYR(0).GT.0.5D0) ISII(III)=1
68854 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
68856 IF(PYR(0).GT.0.5D0) ISII(III)=2
68860 C...Calculate allowed z range.
68863 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
68866 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
68867 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
68869 IF(MOD(MSTJ(43),2).EQ.1) THEN
68871 ZCE=PMTH(2,22)/PMED
68872 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
68874 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
68875 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
68877 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
68878 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
68879 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
68882 ZCE=MIN(ZCE,0.49991D0)
68883 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
68884 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
68885 P(IEP(1),5)=PMTH(1,IR)
68886 V(IEP(1),5)=P(IEP(1),5)**2
68890 C...Integral of Altarelli-Parisi z kernel for QCD.
68891 C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
68892 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
68893 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
68895 C...Evolution of QQ~[3S18] state if MSTP(148)=1.
68896 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
68897 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
68898 FBR=6D0*LOG((1D0-ZC)/ZC)
68900 ELSEIF(MSTJ(49).EQ.0) THEN
68901 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
68902 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
68904 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
68905 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
68906 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
68907 ELSEIF(MSTJ(49).EQ.1) THEN
68908 FBR=(1D0-2D0*ZC)/3D0
68909 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
68911 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
68912 ELSEIF(KFL(1).EQ.21) THEN
68913 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
68915 FBR=2D0*LOG((1D0-ZC)/ZC)
68918 C...Reset QCD probability for colourless.
68919 IF(ISCOL(IR).EQ.0) FBR=0D0
68921 C...Integral of Altarelli-Parisi kernel for photon emission.
68923 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
68924 IF(KFL(1).LE.18) THEN
68925 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
68927 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
68930 C...Inner veto algorithm starts. Find maximum mass for evolution.
68931 410 PMS=V(IEP(1),5)
68936 IRI=IREF(IEP(I)-NS)
68937 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
68940 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
68943 C...Select mass for daughter in QCD evolution.
68945 DO 430 IFF=4,MSTJ(45)
68946 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
68948 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
68949 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
68950 C...Already predetermined choice.
68951 IF(IPSPD.NE.0) THEN
68952 PMSQCD=P(IPSPD,5)**2
68953 ELSEIF(FBR.LT.1D-3) THEN
68955 ELSEIF(MSTJ(44).LE.0) THEN
68956 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
68957 ELSEIF(MSTJ(44).EQ.1) THEN
68958 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
68960 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
68962 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
68963 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
68964 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
68968 C...Select mass for daughter in QED evolution.
68969 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
68970 C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
68971 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
68972 IF(FBRE.LT.1D-3) THEN
68975 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
68976 & (PARU(101)*FBRE)))
68978 C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
68979 PMSQED=PMSQED+PMTH(1,IR)**2
68980 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
68982 IF(PMSQED.GT.PMSQCD) THEN
68988 C...Check whether daughter mass below cutoff.
68989 P(IEP(1),5)=SQRT(V(IEP(1),5))
68990 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
68991 P(IEP(1),5)=PMTH(1,IR)
68992 V(IEP(1),5)=P(IEP(1),5)**2
68996 C...Already predetermined choice of z, and flavour in g -> qqbar.
68997 IF(IPSPD.NE.0) THEN
69000 PMSGD1=P(IPSGD1,5)**2
69001 PMSGD2=P(IPSGD2,5)**2
69002 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
69003 & 4D0*PMSGD1*PMSGD2))
69004 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
69005 & PMSGD1+PMSGD2)/ALAMPS
69006 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
69007 IF(KFL(1).NE.21) THEN
69010 K(IEP(1),5)=IABS(K(IPSGD1,2))
69013 C...Select z value of branching: q -> qgamma.
69014 ELSEIF(MCE.EQ.2) THEN
69015 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
69016 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
69020 C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
69021 ELSEIF(MSTJ(49).EQ.0.AND.
69022 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
69023 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69024 C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
69025 IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
69026 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
69030 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
69031 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
69032 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69033 C...Only do z weighting when no ME correction afterwards.
69034 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
69036 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
69037 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69038 IF(PYR(0).GT.0.5D0) Z=1D0-Z
69039 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
69041 ELSEIF(MSTJ(49).NE.1) THEN
69043 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
69044 KFLB=1+INT(MSTJ(45)*PYR(0))
69045 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
69046 IF(PMQ.GE.1D0) GOTO 410
69047 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
69048 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
69049 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
69050 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
69051 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
69053 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
69057 C...Ditto for scalar gluon model.
69058 ELSEIF(KFL(1).NE.21) THEN
69059 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
69061 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
69062 Z=ZC+(1D0-2D0*ZC)*PYR(0)
69065 Z=ZC+(1D0-2D0*ZC)*PYR(0)
69066 KFLB=1+INT(MSTJ(45)*PYR(0))
69067 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
69068 IF(PMQ.GE.1D0) GOTO 410
69072 C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
69073 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
69074 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
69075 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69076 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
69078 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
69079 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
69080 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
69081 IF(PT2APP.LT.PT2MIN) GOTO 410
69082 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
69086 C...Check if z consistent with chosen m.
69087 IF(KFL(1).EQ.21) THEN
69088 IRGD1=IABS(K(IEP(1),5))
69092 IRGD2=IABS(K(IEP(1),5))
69096 ELSEIF(NEP.GE.3) THEN
69098 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
69099 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
69101 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
69102 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
69104 IF(MOD(MSTJ(43),2).EQ.1) THEN
69105 PMQTH3=0.5D0*PARJ(82)
69106 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
69107 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
69108 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
69109 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
69110 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
69114 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
69117 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
69118 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69119 ELSEIF(IPSPD.NE.0) THEN
69123 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
69125 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
69127 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
69129 C...Width suppression for q -> q + g.
69130 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
69132 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
69136 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
69137 IF(MSTJ(40).EQ.1) THEN
69138 IF(CHI.LT.PYR(0)) GOTO 410
69139 ELSEIF(MSTJ(40).EQ.2) THEN
69140 IF(1D0-CHI.LT.PYR(0)) GOTO 410
69144 C...Three-jet matrix element correction.
69149 C...QED matrix elements: only for massless case so far.
69150 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
69151 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
69152 X2=1D0-V(IEP(1),5)/V(NS+1,5)
69153 X3=(1D0-X1)+(1D0-X2)
69155 KI2=K(IPA(3-INUM),2)
69156 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
69157 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
69158 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
69159 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
69160 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
69161 ELSEIF(MCE.EQ.2) THEN
69163 C...QCD matrix elements, including mass effects.
69164 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
69168 IF(IR.GE.31.AND.IGM.EQ.0) THEN
69169 C...QCD ME: original parton, first branching.
69170 PM2ME=PMTH(1,63-IR)
69172 ELSEIF(IR.GE.31) THEN
69173 C...QCD ME: original parton, subsequent branchings.
69174 PM2ME=PMTH(1,63-IR)
69175 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
69176 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69177 ELSEIF(K(IM,2).EQ.21) THEN
69178 C...QCD ME: secondary partons, first branching.
69181 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
69182 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
69183 & 4D0*PS1ME*PM2ME**2))
69184 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
69186 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69189 C...QCD ME: secondary partons, subsequent branchings.
69191 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
69192 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69195 C...Construct ME variables.
69198 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
69199 X2=1D0+R2ME**2-PS1ME/ECMME**2
69200 C...Call ME, with right order important for two inequivalent showerers.
69201 IF(IR.EQ.IORD+30) THEN
69202 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
69204 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
69206 C...Split up total ME when two radiating partons.
69208 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
69209 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
69210 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
69211 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
69212 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
69213 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
69214 & MAX(1D-10,2D0-X1-X2)
69215 C...Evaluate shower rate to be compared with.
69216 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
69217 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
69218 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
69219 ELSEIF(MSTJ(49).NE.1) THEN
69221 C...Toy model scalar theory matrix elements; no mass effects.
69223 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
69224 X2=1D0-V(IEP(1),5)/V(NS+1,5)
69225 X3=(1D0-X1)+(1D0-X2)
69226 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
69228 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
69232 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
69235 C...Impose angular ordering by rejection of nonordered emission.
69236 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
69237 PEMAO=V(IM,1)*P(IM,4)
69238 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
69239 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
69241 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
69242 & .OR.MSTJ(42).EQ.7)) THEN
69244 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
69245 & .OR.MSTJ(42).EQ.6)) THEN
69247 PMDAO=PMTH(2,K(IEP(1),5))
69248 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
69251 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
69252 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
69253 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
69257 440 IF(K(IAOM,5).EQ.22) THEN
69259 IF(K(IAOM,3).LE.NS) MAOM=0
69260 IF(MAOM.EQ.1) GOTO 440
69262 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
69263 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
69264 IF(THE2ID.LT.THE2IM) GOTO 410
69268 C...Impose user-defined maximum angle at first branching.
69269 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
69270 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
69271 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
69272 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
69273 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
69274 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
69275 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
69276 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
69277 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
69278 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
69282 C...Impose angular constraint in first branching from interference
69283 C...with initial state partons.
69284 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
69285 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
69286 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
69287 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
69288 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
69289 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
69293 C...End of inner veto algorithm. Check if only one leg evolved so far.
69297 IF(NEP.EQ.1) GOTO 490
69298 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
69301 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
69302 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
69306 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
69310 PMSUM=PMSUM+P(N+I,5)
69312 IF(PMSUM.GE.PS(5)) GOTO 350
69313 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
69316 IF(KSH(IRDA).EQ.0) GOTO 480
69317 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
69318 IF(IRDA.EQ.21) THEN
69319 IRGD1=IABS(K(I1,5))
69323 IRGD2=IABS(K(I1,5))
69326 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
69327 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
69329 IF(I1.EQ.N+1) ZM=V(IM,1)
69330 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
69331 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
69332 & 4D0*V(N+1,5)*V(N+2,5))
69333 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
69336 IF(MOD(MSTJ(43),2).EQ.1) THEN
69337 PMQTH3=0.5D0*PARJ(82)
69338 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
69339 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
69340 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
69341 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
69342 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
69346 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
69349 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
69350 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69354 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
69355 & ISSET(1).EQ.0) THEN
69357 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
69358 & ISSET(2).EQ.0) THEN
69362 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
69364 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
69366 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
69369 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
69370 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
69371 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
69372 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
69373 IF(ISL(1).EQ.1) ISL(2)=0
69374 IF(ISL(1).EQ.0) ISLM=1
69375 IF(ISL(2).EQ.0) ISLM=2
69377 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
69382 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
69383 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
69384 PMQ1=V(N+1,5)/V(IM,5)
69385 PMQ2=V(N+2,5)/V(IM,5)
69386 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
69391 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
69395 C...Accepted branch. Construct four-momentum for initial partons.
69401 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
69403 P(N+1,4)=P(IPA(1),4)
69405 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
69406 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
69409 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
69414 P(N+2,4)=P(IM,5)-PED1
69417 ELSEIF(NEP.GE.3) THEN
69418 C...Rescale all momenta for energy conservation.
69424 P(N+I,J)=P(IPA(I),J)
69427 PQS=PQS+P(N+I,5)**2/P(N+I,4)
69430 FAC=(PS(5)-PQS)/(PES-PQS)
69435 P(N+I,J)=FAC*P(N+I,J)
69437 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)
69440 PQS=PQS+P(N+I,5)**2/P(N+I,4)
69442 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
69444 C...Construct transverse momentum for ordinary branching in shower.
69448 550 LOOPPT=LOOPPT+1
69449 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
69450 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
69451 IF(PZM.LE.0D0) THEN
69453 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69454 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69455 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
69456 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
69457 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
69458 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
69460 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
69462 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
69465 ELSEIF(PTS.LT.0D0) THEN
69468 PT=SQRT(MAX(0D0,PTS))
69470 C...Global statistics.
69471 MINT(353)=MINT(353)+1
69472 VINT(353)=VINT(353)+PT
69473 IF (MINT(353).EQ.1) VINT(358)=PT
69475 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
69477 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
69478 & .AND.IAU.NE.0) THEN
69479 IF(K(IGM,3).NE.0) MAZIP=1
69481 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
69482 IF(MAZIP.EQ.0) ZAU=0D0
69483 IF(K(IGM,2).NE.21) THEN
69484 HAZIP=2D0*ZAU/(1D0+ZAU**2)
69486 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
69488 IF(K(N+1,2).NE.21) THEN
69489 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
69491 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
69495 C...Find coefficient of azimuthal asymmetry due to soft gluon
69498 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
69499 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
69500 IF(K(IGM,3).NE.0) MAZIC=N+1
69501 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
69502 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
69503 & ZM.GT.0.5D0) MAZIC=N+2
69504 IF(K(IAU,2).EQ.22) MAZIC=0
69506 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
69508 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
69509 IF(MAZIC.EQ.0) ZGM=1D0
69510 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
69511 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
69512 HAZIC=MIN(0.95D0,HAZIC)
69516 C...Construct energies for ordinary branching in shower.
69517 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
69518 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69519 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69520 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
69521 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
69522 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
69523 P(N+1,4)=PEM*V(IM,1)
69525 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
69526 & SQRT(PMLS)*ZM)/V(IM,5)
69529 C...Already predetermined choice of phi angle or not
69531 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
69533 IF(K(IPSPD,4).GT.0) THEN
69535 IF(IM.EQ.NS+2) THEN
69536 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
69538 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
69541 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
69543 IF(K(IPSPD,4).GT.0) THEN
69545 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
69546 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
69547 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
69548 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
69549 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
69550 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
69554 C...Construct momenta for ordinary branching in shower.
69555 P(N+1,1)=PT*COS(PHI)
69556 P(N+1,2)=PT*SIN(PHI)
69557 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69558 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69559 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
69560 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
69561 ELSEIF(PZM.GT.0D0) THEN
69562 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
69563 & 2D0*PEM*P(N+1,4))/PZM
69569 P(N+2,3)=PZM-P(N+1,3)
69570 P(N+2,4)=PEM-P(N+1,4)
69571 IF(MSTJ(43).LE.2) THEN
69572 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
69573 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
69577 C...Rotate and boost daughters.
69579 IF(MSTJ(43).LE.2) THEN
69580 BEX=P(IGM,1)/P(IGM,4)
69581 BEY=P(IGM,2)/P(IGM,4)
69582 BEZ=P(IGM,3)/P(IGM,4)
69583 GA=P(IGM,4)/P(IGM,5)
69584 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
69593 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
69594 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
69595 IF(PTIMB.GT.1D-4) THEN
69596 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
69601 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
69602 & SIN(THE)*COS(PHI)*P(I,3)
69603 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
69604 & SIN(THE)*SIN(PHI)*P(I,3)
69605 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
69607 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
69608 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
69609 P(I,1)=DP(1)+DGABP*BEX
69610 P(I,2)=DP(2)+DGABP*BEY
69611 P(I,3)=DP(3)+DGABP*BEZ
69612 P(I,4)=GA*(DP(4)+DBP)
69616 C...Weight with azimuthal distribution, if required.
69617 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
69623 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
69624 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
69625 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
69627 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
69628 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
69630 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
69631 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
69632 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
69633 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
69634 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
69635 IF(MAZIP.NE.0) THEN
69636 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
69639 IF(MAZIC.NE.0) THEN
69640 IF(MAZIC.EQ.N+2) CAD=-CAD
69641 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
69642 & .LT.PYR(0)) GOTO 560
69647 C...Azimuthal anisotropy due to interference with initial state partons.
69648 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
69649 &K(N+2,2).EQ.21)) THEN
69651 IF(ISII(III).GE.1) THEN
69653 IF(K(N+1,2).NE.21) IAZIID=N+2
69654 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
69655 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
69656 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
69657 IF(III.EQ.2) THEIID=PARU(1)-THEIID
69658 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
69659 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
69660 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
69661 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
69662 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
69663 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
69664 & .LT.PYR(0)) GOTO 560
69668 C...Continue loop over partons that may branch, until none left.
69669 IF(IGM.GE.0) K(IM,1)=14
69672 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
69673 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
69674 IF(MSTU(21).GE.1) N=NS
69675 IF(MSTU(21).GE.1) RETURN
69679 C...Set information on imagined shower initiator.
69680 600 IF(NPA.GE.2) THEN
69684 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
69692 C...Reconstruct string drawing information.
69693 DO 610 I=NS+1+IIM,N
69694 KQ=KCHG(PYCOMP(K(I,2)),2)
69695 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
69697 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
69698 & IABS(K(I,2)).LE.18) THEN
69700 ELSEIF(K(I,1).LE.10) THEN
69701 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
69702 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
69703 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
69704 ID1=MOD(K(I,4),MSTU(5))
69705 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
69706 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
69707 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
69708 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
69709 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
69710 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
69711 K(ID1,4)=K(ID1,4)+MSTU(5)*I
69712 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
69713 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
69714 K(ID2,5)=K(ID2,5)+MSTU(5)*I
69716 ID1=MOD(K(I,4),MSTU(5))
69718 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
69719 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
69720 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
69721 K(ID1,4)=K(ID1,4)+MSTU(5)*I
69722 K(ID1,5)=K(ID1,5)+MSTU(5)*I
69732 C...Transformation from CM frame.
69734 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
69735 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
69737 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
69738 ELSEIF(NPA.EQ.2) THEN
69743 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
69744 & /(1D0+GA)-P(IPA(1),4))
69745 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
69746 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
69747 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
69749 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
69751 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
69754 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
69757 C...Decay vertex of shower.
69764 C...Delete trivial shower, else connect initiators.
69765 IF(N.LE.NS+NPA+IIM) THEN
69770 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
69771 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
69772 K(NS+IIM+IP,3)=IPA(IP)
69773 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
69774 IF(K(NS+IIM+IP,1).NE.1) THEN
69775 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
69776 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
69784 C*********************************************************************
69787 C...Generates pT-ordered timelike final-state parton showers.
69789 C...MODE defines how to find radiators and recoilers.
69790 C... = 0 : based on colour flow between undecayed partons.
69791 C... = 1 : for IPART <= NPARTD only consider primary partons,
69792 C... whether decayed or not; else as above.
69793 C... = 2 : based on common history, whether decayed or not.
69794 C... = 3 : use (or create) MCT color information to shower partons
69796 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
69798 C...Double precision and integer declarations.
69799 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69800 IMPLICIT INTEGER(I-N)
69801 INTEGER PYK,PYCHGE,PYCOMP
69802 C...Parameter statement to help give large particle numbers.
69803 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69804 &KEXCIT=4000000,KDIMEN=5000000)
69805 C...Parameter statement for maximum size of showers.
69806 PARAMETER (MAXNUR=1000)
69808 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
69809 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69810 COMMON/PYCTAG/NCT,MCT(4000,2)
69811 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69812 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69813 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69814 COMMON/PYINT1/MINT(400),VINT(400)
69815 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
69818 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
69819 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
69820 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
69821 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
69822 C...Statement functions.
69823 SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
69824 &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
69826 C...Initial values. Check that valid system.
69828 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
69829 &MSTJ(41).NE.12) RETURN
69830 IF(NPART.LE.0) THEN
69831 CALL PYERRM(2,'(PYPTFS:) showering system too small')
69837 C...Mass thresholds and Lambda for QCD evolution.
69841 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
69842 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
69849 C...Cutoff scale for QCD evolution. Starting pT2.
69850 NFLAV=MAX(0,MIN(5,MSTJ(45)))
69851 PT0C=0.5D0*PARJ(82)
69852 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
69854 C...Parameters for QED evolution.
69855 AEM2PI=PARU(101)/PARU(2)
69856 PT0EQ=0.5D0*PARJ(83)
69857 PT0EL=0.5D0*PARJ(90)
69859 C...Reset. Remove irrelevant colour tags.
69864 DO 110 I=MINT(84)+1,N
69865 IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
69869 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
69876 C...Begin loop to set up showering partons. Sum four-momenta.
69879 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
69880 IF(K(I,1).GT.10) GOTO 230
69881 ELSEIF(K(I,3).GT.MINT(84)) THEN
69882 IF(K(I,3).GT.MINT(84)+2) GOTO 230
69884 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 230
69887 PSUM(J)=PSUM(J)+P(I,J)
69890 C...Find colour and charge, but skip diquarks.
69891 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 230
69892 KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
69893 KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
69896 IF (IABS(K(I,2)).GE.9900101.AND.IABS(K(I,2)).LE.9910555) THEN
69897 IF (MSTP(148).GE.1) THEN
69898 C...Temporary: force no radiation from quarkonia since not yet treated
69899 CALL PYERRM(11,'(PYPTFS:) quarkonia showers not yet in'
69900 & //' PYPTFS, switched off')
69901 CALL PYGIVE('MSTP(148)=0')
69903 IF (MSTP(148).EQ.0) THEN
69904 C...Skip quarkonia if radiation switched off
69910 C...Option to switch off radiation from particle KF = MSTJ(39) entirely
69911 C...(only intended for studying the effects of switching such rad on/off)
69912 IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) THEN
69916 C...Either colour or anticolour charge radiates; for gluon both.
69917 DO 180 JSGCOL=1,-1,-2
69918 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
69919 JCOL=4+(1-JSGCOL)/2
69922 C...Basic info about radiating parton.
69926 ISCOL(NEVOL)=JSGCOL
69928 PTSCA(NEVOL)=PTPART(IP)
69930 C...Begin search for colour recoiler when MODE = 0 or 1.
69932 C...Find sister with matching anticolour to the radiating parton.
69934 IRNEW=K(IROLD,JCOL)/MSTU(5)
69937 C...Skip radiation off loose colour ends.
69938 130 IF(IRNEW.EQ.0) THEN
69942 C...Optionally skip radiation on dipole to beam remnant.
69943 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
69947 C...For now always skip radiation on dipole to junction.
69948 ELSEIF(K(IRNEW,2).EQ.88) THEN
69952 C...For MODE=1: if reached primary then done.
69953 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
69954 & IRNEW.LE.NPARTD) THEN
69956 C...If sister stable and points back then done.
69957 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
69959 IF(K(IRNEW,1).LT.10) THEN
69961 C...If sister unstable then go to her daughter.
69964 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
69969 C...If found mother then look for aunt.
69970 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
69973 IRNEW=K(IROLD,JCOL)/MSTU(5)
69976 C...If daughter stable then done.
69977 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
69979 IF(K(IRNEW,1).LT.10) THEN
69981 C...If daughter unstable then go to granddaughter.
69984 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
69989 C...If daughter points to another daughter then done or move up.
69990 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
69992 IF(K(IRNEW,1).LT.10) THEN
69995 IRNEW=K(IRNEW,JCOL)/MSTU(5)
70001 C...Begin search for colour recoiler when MODE = 2.
70002 ELSEIF (MODE.EQ.2) THEN
70004 IRNEW=K(IROLD,JCOL)/MSTU(5)
70005 140 IF (IRNEW.LE.0.OR.IRNEW.GT.N) THEN
70006 C...If no color partner found, pick at random among other primaries
70007 C...(e.g., when the color line is traced all the way to the beam)
70008 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70009 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70010 ELSEIF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
70011 C...Step up to mother if radiating parton already branched.
70012 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
70014 IRNEW=K(IROLD,JCOL)/MSTU(5)
70016 C...Pick sister by history if no anticolour available.
70018 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
70020 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
70023 C...Last resort: pick at random among other primaries.
70025 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70026 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70030 C...Trace down if sister branched.
70031 150 IF(K(IRNEW,1).GT.10) THEN
70032 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
70033 C...If no correct color-daughter found, swap.
70034 IF (IRTMP.EQ.0) THEN
70037 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
70042 ELSEIF (MODE.EQ.3) THEN
70043 C...The following will add MCT colour tracing for unprepped events
70044 C...If not done, trace Les Houches colour tags for this dipole
70046 IF (MCT(I,JCOL-3).EQ.0) THEN
70047 C...Special end code -1 : trace to color partner or 0, return in IEND
70049 CALL PYCTTR(I,JCOL,IEND)
70050 C...Clean up mother/daughter 'read' tags set by PYCTTR
70053 K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
70054 K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
70061 IF (K(IR,1).GT.0.AND.MCT(IR,6-JCOL).EQ.MCT(I,JCOL-3))
70065 C...If no color partner, then we hit beam
70066 IF (IEND.LE.0) THEN
70067 C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate
70068 IF (MSTP(72).LE.1) THEN
70072 C...Else try a random partner
70073 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70074 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70077 C...Else save recoiling colour partner
70083 C...Now found other end of colour dipole.
70088 C...Also electrical charge may radiate; so far only quarks and leptons.
70089 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
70090 & IABS(K(I,2)).LE.18) THEN
70092 C...Basic info about radiating parton.
70098 PTSCA(NEVOL)=PTPART(IP)
70100 C...Pick nearest (= smallest invariant mass) charged particle
70101 C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
70105 DO 190 IP2=1,NPART+N-MINT(53)
70106 IF(IP2.EQ.IP) GOTO 190
70107 IF(IP2.LE.NPART) THEN
70109 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
70110 IF(K(I2,1).GT.10) GOTO 190
70111 ELSEIF(K(I2,3).GT.MINT(84)) THEN
70112 IF(K(I2,3).GT.MINT(84)+2) GOTO 190
70114 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 190
70117 I2=MINT(53)+IP2-NPART
70119 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 190
70120 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
70121 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
70122 IF(PM2INV.LT.PM2MIN) THEN
70127 IF(IRNEW.EQ.0) THEN
70132 C...Begin search for charge recoiler when MODE = 2.
70135 C...Pick sister by history; step up if parton already branched.
70136 200 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
70140 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
70142 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
70144 C...Last resort: pick at random among other primaries.
70146 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70147 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70149 C...Trace down if sister branched.
70150 210 IF(K(IRNEW,1).GT.10) THEN
70151 DO 220 IR=IRNEW+1,N
70152 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
70162 C...End loop to set up showering partons. System invariant mass.
70164 IF(NEVOL.LE.0) RETURN
70165 IF (MODE.EQ.3.AND.NEVOL.LE.1) RETURN
70166 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
70168 C...Check if 3-jet matrix elements to be used.
70172 IF(MSTJ(47).GE.1) THEN
70174 C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
70176 IPART1=K(IPART(1),3)
70177 IPART2=K(IPART(2),3)
70178 240 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
70179 KFSRCE=IABS(K(IPART1,2))
70180 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
70183 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
70188 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
70189 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
70190 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
70191 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
70192 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
70193 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
70194 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
70195 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
70197 C...Identify two primary showerers.
70198 KFLA1=IABS(K(IPART(1),2))
70200 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
70201 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
70202 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
70203 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
70204 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
70205 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
70206 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
70207 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
70208 KFLA2=IABS(K(IPART(2),2))
70210 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
70211 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
70212 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
70213 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
70214 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
70215 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
70216 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
70217 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
70219 C...Order of showerers. Presence of gluino.
70220 ITYPMN=MIN(ITYPE1,ITYPE2)
70221 ITYPMX=MAX(ITYPE1,ITYPE2)
70223 IF(ITYPE1.GT.ITYPE2) IORD=2
70225 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
70227 C...Require exactly two primary showerers for ME corrections.
70229 IF(IPART1.GT.0) THEN
70231 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
70234 IF(NPRIM.NE.2) THEN
70236 C...Predetermined and default matrix element kinds.
70237 ELSEIF(MSTJ(38).NE.0) THEN
70241 ELSEIF(MSTJ(47).GE.6) THEN
70247 C...Vector/axial vector -> q + qbar; q -> q + V.
70248 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
70249 & ITYPES.EQ.3)) THEN
70251 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
70253 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
70254 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
70255 C...gamma*/Z0: assume e+e- initial state if unknown.
70257 IF(KFSRCE.EQ.23) THEN
70259 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
70260 IF(IANNFL.GT.0) THEN
70261 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
70263 IF(IANNFL.NE.0) THEN
70264 KANNFL=IABS(K(IANNFL,2))
70265 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
70268 AI=SIGN(1D0,EI+0.1D0)
70269 VI=AI-4D0*EI*PARU(102)
70270 EF=KCHG(KFLA1,1)/3D0
70271 AF=SIGN(1D0,EF+0.1D0)
70272 VF=AF-4D0*EF*PARU(102)
70273 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
70276 SQWZ=PSUM(5)*PMAS(23,2)
70277 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
70278 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
70279 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
70280 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
70282 ALPHA=VECT/(VECT+AXIV)
70283 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
70286 C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
70287 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
70289 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70290 & ITYPES.EQ.1)) THEN
70293 C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
70294 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
70296 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
70298 ELSEIF(KFSRCE.EQ.36) THEN
70301 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70302 & ITYPES.EQ.1)) THEN
70305 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
70306 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70307 & ITYPES.EQ.3)) THEN
70309 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70310 & ITYPES.EQ.2)) THEN
70312 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
70314 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70315 & ITYPES.EQ.2)) THEN
70318 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
70319 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70320 & ITYPES.EQ.5)) THEN
70322 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70323 & ITYPES.EQ.2)) THEN
70325 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70326 & ITYPES.EQ.1)) THEN
70329 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
70330 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
70332 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70333 & ITYPES.EQ.2)) THEN
70335 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70336 & ITYPES.EQ.1)) THEN
70339 C...g -> ~g + ~g (eikonal approximation).
70340 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
70343 M3JC=5*ICLASS+ICOMBI
70346 C...Store pair that together define matrix element treatment.
70349 MESYS(NMESYS,0)=M3JC
70350 MESYS(NMESYS,1)=IPART(1)
70351 MESYS(NMESYS,2)=IPART(2)
70354 C...Store qqbar or l+l- pairs for QED radiation.
70355 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
70357 MESYS(NMESYS,0)=101
70358 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
70359 MESYS(NMESYS,1)=IPART(1)
70360 MESYS(NMESYS,2)=IPART(2)
70363 C...Store other qqbar/l+l- pairs from g/gamma branchings.
70365 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 290
70367 260 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
70371 C...Move up this check to avoid out-of-bounds.
70372 IF(I1M.EQ.0) GOTO 290
70373 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 290
70375 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 280
70377 270 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
70381 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
70387 MESYS(NMESYS,0)=102
70395 C..Loopback point for counting number of emissions.
70399 C...Begin loop to evolve all existing partons, if required.
70402 DO 380 IEVOL=1,NEVOL
70403 IF(IFLG(IEVOL).EQ.0) THEN
70405 C...Basic info on radiator and recoil.
70412 C...Invariant mass of "dipole".Starting value for pT evolution.
70413 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
70414 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
70416 C...Case of evolution by QCD branching.
70417 IF(ISCOL(IEVOL).NE.0) THEN
70419 C...Parton-by-parton maximum scale from initial conditions.
70420 IF(MSTP(72).EQ.0) THEN
70421 DO 320 IPRT=1,NPARTS
70422 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
70426 C...If kinematically impossible then do not evolve.
70427 IF(PT2.LT.PT2CMN) THEN
70432 C...Check if part of system for which ME corrections should be applied.
70434 DO 330 IME=1,NMESYS
70435 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
70436 & MESYS(IME,0).LT.100) IMESYS=IME
70439 C...Special flag for colour octet states.
70440 C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot.
70442 IF(K(I,2).EQ.21) MOCT=1
70444 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
70446 IF(K(I,2).EQ.5100021) MOCT=2
70448 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).EQ.9900101.AND.
70449 & IABS(K(I,2)).LE.9910555) MOCT=2
70453 C...Upper estimate for matrix element weighting and colour factor.
70454 C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
70457 IF(MOCT.GE.1) COLFAC=3D0/2D0
70458 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
70459 WTPSQQ=0.5D0*0.5D0*NFLAV
70461 C...Determine overestimated z range: switch at c and b masses.
70466 IF(PT2.GT.1.01D0*PMCS) THEN
70472 IF(PT2.GT.1.01D0*PMBS) THEN
70478 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
70479 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
70481 C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
70482 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
70485 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
70486 EVCOEF=EVCOEF+EVEMQQ
70489 C...Pick pT2 (in overestimated z range).
70490 350 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
70492 C...Loopback if crossed c/b mass thresholds.
70493 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
70497 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
70502 C...Finish if below lower cutoff.
70503 IF(PT2.LT.PT2CMN) THEN
70508 C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
70509 C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting
70511 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
70513 C...Pick z: dz/(1-z) or dz.
70514 IF(IFLAG.EQ.1) THEN
70515 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
70517 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
70520 C...Loopback if outside allowed range for given pT2.
70521 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
70522 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
70523 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
70524 PM2=PM2I+PT2/(Z*(1D0-Z))
70525 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
70527 C...No weighting for primary partons; to be done later on.
70528 IF(IMESYS.GT.0) THEN
70530 C...Weighting of q->qg/X->Xg branching.
70531 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
70532 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 350
70534 C...Weighting of g->gg branching.
70535 ELSEIF(IFLAG.EQ.1) THEN
70536 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 350
70538 C...Flavour choice and weighting of g->qqbar branching.
70540 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
70542 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
70543 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
70544 IF(WTME.LT.PYR(0)) GOTO 350
70548 C...Case of evolution by QED branching.
70549 ELSEIF(ISCHG(IEVOL).NE.0) THEN
70551 C...If kinematically impossible then do not evolve.
70553 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
70554 IF(PT2.LT.PT2EMN) THEN
70559 C...Check if part of system for which ME corrections should be applied.
70561 DO 360 IME=1,NMESYS
70562 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
70563 & MESYS(IME,0).GT.100) IMESYS=IME
70566 C...Charge. Matrix element weighting factor.
70567 CHG=ISCHG(IEVOL)/3D0
70570 C...Determine overestimated z range. Find evolution coefficient.
70571 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
70572 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
70573 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
70575 C...Pick pT2 (in overestimated z range).
70576 370 PT2=PT2*PYR(0)**(1D0/EVCOEF)
70578 C...Finish if below lower cutoff.
70579 IF(PT2.LT.PT2EMN) THEN
70584 C...Pick z: dz/(1-z).
70585 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
70587 C...Loopback if outside allowed range for given pT2.
70588 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
70589 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
70590 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 370
70591 PM2=PM2I+PT2/(Z*(1D0-Z))
70592 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 370
70594 C...Weighting by branching kernel, except if ME weighting later.
70595 IF(IMESYS.EQ.0) THEN
70596 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 370
70601 C...Save acceptable branching.
70603 IMESAV(IEVOL)=IMESYS
70609 C...Check if branching has highest pT.
70610 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
70612 PT2MX=PT2SAV(IEVOL)
70616 C...Finished if no more branchings to be done.
70617 IF(IMX.EQ.0) GOTO 500
70619 C...Restore info on hardest branching to be processed.
70630 PM2=PM2I+PT2/(Z*(1D0-Z))
70632 C...Special flag for colour octet states.
70634 IF(K(I,2).EQ.21) MOCT=1
70635 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
70636 IF(K(I,2).EQ.5100021) MOCT=2
70638 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).GE.9900101.AND.
70639 & IABS(K(I,2)).LE.9910555) MOCT=2
70642 C...Restore further info for g->qqbar branching.
70644 IF(IFLG(IMX).GT.10) THEN
70647 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
70650 C...For branching g include azimuthal asymmetries from polarization.
70652 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
70653 C...Trace grandmother via intermediate recoil copies.
70656 390 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
70657 & K(IM,3).GT.0) THEN
70659 IF(IM.GT.MINT(84)) GOTO 390
70662 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
70663 & KFGM=IABS(K(IGM,2))
70664 C...Define approximate energy sharing by identifying aunt.
70666 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
70667 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
70668 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
70669 C...Coefficient from gluon production.
70671 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
70673 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
70675 C...Coefficient from gluon decay.
70677 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
70679 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
70684 C...Create new slots for branching products and recoil.
70690 C...Set status, flavour and mother of new ones.
70693 IF(KCHA.NE.0) K(IGNEW,1)=1
70698 IF(KCHA.NE.0) K(IGNEW,2)=22
70700 K(INEW,2)=-ISIGN(KFQ,KCOL)
70701 K(IGNEW,2)=-K(INEW,2)
70708 C...Find rest frame and angles of branching+recoil.
70714 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
70715 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
70716 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
70717 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
70718 PHI=PYANGL(P(INEW,1),P(INEW,2))
70719 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
70721 C...Derive kinematics of branching: generics (like g->gg).
70726 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
70727 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
70728 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
70729 PTCOR=SQRT(MAX(0D0,PT2COR))
70730 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
70731 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
70732 C...Specific kinematics reduction for q->qg with m_q > 0.
70734 PTCOR=(1D0-PM2I/PM2)*PTCOR
70735 PZN=PZN+PM2I*PZG/PM2
70736 PZG=(1D0-PM2I/PM2)*PZG
70737 C...Specific kinematics reduction for g->qqbar with m_q > 0.
70738 ELSEIF(KFQ.NE.0) THEN
70742 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
70746 C...Pick phi and construct kinematics of branching.
70747 420 PHIROT=PARU(2)*PYR(0)
70748 P(INEW,1)=PTCOR*COS(PHIROT)
70749 P(INEW,2)=PTCOR*SIN(PHIROT)
70751 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
70752 P(IGNEW,1)=-P(INEW,1)
70753 P(IGNEW,2)=-P(INEW,2)
70755 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
70759 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
70761 C...Boost branching system to lab frame.
70762 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
70764 C...Renew choice of phi angle according to polarization asymmetry.
70765 IF(ABS(ASYPOL).GT.1D-3) THEN
70771 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
70772 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
70773 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
70775 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
70776 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
70778 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
70779 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
70780 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
70781 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
70782 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
70783 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
70788 C...Matrix element corrections for primary partons when requested.
70789 IF(IMESYS.GT.0) THEN
70790 M3JC=MESYS(IMESYS,0)
70792 C...Identify recoiling partner and set up three-body kinematics.
70793 IRP=MESYS(IMESYS,1)
70794 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
70795 IF(IRP.EQ.IR) IRP=IRNEW
70797 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
70799 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
70801 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
70802 & PSUM(3)*P(INEW,3))/PSUM(5)**2
70803 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
70804 & PSUM(3)*P(IRP,3))/PSUM(5)**2
70806 R1ME=P(INEW,5)/PSUM(5)
70807 R2ME=P(IRP,5)/PSUM(5)
70809 C...Matrix elements for gluon emission.
70810 IF(M3JC.LT.100) THEN
70812 C...Call ME, with right order important for two inequivalent showerers.
70813 IF(MESYS(IMESYS,IORD).EQ.I) THEN
70814 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
70816 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
70819 C...Split up total ME when two radiating partons.
70821 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
70822 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
70823 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
70824 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
70825 & MAX(1D-10,2D0-X1-X2)
70827 C...Evaluate shower rate.
70828 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
70829 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70830 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
70832 C...Matrix elements for photon emission: still rather primitive.
70835 C...For generic charge combination currently only massless expression.
70836 IF(M3JC.EQ.101) THEN
70837 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
70838 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
70839 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
70840 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
70842 C...For flavour neutral system assume vector source and include masses.
70844 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
70845 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
70846 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
70847 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70851 C...Perform weighting with W_ME/W_PS.
70852 IF(WME.LT.PYR(0)*WPS) THEN
70860 C...Now for sure accepted branching. Save highest pT.
70861 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
70863 C...Update status for obsolete ones. Bookkkep the moved original parton
70864 C...and new daughter (arbitrary choice for g->gg or g->qqbar).
70865 C...Do not bookkeep radiated photon, since it cannot radiate further.
70869 IF(IPART(IP).EQ.I) IPART(IP)=INEW
70870 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
70877 C...Initialize colour flow of branching.
70878 C...Use both old and new style colour tags for flexibility.
70892 C...Trivial colour flow for l->lgamma and q->qgamma.
70893 IF(IABS(KCHA).EQ.3) THEN
70896 ELSEIF(KCHA.NE.0) THEN
70897 IF(K(I,4).NE.0) THEN
70899 K(INEW,4)=MSTU(5)*I
70900 MCT(INEW,1)=MCT(I,1)
70902 IF(K(I,5).NE.0) THEN
70904 K(INEW,5)=MSTU(5)*I
70905 MCT(INEW,2)=MCT(I,2)
70908 C...Set colour flow for q->qg and g->gg.
70909 ELSEIF(KFQ.EQ.0) THEN
70910 K(I,JCOLP)=K(I,JCOLP)+IGNEW
70911 K(IGNEW,JCOLP)=MSTU(5)*I
70912 K(INEW,JCOLP)=MSTU(5)*IGNEW
70913 K(IGNEW,JCOLN)=MSTU(5)*INEW
70914 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
70916 MCT(INEW,JCOLP-3)=NCT
70917 MCT(IGNEW,JCOLN-3)=NCT
70919 K(I,JCOLN)=K(I,JCOLN)+INEW
70920 K(INEW,JCOLN)=MSTU(5)*I
70921 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
70924 C...Set colour flow for g->qqbar.
70926 K(I,JCOLN)=K(I,JCOLN)+INEW
70927 K(INEW,JCOLN)=MSTU(5)*I
70928 K(I,JCOLP)=K(I,JCOLP)+IGNEW
70929 K(IGNEW,JCOLP)=MSTU(5)*I
70930 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
70931 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
70934 C...Daughter info for colourless recoiling parton.
70935 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
70941 C...Colour of recoiling parton sails through unchanged.
70943 IF(K(IR,4).NE.0) THEN
70944 K(IR,4)=K(IR,4)+IRNEW
70945 K(IRNEW,4)=MSTU(5)*IR
70946 MCT(IRNEW,1)=MCT(IR,1)
70948 IF(K(IR,5).NE.0) THEN
70949 K(IR,5)=K(IR,5)+IRNEW
70950 K(IRNEW,5)=MSTU(5)*IR
70951 MCT(IRNEW,2)=MCT(IR,2)
70955 C...Vertex information trivial.
70962 C...Update list of old radiators.
70963 DO 480 IEVOL=1,NEVOL
70964 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
70966 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
70969 ELSEIF(IPOS(IEVOL).EQ.I) THEN
70972 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
70975 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
70977 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
70981 C...Update links of old connected partons.
70982 IF(IREC(IEVOL).EQ.I) THEN
70985 ELSEIF(IREC(IEVOL).EQ.IR) THEN
70991 C...q->qg or g->gg: create new gluon radiators.
70992 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
70999 PTSCA(NEVOL)=SQRT(PT2)
71006 PTSCA(NEVOL)=PTSCA(NEVOL-1)
71009 C...Update matrix elements parton list and add new for g/gamma->qqbar.
71010 DO 490 IME=1,NMESYS
71011 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
71012 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
71013 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
71014 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
71019 MESYS(NMESYS,1)=INEW
71020 MESYS(NMESYS,2)=IGNEW
71022 MESYS(NMESYS,0)=102
71023 MESYS(NMESYS,1)=INEW
71024 MESYS(NMESYS,2)=IGNEW
71027 C...Global statistics.
71028 MINT(353)=MINT(353)+1
71029 VINT(353)=VINT(353)+PTCOR
71030 IF (MINT(353).EQ.1) VINT(358)=PTCOR
71032 C...Loopback for more emissions if enough space.
71034 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
71035 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
71038 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
71047 C*********************************************************************
71050 C...Auxiliary to PYSHOW and PYPTFS.
71051 C...Matrix elements for gluon (or photon) emission from
71052 C...a two-body state; to be used by the parton shower routine.
71053 C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
71054 C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
71055 C... = (alpha-strong/2 pi) * CF * PYMAEL,
71056 C...i.e. normalization is such that one recovers the familiar
71057 C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
71058 C...Coupling structure:
71059 C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
71060 C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
71061 C... = 16-19 : q -> q V
71062 C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
71063 C... = 26-29 : q -> q S
71064 C... = 31-34 : V -> ~q ~qbar (~q = squark)
71065 C... = 36-39 : ~q -> ~q V
71066 C... = 41-44 : S -> ~q ~qbar
71067 C... = 46-49 : ~q -> ~q S
71068 C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
71069 C... = 56-59 : ~q -> q chi
71070 C... = 61-64 : q -> ~q chi
71071 C... = 66-69 : ~g -> q ~qbar
71072 C... = 71-74 : ~q -> q ~g
71073 C... = 76-79 : q -> ~q ~g
71074 C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
71075 C...Note that the order of the decay products is important.
71076 C...In each set of four, the variants are ordered as:
71077 C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
71078 C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
71079 C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
71080 C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
71082 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
71084 C...Double precision and integer declarations.
71085 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71086 IMPLICIT INTEGER(I-N)
71088 C...Check input values. Return zero outside allowed phase space.
71090 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
71091 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
71092 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
71093 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
71094 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
71095 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
71097 C...Initial values and flags.
71105 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
71107 C...Eikonal expression; also acts as default.
71108 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
71110 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
71112 ELSEIF(ICOMBI.EQ.2) THEN
71113 ANUM=(2D0-X1-X2)**2
71114 ELSEIF(ICOMBI.EQ.3) THEN
71115 ANUM=ALPCOR*(2D0-X1-X2)**2
71117 ANUM=0.5D0*(2D0-X1-X2)**2
71119 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
71120 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
71121 & R1**2/(1D0+R2**2-R1**2-X2)**2-
71122 & R2**2/(1D0+R1**2-R2**2-X1)**2)
71125 C...V -> q qbar (V = gamma*/Z0/W+-/...).
71126 ELSEIF(ICLASS.EQ.2) THEN
71127 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71128 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
71129 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
71130 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
71131 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
71132 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
71133 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
71134 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
71135 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
71136 & (-1+R1**2-R2**2+X2)**2
71137 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
71138 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
71139 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
71140 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
71141 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
71142 & -X1-X2)**2+X1*(2-X1-X2)**2)/
71143 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71144 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
71145 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
71146 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
71147 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
71148 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
71152 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71153 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
71154 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
71155 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
71156 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
71157 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
71158 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
71159 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
71160 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
71161 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
71162 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
71163 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
71164 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
71165 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
71166 & -X1-X2)**2+X1*(2-X1-X2)**2)/
71167 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71168 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
71169 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
71170 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
71171 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
71172 & +X2)/(-1-R1**2+R2**2+X1)**2
71176 IF(ICOMBI.EQ.4) THEN
71177 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
71178 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
71179 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
71180 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
71181 & (-1-R1**2+R2**2+X1)**2
71183 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
71184 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
71185 & -R1**2*X2**2+X1*X2**2)/
71186 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71187 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
71188 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
71189 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
71190 & (-1+R1**2-R2**2+X2)**2
71196 ELSEIF(ICLASS.EQ.3) THEN
71197 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71198 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
71199 & +R1**2*R2**2-2D0*R2**4)
71200 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
71201 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
71202 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
71203 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
71204 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
71205 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
71206 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
71207 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
71208 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
71209 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
71210 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71211 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71212 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
71213 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
71214 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
71215 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
71216 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71217 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
71218 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
71221 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71222 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
71223 & +R1**2*R2**2-2D0*R2**4)
71224 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
71225 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
71226 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
71227 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
71228 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
71229 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
71230 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71231 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
71232 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
71233 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
71234 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71235 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71236 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
71237 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
71238 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
71239 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
71240 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71241 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
71242 & +X1*X2**2)/(-2+X1+X2)**2
71245 IF(ICOMBI.EQ.4) THEN
71246 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
71247 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
71248 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
71249 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
71250 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
71251 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71252 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
71253 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
71254 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71255 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71256 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
71257 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
71258 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
71259 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71260 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
71261 & +X1*X2**2)/(2-X1-X2)**2
71265 C...S -> q qbar (S = h0/H0/A0/H+-/...).
71266 ELSEIF(ICLASS.EQ.4) THEN
71267 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71268 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
71269 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71270 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71271 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71272 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
71273 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
71274 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71275 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71276 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71277 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71280 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71281 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
71282 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71283 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71284 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71285 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71286 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
71287 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71288 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
71289 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
71290 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
71291 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71294 IF(ICOMBI.EQ.4) THEN
71295 RLO4=PS*(1D0-R1**2-R2**2)
71296 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
71297 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71298 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
71299 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
71300 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71301 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
71302 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71307 ELSEIF(ICLASS.EQ.5) THEN
71308 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71309 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71310 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
71311 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71312 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
71313 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71314 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
71315 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
71316 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71317 & (-1+R1**2-R2**2+X2)**2
71320 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71321 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
71322 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
71323 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71324 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
71325 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71326 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
71327 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
71328 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71329 & (-1+R1**2-R2**2+X2)**2
71332 IF(ICOMBI.EQ.4) THEN
71333 RLO4=PS*(1D0+R1**2-R2**2)
71334 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
71335 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71336 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
71337 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
71338 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
71339 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
71343 C...V -> ~q ~qbar (~q = squark).
71344 ELSEIF(ICLASS.EQ.6) THEN
71345 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
71346 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
71347 & (-1-R1**2+R2**2+X1)**2
71348 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
71349 & (-1-R1**2+R2**2+X1)
71350 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
71351 & /(-1+R1**2-R2**2+X2)**2
71352 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
71353 & (-1+R1**2-R2**2+X2)
71354 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
71355 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
71356 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
71357 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71361 ELSEIF(ICLASS.EQ.7) THEN
71362 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
71363 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
71364 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
71365 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
71366 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
71367 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
71368 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
71369 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
71370 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
71371 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
71372 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
71378 ELSEIF(ICLASS.EQ.8) THEN
71380 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
71381 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
71382 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
71383 & -R1**2*X2**2+X1*X2**2)/
71384 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
71389 ELSEIF(ICLASS.EQ.9) THEN
71391 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71392 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71393 & -(X1+X2)/(-2+X1+X2)**2
71396 C...chi -> q ~qbar (chi = neutralino/chargino).
71397 ELSEIF(ICLASS.EQ.10) THEN
71398 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71399 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71400 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
71401 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
71402 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
71403 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71404 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
71405 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71406 & (-1+R1**2-R2**2+X2)**2
71409 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71410 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
71411 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
71412 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
71413 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
71414 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71415 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
71416 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71417 & (-1+R1**2-R2**2+X2)**2
71420 IF(ICOMBI.EQ.4) THEN
71421 RLO4=PS*(1+R1**2-R2**2)
71422 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
71423 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
71424 & +X2+R1**2*X2-X1*X2/2)/
71425 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71426 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
71427 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
71432 ELSEIF(ICLASS.EQ.11) THEN
71433 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71434 RLO1=PS*(1D0-(R1+R2)**2)
71435 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
71436 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71437 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71438 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71439 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
71440 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71441 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71444 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71445 RLO2=PS*(1D0-(R1-R2)**2)
71446 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
71448 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71449 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
71450 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71451 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
71452 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71453 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71456 IF(ICOMBI.EQ.4) THEN
71457 RLO4=PS*(1D0-R1**2-R2**2)
71458 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
71459 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
71460 & +3*R1**2*X2-R2**2*X2-X1*X2)/
71461 & (-1+R1**2-R2**2+X2)**2
71462 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
71463 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
71464 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71469 ELSEIF(ICLASS.EQ.12) THEN
71470 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71471 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
71472 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71473 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
71474 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
71475 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
71476 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71477 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71480 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71481 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
71482 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
71483 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
71484 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
71485 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
71486 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71487 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71490 IF(ICOMBI.EQ.4) THEN
71491 RLO4=PS*(1D0-R1**2+R2**2)
71492 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71493 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
71494 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
71495 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
71496 & +R1**2*X2-X1*X2/2-X2**2/2)/
71497 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71502 ELSEIF(ICLASS.EQ.13) THEN
71503 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71504 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71505 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
71506 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
71507 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
71508 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
71509 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
71510 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
71511 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
71512 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
71513 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
71514 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
71515 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
71516 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71517 & (3*(-1+R1**2-R2**2+X2)**2)
71521 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71522 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
71523 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
71524 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
71525 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71526 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
71527 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
71528 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
71529 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
71530 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
71531 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
71532 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71533 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
71534 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
71535 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71536 & (3*(-1+R1**2-R2**2+X2)**2)
71540 IF(ICOMBI.EQ.4) THEN
71541 RLO4=PS*(1D0+R1**2-R2**2)
71542 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
71543 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
71544 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
71545 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
71546 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
71547 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71548 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
71549 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71550 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
71551 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71552 & (3*(-1+R1**2-R2**2+X2)**2)
71558 ELSEIF(ICLASS.EQ.14) THEN
71559 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71560 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
71561 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
71562 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71563 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71564 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
71565 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
71566 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
71567 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
71568 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71569 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71570 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
71571 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
71572 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
71573 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
71575 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
71576 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71577 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71581 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71582 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
71583 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
71584 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71585 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71586 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
71587 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
71588 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
71589 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
71590 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
71591 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
71592 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
71594 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
71595 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
71596 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
71597 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
71598 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
71599 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71603 IF(ICOMBI.EQ.4) THEN
71604 RLO4=PS*(1-R1**2-R2**2)
71605 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
71606 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
71607 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71608 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
71609 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
71610 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
71611 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
71612 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
71613 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
71614 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
71615 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
71616 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
71617 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
71618 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
71619 RFO4=9D0*RFO4/128D0
71624 ELSEIF(ICLASS.EQ.15) THEN
71625 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71626 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
71627 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
71628 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
71629 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
71630 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
71631 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
71632 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
71633 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
71634 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
71635 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
71636 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
71637 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
71638 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
71639 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
71640 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71644 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71645 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
71646 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
71647 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
71648 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
71649 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
71650 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
71651 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
71652 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
71653 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
71654 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71655 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
71656 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
71657 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
71658 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71659 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71663 IF(ICOMBI.EQ.4) THEN
71664 RLO4=PS*(1D0-R1**2+R2**2)
71665 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
71666 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
71667 & -R2**2*X2/2-X1*X2/2)/
71668 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
71669 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
71670 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71671 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
71672 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
71673 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
71674 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
71675 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
71676 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71681 C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
71682 ELSEIF(ICLASS.EQ.16) THEN
71684 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
71686 ELSEIF(ICOMBI.EQ.2) THEN
71687 ANUM=(2D0-X1-X2)**2
71688 ELSEIF(ICOMBI.EQ.3) THEN
71689 ANUM=ALPCOR*(2D0-X1-X2)**2
71691 ANUM=0.5D0*(2D0-X1-X2)**2
71693 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
71694 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
71695 & R1**2/(1D0+R2**2-R1**2-X2)**2-
71696 & R2**2/(1D0+R1**2-R2**2-X1)**2)
71701 C...Find relevant LO and FO expression.
71702 IF(ICOMBI.EQ.0) THEN
71703 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
71706 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
71709 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
71710 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
71711 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
71712 ELSEIF(ISSET4.EQ.1) THEN
71715 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
71716 RLO=0.5D0*(RLO1+RLO2)
71717 RFO=0.5D0*(RFO1+RFO2)
71718 ELSEIF(ISSET1.EQ.1) THEN
71722 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
71733 C*********************************************************************
71736 C...Modifies an event so as to approximately take into account
71737 C...Bose-Einstein effects according to a simple phenomenological
71738 C...parametrization.
71740 SUBROUTINE PYBOEI(NSAV)
71742 C...Double precision and integer declarations.
71743 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71744 IMPLICIT INTEGER(I-N)
71745 INTEGER PYK,PYCHGE,PYCOMP
71746 C...Parameter statement to help give large particle numbers.
71747 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71748 &KEXCIT=4000000,KDIMEN=5000000)
71750 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71751 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71752 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71753 COMMON/PYINT1/MINT(400),VINT(400)
71754 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
71755 C...Local arrays and data.
71756 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
71757 &BEIW(100),BEI3W(100)
71758 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
71759 C...Statement function: squared invariant mass.
71760 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
71761 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
71763 C...Boost event to overall CM frame. Calculate CM energy.
71764 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
71770 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
71771 & .AND.K(I,3).GT.0) THEN
71772 KFMA=IABS(K(K(I,3),2))
71773 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
71775 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
71777 DPS(J)=DPS(J)+P(I,J)
71780 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
71784 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
71787 C...Check if we have separated strings
71789 C...Reserve copy of particles by species at end of record.
71795 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
71796 NBE(IBE)=NBE(IBE-1)
71798 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
71799 DO 140 IIBE=1,IBE-1
71800 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
71803 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
71805 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
71806 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
71807 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
71810 NBE(IBE)=NBE(IBE)+1
71817 P(NBE(IBE),1)=0.0D0
71818 P(NBE(IBE),2)=0.0D0
71819 P(NBE(IBE),3)=0.0D0
71820 P(NBE(IBE),4)=0.0D0
71821 P(NBE(IBE),5)=0.0D0
71822 SMMIN=MIN(SMMIN,P(I,5))
71823 C...Check if particles comes from different W's or Z's
71824 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
71826 150 IF(K(IM,3).GT.0) THEN
71828 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
71830 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
71831 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
71832 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
71833 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
71836 C...Check if particles comes from different strings.
71837 IF(PARJ(94).GT.0.0D0) THEN
71839 160 IF(K(IM,3).GT.0) THEN
71841 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
71849 P(NBE(IBE),5)=-1.0D0
71852 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
71854 C...Calculate separation between W+ and W- or between two Z0's.
71855 C...No separation if there has been re-connections.
71857 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
71858 IF(K(IWP,2).EQ.23) THEN
71867 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
71868 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
71869 TAUP=-TAUPD*LOG(PYR(IDUM))
71870 TAUN=-TAUND*LOG(PYR(IDUM))
71871 DXP=TAUP*PYP(IWP,8)/DMP
71872 DXN=TAUN*PYP(IWN,8)/DMN
71874 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
71875 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
71878 C...Add separation between strings.
71879 IF(PARJ(94).GT.0.0D0) THEN
71880 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
71885 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
71886 DO 220 IBE=1,MIN(9,MSTJ(52))
71887 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
71890 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
71891 IF(I2M.EQ.I1M) GOTO 200
71893 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
71894 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
71895 & (P(I1,5)+P(I2,5))**2
71896 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
71905 C...Tabulate integral for subsequent momentum shift.
71906 DO 400 IBE=1,MIN(9,MSTJ(52))
71907 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
71908 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
71910 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
71911 & NBE(7)-NBE(6)).LE.1) GOTO 270
71912 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
71913 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
71914 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
71915 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
71916 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
71917 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
71918 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
71919 QDELW=0.1D0*MIN(PMHQ,SIGW)
71920 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
71921 IF(MSTJ(51).EQ.1) THEN
71922 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
71923 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
71924 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
71925 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
71926 BEEX=EXP(0.5D0*QDEL/PARJ(93))
71927 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
71928 BEEXW=EXP(0.5D0*QDELW/SIGW)
71929 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
71930 BERT=EXP(-QDEL/PARJ(93))
71931 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
71932 BERTW=EXP(-QDELW/SIGW)
71933 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
71935 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
71936 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
71937 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
71938 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
71941 QBIN=QDEL*(IBIN-0.5D0)
71942 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71943 IF(MSTJ(51).EQ.1) THEN
71945 BEI(IBIN)=BEI(IBIN)*BEEX
71947 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
71949 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
71951 DO 240 IBIN=1,NBIN3
71952 QBIN=QDEL3*(IBIN-0.5D0)
71953 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71954 IF(MSTJ(51).EQ.1) THEN
71956 BEI3(IBIN)=BEI3(IBIN)*BEEX3
71958 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
71960 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
71962 DO 250 IBIN=1,NBINW
71963 QBIN=QDELW*(IBIN-0.5D0)
71964 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71965 IF(MSTJ(51).EQ.1) THEN
71967 BEIW(IBIN)=BEIW(IBIN)*BEEXW
71969 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
71971 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
71973 DO 260 IBIN=1,NBIN3W
71974 QBIN=QDEL3W*(IBIN-0.5D0)
71975 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
71976 & SQRT(QBIN**2+PMHQ**2)
71977 IF(MSTJ(51).EQ.1) THEN
71978 BEEX3W=BEEX3W*BERT3W
71979 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
71981 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
71983 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
71986 C...Loop through particle pairs and find old relative momentum.
71987 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
71989 DO 380 I2M=I1M+1,NBE(IBE)
71990 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
71991 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
71993 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
71994 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
71995 IF(Q2OLD.LE.0.0D0) GOTO 380
71998 C...Calculate new relative momentum.
72003 IF(QOLD.LT.1D-3*QDEL) THEN
72005 ELSEIF(QOLD.LE.QDEL) THEN
72007 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
72010 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
72011 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
72012 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72014 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72016 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
72017 IF(QOLD.LT.1D-3*QDEL3) THEN
72019 ELSEIF(QOLD.LE.QDEL3) THEN
72021 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
72024 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
72025 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
72026 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72028 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72030 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
72033 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
72034 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
72035 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
72037 IF(QOLD.LT.1D-3*QDELW) THEN
72039 ELSEIF(QOLD.LE.QDELW) THEN
72041 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
72044 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
72045 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
72046 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72048 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72050 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
72051 IF(QOLD.LT.1D-3*QDEL3W) THEN
72053 ELSEIF(QOLD.LE.QDEL3W) THEN
72055 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
72058 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
72059 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
72060 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72062 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72064 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
72066 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
72068 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
72070 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
72071 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
72073 IF(MSTJ(54).GE.1) THEN
72074 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
72076 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
72077 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
72079 ELSEIF(MSTJ(54).LE.-1) THEN
72080 EDEL=P(I1,4)+P(I2,4)-
72081 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
72082 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
72083 & (P(I1,3)-P(I2,3))**2
72088 SM1=(P(I1,5)+SMMIN)**2
72089 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72090 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
72091 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
72092 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
72093 & K(I3M,5).NE.K(I1M,5)) GOTO 360
72095 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
72098 SM3=(P(I3,5)+SMMIN)**2
72099 IF(MSTJ(54).EQ.-2) THEN
72100 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
72101 & S23*MIN(SM1,SM3))*SM1)
72103 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
72104 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
72105 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
72106 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
72108 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
72109 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
72112 IF(WMAX*WI.GE.1.0) GOTO 360
72114 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
72115 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
72116 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
72117 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
72118 & K(I4M,5).NE.K(I1M,5)) GOTO 350
72120 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
72122 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
72123 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
72124 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
72126 IF(MSTJ(54).EQ.-2) THEN
72130 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
72131 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
72132 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
72133 W=MIN(W,MIN(S23,S24)*S13*S14)
72136 C...weight=1-cos(theta)/mtot2
72137 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
72138 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
72139 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
72140 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
72142 IF(W.LE.WMAX) GOTO 350
72144 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
72145 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
72146 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
72147 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
72148 IF(W.LE.WMAX) GOTO 350
72154 IF(MI4.EQ.0) GOTO 380
72157 EOLD=P(I3,4)+P(I4,4)
72159 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
72160 & (P(I3,3)+P(I4,3))**2
72161 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
72162 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
72163 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
72165 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
72166 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
72173 C...Shift momenta and recalculate energies.
72177 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72181 P(I,J)=P(I,J)+P(IM,J)
72183 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72186 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
72191 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
72192 440 ALPHA=(ESUMP-ESUM)/PROD
72193 PARJ(96)=PARJ(96)+ALPHA
72196 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72199 P(I,J)=P(I,J)+ALPHA*V(IM,J)
72201 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72204 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
72207 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
72211 C...Rescale all momenta for energy conservation.
72215 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
72217 PQS=PQS+P(I,5)**2/P(I,4)
72220 FAC=(PECM-PQS)/(PES-PQS)
72222 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
72226 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72229 C...Boost back to correct reference frame.
72230 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
72232 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
72238 C*********************************************************************
72241 C...Calculates the momentum shift in a system of two particles assuming
72242 C...the relative momentum squared should be shifted to Q2NEW. NI is the
72243 C...last position occupied in /PYJETS/.
72245 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
72247 C...Double precision and integer declarations.
72248 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72249 IMPLICIT INTEGER(I-N)
72250 INTEGER PYK,PYCHGE,PYCOMP
72251 C...Parameter statement to help give large particle numbers.
72252 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72253 &KEXCIT=4000000,KDIMEN=5000000)
72255 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72256 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72257 SAVE /PYJETS/,/PYDAT1/
72258 C...Local arrays and data.
72262 IF(MSTJ(55).EQ.0) THEN
72264 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
72265 & (P(I1,3)-P(I2,3))**2
72266 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
72267 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
72271 DA=SE*DE*DP12-DP2*DQ2SE
72272 DB=DP2*DQ2SE-DP12**2
72273 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
72275 PD=HA*(P(I1,J)-P(I2,J))
72287 DP(J)=P(I1,J)+P(I2,J)
72290 C...Boost to cms and rotate first particle to z-axis
72291 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
72292 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
72293 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
72294 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
72295 S=Q2NEW+(P(I1,5)+P(I2,5))**2
72296 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
72300 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
72304 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
72305 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
72306 CALL PYROBO(NI+1,NI+2,THE,PHI,
72307 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
72310 P(NI+1,J)=P(NI+1,J)-P(I1,J)
72311 P(NI+2,J)=P(NI+2,J)-P(I2,J)
72317 C*********************************************************************
72320 C...Gives the mass of a particle/parton.
72322 FUNCTION PYMASS(KF)
72324 C...Double precision and integer declarations.
72325 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72326 IMPLICIT INTEGER(I-N)
72327 INTEGER PYK,PYCHGE,PYCOMP
72329 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72330 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72331 SAVE /PYDAT1/,/PYDAT2/
72333 C...Reset variables. Compressed code. Special case for popcorn diquarks.
72342 C...Guarantee use of constituent masses for internal checks.
72343 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
72344 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
72346 PYMASS=PARF(100+KFA)
72347 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
72348 ELSEIF(KFA.LE.10) THEN
72350 ELSEIF(MSTJ(93).EQ.1) THEN
72351 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
72353 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
72356 C...Other masses can be read directly off table.
72361 C...Optional mass broadening according to truncated Breit-Wigner
72362 C...(either in m or in m^2).
72363 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
72364 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
72365 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
72366 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
72369 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
72370 & (PM0*PMAS(KC,2)))
72371 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
72372 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
72373 & (PMUPP-PMLOW)*PYR(0))))
72381 C*********************************************************************
72384 C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
72385 C...for Higgs couplings. Everything else sent on to PYMASS.
72387 FUNCTION PYMRUN(KF,Q2)
72389 C...Double precision and integer declarations.
72390 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72391 IMPLICIT INTEGER(I-N)
72392 INTEGER PYK,PYCHGE,PYCOMP
72394 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72395 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72396 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
72397 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
72399 C...Most masses not handled here.
72401 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
72404 C...Current-algebra masses, but no Q2 dependence.
72405 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
72406 PYMRUN=PARF(90+KFA)
72408 C...Running current-algebra masses.
72411 PYMRUN=PARF(90+KFA)*
72412 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
72413 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
72419 C*********************************************************************
72422 C...Gives the particle/parton name as a character string.
72424 SUBROUTINE PYNAME(KF,CHAU)
72426 C...Double precision and integer declarations.
72427 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72428 IMPLICIT INTEGER(I-N)
72429 INTEGER PYK,PYCHGE,PYCOMP
72431 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72432 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72433 COMMON/PYDAT4/CHAF(500,2)
72435 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
72436 C...Local character variable.
72439 C...Read out code with distinction particle/antiparticle.
72442 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
72448 C*********************************************************************
72451 C...Gives three times the charge for a particle/parton.
72453 FUNCTION PYCHGE(KF)
72455 C...Double precision and integer declarations.
72456 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72457 IMPLICIT INTEGER(I-N)
72458 INTEGER PYK,PYCHGE,PYCOMP
72460 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72463 C...Read out charge and change sign for antiparticle.
72466 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
72471 C*********************************************************************
72474 C...Compress the standard KF codes for use in mass and decay arrays;
72475 C...also checks whether a given code actually is defined.
72477 FUNCTION PYCOMP(KF)
72479 C...Double precision and integer declarations.
72480 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72481 IMPLICIT INTEGER(I-N)
72482 INTEGER PYK,PYCHGE,PYCOMP
72484 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72485 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72486 SAVE /PYDAT1/,/PYDAT2/
72487 C...Local arrays and saved data.
72488 DIMENSION KFORD(100:500),KCORD(101:500)
72489 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
72491 C...Whenever necessary reorder codes for faster search.
72492 IF(MSTU(20).EQ.0) THEN
72497 IF(KFA.LE.100) GOTO 120
72499 DO 100 I1=NFORD-1,0,-1
72500 IF(KFA.GE.KFORD(I1)) GOTO 110
72501 KFORD(I1+1)=KFORD(I1)
72502 KCORD(I1+1)=KCORD(I1)
72504 110 KFORD(I1+1)=KFA
72512 C...Fast action if same code as in latest call.
72513 IF(KF.EQ.KFLAST) THEN
72518 C...Starting values. Remove internal diquark flags.
72521 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
72522 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
72524 C...Simple cases: direct translation.
72525 IF(KFA.GT.KFORD(NFORD)) THEN
72526 ELSEIF(KFA.LE.100) THEN
72529 C...Else binary search.
72533 130 IAVG=(IMIN+IMAX)/2
72534 IF(KFORD(IAVG).GT.KFA) THEN
72536 IF(IMAX.GT.IMIN+1) GOTO 130
72537 ELSEIF(KFORD(IAVG).LT.KFA) THEN
72539 IF(IMAX.GT.IMIN+1) GOTO 130
72545 C...Check if antiparticle allowed.
72546 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
72547 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
72550 C...Save codes for possible future fast action.
72557 C*********************************************************************
72560 C...Informs user of errors in program execution.
72562 SUBROUTINE PYERRM(MERR,CHMESS)
72564 C...Double precision and integer declarations.
72565 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72566 IMPLICIT INTEGER(I-N)
72567 INTEGER PYK,PYCHGE,PYCOMP
72569 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72571 SAVE /PYJETS/,/PYDAT1/
72572 C...Local character variable.
72573 CHARACTER CHMESS*(*)
72575 C...Write first few warnings, then be silent.
72576 IF(MERR.LE.10) THEN
72577 MSTU(27)=MSTU(27)+1
72579 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
72580 & MERR,MSTU(31),CHMESS
72582 C...Write first few errors, then be silent or stop program.
72583 ELSEIF(MERR.LE.20) THEN
72584 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
72585 MSTU(30)=MSTU(30)+1
72587 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
72588 & MERR-10,MSTU(31),CHMESS
72589 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
72590 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
72591 WRITE(MSTU(11),5200)
72592 IF(MERR.NE.17) CALL PYLIST(2)
72596 C...Stop program in case of irreparable error.
72598 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
72602 C...Formats for output.
72603 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
72604 &' PYEXEC calls:'/5X,A)
72605 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
72606 &' PYEXEC calls:'/5X,A)
72607 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
72609 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
72610 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
72615 C*********************************************************************
72618 C...Calculates the running alpha_electromagnetic.
72620 FUNCTION PYALEM(Q2)
72622 C...Double precision and integer declarations.
72623 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72624 IMPLICIT INTEGER(I-N)
72625 INTEGER PYK,PYCHGE,PYCOMP
72627 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72630 C...Calculate real part of photon vacuum polarization.
72631 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
72632 C...For hadrons use parametrization of H. Burkhardt et al.
72633 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
72634 AEMPI=PARU(101)/(3D0*PARU(1))
72635 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
72637 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
72639 ELSEIF(MSTU(101).EQ.2) THEN
72640 RPIGG=1D0-PARU(101)/PARU(103)
72641 ELSEIF(Q2.LT.0.09D0) THEN
72642 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
72643 ELSEIF(Q2.LT.9D0) THEN
72644 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
72645 & 0.00238D0*LOG(1D0+3.927D0*Q2)
72646 ELSEIF(Q2.LT.1D4) THEN
72647 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
72648 & 0.00299D0*LOG(1D0+Q2)
72650 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
72651 & 0.00293D0*LOG(1D0+Q2)
72654 C...Calculate running alpha_em.
72655 PYALEM=PARU(101)/(1D0-RPIGG)
72661 C*********************************************************************
72664 C...Gives the value of alpha_strong.
72666 FUNCTION PYALPS(Q2)
72668 C...Double precision and integer declarations.
72669 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72670 IMPLICIT INTEGER(I-N)
72671 INTEGER PYK,PYCHGE,PYCOMP
72673 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72674 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72675 SAVE /PYDAT1/,/PYDAT2/
72676 C...Coefficients for second-order threshold matching.
72677 C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
72678 DIMENSION STEPDN(6),STEPUP(6)
72679 c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
72680 c &(2D0*321D0/3703D0),0D0/
72681 c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
72682 c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
72683 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
72684 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
72686 C...Constant alpha_strong trivial. Pick artificial Lambda.
72687 IF(MSTU(111).LE.0) THEN
72689 MSTU(118)=MSTU(112)
72691 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
72692 & ((33D0-2D0*MSTU(112))*PARU(111)))
72693 PARU(118)=PARU(111)
72697 C...Find effective Q2, number of flavours and Lambda.
72699 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
72702 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
72703 Q2THR=PARU(113)*PMAS(NF,1)**2
72704 IF(Q2EFF.LT.Q2THR) THEN
72707 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
72708 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
72712 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
72713 Q2THR=PARU(113)*PMAS(NF+1,1)**2
72714 IF(Q2EFF.GT.Q2THR) THEN
72717 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
72718 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
72722 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
72723 PARU(117)=SQRT(ALAM2)
72725 C...Evaluate first or second order alpha_strong.
72726 B0=(33D0-2D0*NF)/6D0
72727 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
72728 IF(MSTU(111).EQ.1) THEN
72729 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
72731 B1=(153D0-19D0*NF)/6D0
72732 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
72741 C*********************************************************************
72744 C...Reconstructs an angle from given x and y coordinates.
72746 FUNCTION PYANGL(X,Y)
72748 C...Double precision and integer declarations.
72749 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72750 IMPLICIT INTEGER(I-N)
72751 INTEGER PYK,PYCHGE,PYCOMP
72753 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72758 IF(R.LT.1D-20) RETURN
72759 IF(ABS(X)/R.LT.0.8D0) THEN
72760 PYANGL=SIGN(ACOS(X/R),Y)
72763 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
72764 PYANGL=PARU(1)-PYANGL
72765 ELSEIF(X.LT.0D0) THEN
72766 PYANGL=-PARU(1)-PYANGL
72773 C*********************************************************************
72776 C...Performs rotations and boosts.
72778 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
72780 C...Double precision and integer declarations.
72781 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72782 IMPLICIT INTEGER(I-N)
72783 INTEGER PYK,PYCHGE,PYCOMP
72785 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72786 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72787 SAVE /PYJETS/,/PYDAT1/
72789 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
72791 C...Find and check range of rotation/boost.
72793 IF(IMIN.LE.0) IMIN=1
72794 IF(MSTU(1).GT.0) IMIN=MSTU(1)
72796 IF(IMAX.LE.0) IMAX=N
72797 IF(MSTU(2).GT.0) IMAX=MSTU(2)
72798 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
72799 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
72803 C...Optional resetting of V (when not set before.)
72804 IF(MSTU(33).NE.0) THEN
72805 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
72813 C...Rotate, typically from z axis to direction (theta,phi).
72814 IF(THE**2+PHI**2.GT.1D-20) THEN
72815 ROT(1,1)=COS(THE)*COS(PHI)
72817 ROT(1,3)=SIN(THE)*COS(PHI)
72818 ROT(2,1)=COS(THE)*SIN(PHI)
72820 ROT(2,3)=SIN(THE)*SIN(PHI)
72825 IF(K(I,1).LE.0) GOTO 140
72831 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
72832 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
72837 C...Boost, typically from rest to momentum/energy=beta.
72838 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
72842 DB=SQRT(DBX**2+DBY**2+DBZ**2)
72844 IF(DB.GT.EPS1) THEN
72845 C...Rescale boost vector if too close to unity.
72846 CALL PYERRM(3,'(PYROBO:) boost vector too large')
72852 DGA=1D0/SQRT(1D0-DB**2)
72854 IF(K(I,1).LE.0) GOTO 160
72859 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
72860 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
72861 P(I,1)=DP(1)+DGABP*DBX
72862 P(I,2)=DP(2)+DGABP*DBY
72863 P(I,3)=DP(3)+DGABP*DBZ
72864 P(I,4)=DGA*(DP(4)+DBP)
72865 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
72866 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
72867 V(I,1)=DV(1)+DGABV*DBX
72868 V(I,2)=DV(2)+DGABV*DBY
72869 V(I,3)=DV(3)+DGABV*DBZ
72870 V(I,4)=DGA*(DV(4)+DBV)
72877 C*********************************************************************
72880 C...Performs global manipulations on the event record, in particular
72881 C...to exclude unstable or undetectable partons/particles.
72883 SUBROUTINE PYEDIT(MEDIT)
72885 C...Double precision and integer declarations.
72886 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72887 IMPLICIT INTEGER(I-N)
72888 INTEGER PYK,PYCHGE,PYCOMP
72889 C...Parameter statement to help give large particle numbers.
72890 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72891 &KEXCIT=4000000,KDIMEN=5000000)
72893 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72894 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72895 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72896 COMMON/PYCTAG/NCT,MCT(4000,2)
72897 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
72899 DIMENSION NS(2),PTS(2),PLS(2)
72901 C...Remove unwanted partons/particles.
72902 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
72904 IF(MSTU(2).GT.0) IMAX=MSTU(2)
72905 I1=MAX(1,MSTU(1))-1
72906 DO 110 I=MAX(1,MSTU(1)),IMAX
72907 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
72908 IF(MEDIT.EQ.1) THEN
72909 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72910 ELSEIF(MEDIT.EQ.2) THEN
72911 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72913 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72914 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72915 & K(I,2).EQ.KSUSY1+39) GOTO 110
72916 ELSEIF(MEDIT.EQ.3) THEN
72917 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72919 IF(KC.EQ.0) GOTO 110
72920 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
72921 ELSEIF(MEDIT.EQ.5) THEN
72922 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
72924 IF(KC.EQ.0) GOTO 110
72925 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
72926 & KCHG(KC,2).EQ.0) GOTO 110
72929 C...Pack remaining partons/particles. Origin no longer known.
72938 IF(I1.LT.N) MSTU(3)=0
72939 IF(I1.LT.N) MSTU(70)=0
72942 C...Selective removal of class of entries. New position of retained.
72943 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
72946 K(I,3)=MOD(K(I,3),MSTU(5))
72947 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
72948 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
72949 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
72950 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
72951 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
72952 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
72953 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
72955 K(I,3)=K(I,3)+MSTU(5)*I1
72958 C...Find new event history information and replace old.
72960 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
72961 & K(I,3)/MSTU(5).EQ.0) GOTO 140
72963 130 IM=MOD(K(ID,3),MSTU(5))
72964 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
72965 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
72966 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
72970 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
72971 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
72972 & K(IM,2).EQ.94) THEN
72977 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
72978 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
72979 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
72980 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
72981 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
72982 & K(K(I,4),3)/MSTU(5)
72983 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
72984 & K(K(I,5),3)/MSTU(5)
72986 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
72987 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
72988 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
72989 KCD=MOD(K(I,4),MSTU(5))
72990 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
72991 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
72992 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
72993 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
72994 KCD=MOD(K(I,5),MSTU(5))
72995 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
72996 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
73000 C...Pack remaining entries.
73005 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
73012 C...Also update LHA1 colour tags
73015 K(I1,3)=MOD(K(I1,3),MSTU(5))
73017 IF(I.EQ.MSTU(90+IZ)) THEN
73018 MSTU(90)=MSTU(90)+1
73019 MSTU(90+MSTU(90))=I1
73020 PARU(90+MSTU(90))=PARU(90+IZ)
73024 IF(I1.LT.N) MSTU(3)=0
73025 IF(I1.LT.N) MSTU(70)=0
73028 C...Fill in some missing daughter pointers (lost in colour flow).
73029 ELSEIF(MEDIT.EQ.16) THEN
73031 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
73032 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
73033 C...Find daughters who point to mother.
73035 IF(K(I1,3).NE.I) THEN
73036 ELSEIF(K(I,4).EQ.0) THEN
73042 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73043 IF(K(I,4).NE.0) GOTO 220
73044 C...Find daughters who point to documentation version of mother.
73046 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
73047 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
73048 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
73050 IF(K(I1,3).NE.IM) THEN
73051 ELSEIF(K(I,4).EQ.0) THEN
73057 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73058 IF(K(I,4).NE.0) GOTO 220
73059 C...Find daughters who point to documentation daughters who,
73060 C...in their turn, point to documentation mother.
73064 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
73066 IF(ID1.EQ.IM) ID1=I1
73070 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
73071 ELSEIF(K(I,4).EQ.0) THEN
73077 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73080 C...Save top entries at bottom of PYJETS commonblock.
73081 ELSEIF(MEDIT.EQ.21) THEN
73082 IF(2*N.GE.MSTU(4)) THEN
73083 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
73088 K(MSTU(4)-I,J)=K(I,J)
73089 P(MSTU(4)-I,J)=P(I,J)
73090 V(MSTU(4)-I,J)=V(I,J)
73095 C...Restore bottom entries of commonblock PYJETS to top.
73096 ELSEIF(MEDIT.EQ.22) THEN
73097 DO 260 I=1,MSTU(32)
73099 K(I,J)=K(MSTU(4)-I,J)
73100 P(I,J)=P(MSTU(4)-I,J)
73101 V(I,J)=V(MSTU(4)-I,J)
73106 C...Mark primary entries at top of commonblock PYJETS as untreated.
73107 ELSEIF(MEDIT.EQ.23) THEN
73112 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
73114 IF(KH.NE.0) GOTO 280
73116 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
73117 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
73121 C...Place largest axis along z axis and second largest in xy plane.
73122 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
73123 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
73124 & P(MSTU(61),2)),0D0,0D0,0D0)
73125 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
73126 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
73127 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
73128 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
73129 IF(MEDIT.EQ.31) RETURN
73131 C...Rotate to put slim jet along +z axis.
73138 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
73139 IF(MSTU(41).GE.2) THEN
73141 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73142 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73143 & K(I,2).EQ.KSUSY1+39) GOTO 300
73144 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
73147 IS=2D0-SIGN(0.5D0,P(I,3))
73149 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
73151 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
73152 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
73154 C...Rotate to put second largest jet into -z,+x quadrant.
73156 IF(P(I,3).GE.0D0) GOTO 310
73157 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
73158 IF(MSTU(41).GE.2) THEN
73160 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73161 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73162 & K(I,2).EQ.KSUSY1+39) GOTO 310
73163 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
73166 IS=2D0-SIGN(0.5D0,P(I,1))
73167 PLS(IS)=PLS(IS)-P(I,3)
73169 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
73176 C*********************************************************************
73179 C...Gives program heading, or lists an event, or particle
73180 C...data, or current parameter values.
73182 SUBROUTINE PYLIST(MLIST)
73184 C...Double precision and integer declarations.
73185 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73186 IMPLICIT INTEGER(I-N)
73187 INTEGER PYK,PYCHGE,PYCOMP
73188 C...Parameter statement to help give large particle numbers.
73189 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
73190 &KEXCIT=4000000,KDIMEN=5000000)
73192 C...HEPEVT commonblock.
73193 PARAMETER (NMXHEP=4000)
73194 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
73195 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
73196 DOUBLE PRECISION PHEP,VHEP
73199 C...User process event common block.
73201 PARAMETER (MAXNUP=500)
73202 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
73203 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
73204 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
73205 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
73206 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
73210 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73211 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73212 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73213 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
73214 COMMON/PYCTAG/NCT,MCT(4000,2)
73215 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
73216 C...Local arrays, character variables and data.
73217 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
73219 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
73221 C...Initialization printout: version number and date of last change.
73222 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
73225 IF(MLIST.EQ.0) RETURN
73228 C...List event data, including additional lines after N.
73229 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
73230 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
73231 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
73232 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
73233 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
73235 IF(MLIST.GE.2) LMX=16
73238 IF(MSTU(2).GT.0) IMAX=MSTU(2)
73239 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
73240 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
73241 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
73242 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
73244 C...Get particle name, pad it and check it is not too long.
73245 CALL PYNAME(K(I,2),CHAP)
73248 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
73252 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
73254 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
73257 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
73259 CHAC=CHDL(MDL)(1:2*LDL)//' '
73261 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
73262 & CHDL(MDL)(LDL+1:2*LDL)//' '
73263 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
73267 C...Add information on string connection.
73268 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
73272 IF(KC.NE.0) KCC=KCHG(KC,2)
73273 IF(IABS(K(I,2)).EQ.39) THEN
73274 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
73275 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
73277 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
73278 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
73279 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
73280 ELSEIF(KCC.NE.0) THEN
73282 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
73285 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
73286 & CHAC(LMX-1:LMX-1)='I'
73288 C...Write data for particle/jet.
73289 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
73290 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
73292 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
73293 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
73295 ELSEIF(MLIST.EQ.1) THEN
73296 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
73298 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
73299 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
73300 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
73301 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
73302 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
73304 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) 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)
73307 & ,10000),MCT(I,1),MCT(I,2)
73309 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
73311 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
73312 & ,MCT(I,1),MCT(I,2)
73314 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
73316 C...Insert extra separator lines specified by user.
73317 IF(MSTU(70).GE.1) THEN
73319 DO 110 J=1,MIN(10,MSTU(70))
73320 IF(I.EQ.MSTU(70+J)) ISEP=1
73323 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
73324 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
73325 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
73330 C...Sum of charges and momenta.
73334 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
73335 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
73336 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
73337 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
73338 ELSEIF(MLIST.EQ.1) THEN
73339 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
73340 ELSEIF(MLIST.LE.3) THEN
73341 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
73343 WRITE(MSTU(11),7000) PS(6)
73346 C...Simple listing of HEPEVT entries (mainly for test purposes).
73347 ELSEIF(MLIST.EQ.5) THEN
73348 WRITE(MSTU(11),7100)
73350 IF(ISTHEP(I).EQ.0) GOTO 140
73351 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
73352 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
73356 C...Simple listing of user-process entries (mainly for test purposes).
73357 ELSEIF(MLIST.EQ.7) THEN
73358 WRITE(MSTU(11),7300)
73360 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
73361 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
73364 C...Give simple list of KF codes defined in program.
73365 ELSEIF(MLIST.EQ.11) THEN
73366 WRITE(MSTU(11),7500)
73368 CALL PYNAME(KF,CHAP)
73369 CALL PYNAME(-KF,CHAN)
73370 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
73371 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73375 DO 170 KFLB=1,KFLA-(3-KFLS)/2
73376 KF=1000*KFLA+100*KFLB+KFLS
73377 CALL PYNAME(KF,CHAP)
73378 CALL PYNAME(-KF,CHAN)
73379 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73385 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
73386 IF(KMUL.EQ.5) KFLS=5
73388 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
73389 IF(KMUL.EQ.4) KFLR=2
73391 DO 200 KFLC=1,KFLB-1
73392 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
73393 CALL PYNAME(KF,CHAP)
73394 CALL PYNAME(-KF,CHAN)
73395 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73398 CALL PYNAME(KFK,CHAP)
73399 WRITE(MSTU(11),7600) KFK,CHAP
73401 CALL PYNAME(KFK,CHAP)
73402 WRITE(MSTU(11),7600) KFK,CHAP
73405 KF=10000*KFLR+110*KFLB+KFLS
73406 CALL PYNAME(KF,CHAP)
73407 WRITE(MSTU(11),7600) KF,CHAP
73411 CALL PYNAME(KF,CHAP)
73412 WRITE(MSTU(11),7600) KF,CHAP
73414 CALL PYNAME(KF,CHAP)
73415 WRITE(MSTU(11),7600) KF,CHAP
73421 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
73423 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
73424 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
73425 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
73426 CALL PYNAME(KF,CHAP)
73427 CALL PYNAME(-KF,CHAN)
73428 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73435 IF(KF.LT.1000000) GOTO 270
73436 CALL PYNAME(KF,CHAP)
73437 CALL PYNAME(-KF,CHAN)
73438 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
73439 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73442 C...List parton/particle data table. Check whether to be listed.
73443 ELSEIF(MLIST.EQ.12) THEN
73444 WRITE(MSTU(11),7700)
73445 DO 300 KC=1,MSTU(6)
73447 IF(KF.EQ.0) GOTO 300
73448 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
73451 C...Find particle name and mass. Print information.
73452 CALL PYNAME(KF,CHAP)
73453 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
73454 CALL PYNAME(-KF,CHAN)
73455 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
73456 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
73458 C...Particle decay: channel number, branching ratios, matrix element,
73459 C...decay products.
73460 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73462 CALL PYNAME(KFDP(IDC,J),CHAD(J))
73464 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
73469 C...List parameter value table.
73470 ELSEIF(MLIST.EQ.13) THEN
73471 WRITE(MSTU(11),8000)
73473 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
73477 C...Format statements for output on unit MSTU(11) (by default 6).
73478 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
73479 &5X,'KF orig p_x p_y p_z E m'/)
73480 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
73481 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73482 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
73483 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
73484 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73485 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
73486 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
73487 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
73488 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
73489 & ,' C tag AC tag'/)
73490 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
73491 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
73492 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
73493 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
73494 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
73495 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
73496 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
73497 6200 FORMAT(66X,5(1X,F12.3))
73498 6300 FORMAT(1X,78('='))
73499 6400 FORMAT(1X,130('='))
73500 6500 FORMAT(1X,65('='))
73501 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
73502 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
73503 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
73504 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
73506 7000 FORMAT(19X,'sum charge:',F6.2)
73507 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
73508 &//' I IST ID Mothers Daughters p_x p_y p_z',
73510 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
73511 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
73512 &//' I IST ID Mothers Colours p_x p_y p_z',
73514 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
73515 7500 FORMAT(///20X,'List of KF codes in program'/)
73516 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
73517 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
73518 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
73519 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
73520 &1X,'ME',3X,'Br.rat.',4X,'decay products')
73521 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
73522 &1X,1P,E13.5,3X,I2)
73523 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
73524 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
73525 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
73526 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
73531 C*********************************************************************
73534 C...Writes a logo for the program.
73538 C...Double precision and integer declarations.
73539 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73540 IMPLICIT INTEGER(I-N)
73541 INTEGER PYK,PYCHGE,PYCOMP
73542 C...Parameter for length of information block.
73543 PARAMETER (IREFER=21)
73545 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73546 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
73547 SAVE /PYDAT1/,/PYPARS/
73548 C...Local arrays and character variables.
73550 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
73551 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
73553 C...Data on months, logo, titles, and references.
73554 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
73555 &'Oct','Nov','Dec'/
73556 DATA (LOGO(J),J=1,19)/
73558 &' *:::!!:::::::::::* ',
73559 &' *::::::!!::::::::::::::* ',
73560 &' *::::::::!!::::::::::::::::* ',
73561 &' *:::::::::!!:::::::::::::::::* ',
73562 &' *:::::::::!!:::::::::::::::::* ',
73563 &' *::::::::!!::::::::::::::::*! ',
73564 &' *::::::!!::::::::::::::* !! ',
73565 &' !! *:::!!:::::::::::* !! ',
73566 &' !! !* -><- * !! ',
73576 DATA (LOGO(J),J=20,38)/
73577 &'Welcome to the Lund Monte Carlo!',
73579 &'PPP Y Y TTTTT H H III A ',
73580 &'P P Y Y T H H I A A ',
73581 &'PPP Y T HHHHH I AAAAA',
73582 &'P Y T H H I A A',
73583 &'P Y T H H III A A',
73585 &'This is PYTHIA version x.xxx ',
73586 &'Last date of change: xx xxx 200x',
73588 &'Now is xx xxx 200x at xx:xx:xx ',
73590 &'Disclaimer: this program comes ',
73591 &'without any guarantees. Beware ',
73592 &'of errors and use common sense ',
73593 &'when interpreting results. ',
73595 &'Copyright T. Sjostrand (2008) '/
73596 DATA (REFER(J),J=1,14)/
73597 &'An archive of program versions and d',
73598 &'ocumentation is found on the web: ',
73599 &'http://www.thep.lu.se/~torbjorn/Pyth',
73603 &'When you cite this program, the offi',
73604 &'cial reference is to the 6.4 manual:',
73605 &'T. Sjostrand, S. Mrenna and P. Skand',
73606 &'s, JHEP05 (2006) 026 ',
73607 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
73608 &'-T) [hep-ph/0603175]. ',
73611 DATA (REFER(J),J=15,32)/
73612 &'Also remember that the program, to a',
73613 &' large extent, represents original ',
73614 &'physics research. Other publications',
73615 &' of special relevance to your ',
73616 &'studies may therefore deserve separa',
73620 &'Main author: Torbjorn Sjostrand; Dep',
73621 &'artment of Theoretical Physics, ',
73622 &' Lund University, Solvegatan 14A, S',
73623 &'-223 62 Lund, Sweden; ',
73624 &' phone: + 46 - 46 - 222 48 16; e-ma',
73625 &'il: torbjorn@thep.lu.se ',
73626 &'Author: Stephen Mrenna; Computing Di',
73627 &'vision, GDS Group, ',
73628 &' Fermi National Accelerator Laborat',
73629 &'ory, MS 234, Batavia, IL 60510, USA;'/
73630 DATA (REFER(J),J=33,2*IREFER)/
73631 &' phone: + 1 - 630 - 840 - 2556; e-m',
73632 &'ail: mrenna@fnal.gov ',
73633 &'Author: Peter Skands; Theoretical Ph',
73634 &'ysics Department, ',
73635 &' Fermi National Accelerator Laborat',
73636 &'ory, MS 106, Batavia, IL 60510, USA;',
73637 &' and CERN/PH, CH-1211 Geneva, Switz',
73639 &' phone: + 41 - 22 - 767 24 59; e-ma',
73640 &'il: skands@fnal.gov '/
73642 C...Check that PYDATA linked.
73643 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
73645 & 'Error: PYDATA has not been linked.'
73646 WRITE(*,'(1X,A)') 'Execution stopped!'
73649 C...Write current version number and current date+time.
73651 WRITE(VERS,'(I1)') MSTP(181)
73652 LOGO(28)(24:24)=VERS
73653 WRITE(SUBV,'(I3)') MSTP(182)
73654 LOGO(28)(26:28)=SUBV
73655 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
73656 WRITE(DATE,'(I2)') MSTP(185)
73657 LOGO(29)(22:23)=DATE
73658 LOGO(29)(25:27)=MONTH(MSTP(184))
73659 WRITE(YEAR,'(I4)') MSTP(183)
73660 LOGO(29)(29:32)=YEAR
73662 IF(IDATI(1).LE.0) THEN
73665 WRITE(DATE,'(I2)') IDATI(3)
73667 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
73668 WRITE(YEAR,'(I4)') IDATI(1)
73669 LOGO(31)(15:18)=YEAR
73670 WRITE(HOUR,'(I2)') IDATI(4)
73671 LOGO(31)(23:24)=HOUR
73672 WRITE(MINU,'(I2)') IDATI(5)
73673 LOGO(31)(26:27)=MINU
73674 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
73675 WRITE(SECO,'(I2)') IDATI(6)
73676 LOGO(31)(29:30)=SECO
73677 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
73681 C...Loop over lines in header. Define page feed and side borders.
73682 DO 100 ILIN=1,29+IREFER
73691 C...Separator lines and logos.
73692 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
73693 LINE(4:77)='***********************************************'//
73694 & '***************************'
73695 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
73696 LINE(6:37)=LOGO(ILIN-5)
73697 LINE(44:75)=LOGO(ILIN+14)
73698 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
73699 LINE(5:40)=REFER(2*ILIN-51)
73700 LINE(41:76)=REFER(2*ILIN-50)
73703 C...Write lines to appropriate unit.
73704 WRITE(MSTU(11),'(A79)') LINE
73710 C*********************************************************************
73713 C...Facilitates the updating of particle and decay data
73714 C...by allowing it to be done in an external file.
73716 SUBROUTINE PYUPDA(MUPDA,LFN)
73718 C...Double precision and integer declarations.
73719 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73720 IMPLICIT INTEGER(I-N)
73721 INTEGER PYK,PYCHGE,PYCOMP
73723 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73724 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73725 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
73726 COMMON/PYDAT4/CHAF(500,2)
73728 COMMON/PYINT4/MWID(500),WIDS(500,5)
73729 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
73730 C...Local arrays, character variables and data.
73731 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
73732 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
73733 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
73734 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
73735 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
73736 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
73737 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
73739 C...Write header if not yet done.
73740 IF(MSTU(12).NE.12345) CALL PYLIST(0)
73742 C...Write information on file for editing.
73743 IF(MUPDA.EQ.1) THEN
73745 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
73746 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
73747 & MWID(KC),MDCY(KC,1)
73748 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73749 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
73750 & (KFDP(IDC,J),J=1,5)
73754 C...Read complete set of information from edited file or
73755 C...read partial set of new or updated information from edited file.
73756 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
73758 C...Reset counters.
73762 IF(MUPDA.EQ.2) THEN
73767 DO 130 KC=1,MSTU(6)
73768 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
73769 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
73773 C...Begin of loop: read new line; unknown whether particle or
73775 140 READ(LFN,5200,END=190) CHINL
73777 C...Identify particle code and whether already defined (for MUPDA=3).
73778 IF(CHINL(2:10).NE.' ') THEN
73781 IF(MUPDA.EQ.2) THEN
73794 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
73797 C...Remove duplicate old decay data.
73798 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
73799 IDCREP=MDCY(KCREP,2)
73800 NDCREP=MDCY(KCREP,3)
73802 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
73804 DO 180 I=IDCREP,NDC-NDCREP
73805 MDME(I,1)=MDME(I+NDCREP,1)
73806 MDME(I,2)=MDME(I+NDCREP,2)
73807 BRAT(I)=BRAT(I+NDCREP)
73809 KFDP(I,J)=KFDP(I+NDCREP,J)
73814 ELSEIF(KCREP.NE.0) THEN
73822 C...Study line with particle data.
73823 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
73824 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
73825 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
73826 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
73827 & MWID(KC),MDCY(KC,1)
73831 C...Study line with decay data.
73834 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
73835 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
73836 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
73837 MDCY(KC,3)=MDCY(KC,3)+1
73838 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
73839 & (KFDP(NDC,J),J=1,5)
73842 C...End of loop; ensure that PYCOMP tables are updated.
73847 C...Perform possible tests that new information is consistent.
73848 DO 220 KC=1,MSTU(6)
73850 IF(KF.EQ.0) GOTO 220
73851 WRITE(CHKF,5300) KF
73852 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
73853 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
73854 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
73856 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73857 IF(MDME(IDC,2).GT.80) GOTO 210
73859 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
73863 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
73865 ELSEIF(PYCOMP(KP).EQ.0) THEN
73870 PMS=PMS-PMAS(KPC,1)
73871 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
73875 IF(KQ.NE.0) MERR=MAX(2,MERR)
73876 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
73878 IF(MERR.EQ.3) CALL PYERRM(17,
73879 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
73880 IF(MERR.EQ.2) CALL PYERRM(17,
73881 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
73882 IF(MERR.EQ.1) CALL PYERRM(7,
73883 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
73884 BRSUM=BRSUM+BRAT(IDC)
73886 WRITE(CHTMP,5500) BRSUM
73887 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
73888 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
73889 & CHTMP(9:16)//' for KF ='//CHKF)
73892 C...Write DATA statements for inclusion in program.
73893 ELSEIF(MUPDA.EQ.4) THEN
73895 C...Find out how many codes and decay channels are actually used.
73899 IF(KCHG(I,4).NE.0) THEN
73901 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
73905 C...Initialize writing of DATA statements for inclusion in program.
73908 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
73911 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
73915 C...Loop through variables for conversion to characters.
73917 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
73918 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
73919 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
73920 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
73921 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
73922 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
73923 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
73924 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
73925 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
73926 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
73927 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
73928 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
73929 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
73930 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
73931 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
73932 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
73933 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
73934 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
73935 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
73936 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
73937 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
73938 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
73940 C...Replace variables beyond what is properly defined.
73942 IF(IDIM.GT.KCC) CHTMP=' 0'
73943 ELSEIF(IVAR.LE.8) THEN
73944 IF(IDIM.GT.KCC) CHTMP=' 0.0'
73945 ELSEIF(IVAR.LE.11) THEN
73946 IF(IDIM.GT.KCC) CHTMP=' 0'
73947 ELSEIF(IVAR.LE.13) THEN
73948 IF(IDIM.GT.NDC) CHTMP=' 0'
73949 ELSEIF(IVAR.LE.14) THEN
73950 IF(IDIM.GT.NDC) CHTMP=' 0.0'
73951 ELSEIF(IVAR.LE.19) THEN
73952 IF(IDIM.GT.NDC) CHTMP=' 0'
73953 ELSEIF(IVAR.LE.21) THEN
73954 IF(IDIM.GT.KCC) CHTMP=' '
73956 IF(IDIM.GT.KCC) CHTMP=' 0'
73959 C...Length of variable, trailing decimal zeros, quotation marks.
73963 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
73964 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
73966 CHNEW=CHTMP(LLOW:LHIG)//' '
73968 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
73971 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
73972 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
73977 CHNEW(LNEW+1:LNEW+2)='D0'
73980 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
73981 DO 260 LL=LNEW,1,-1
73982 IF(CHNEW(LL:LL).EQ.'''') THEN
73984 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
73990 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
73994 C...Form composite character string, often including repetition counter.
73995 IF(CHNEW.NE.CHOLD) THEN
74002 IF(NRPT.GE.2) LRPT=LNEW+3
74003 IF(NRPT.GE.10) LRPT=LNEW+4
74004 IF(NRPT.GE.100) LRPT=LNEW+5
74005 IF(NRPT.GE.1000) LRPT=LNEW+6
74008 WRITE(CHTMP,5400) NRPT
74010 IF(NRPT.GE.10) LRPT=2
74011 IF(NRPT.GE.100) LRPT=3
74012 IF(NRPT.GE.1000) LRPT=4
74013 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
74017 C...Add characters to end of line, to new line (after storing old line),
74018 C...or to new block of lines (after writing old block).
74019 IF(LLIN+LCOM.LE.70) THEN
74020 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
74022 ELSEIF(NLIN.LE.19) THEN
74023 CHLIN(LLIN+1:72)=' '
74026 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
74029 CHLIN(LLIN:72)='/'//' '
74031 WRITE(CHTMP,5400) IDIM-NRPT
74032 CHBLK(1)(30:33)=CHTMP(13:16)
74034 WRITE(LFN,5700) CHBLK(ILIN)
74038 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
74039 & ',I= , )/'//CHCOM(1:LCOM)//','
74040 WRITE(CHTMP,5400) IDIM-NRPT+1
74041 CHLIN(25:28)=CHTMP(13:16)
74046 C...Write final block of lines.
74047 CHLIN(LLIN:72)='/'//' '
74049 WRITE(CHTMP,5400) NDIM
74050 CHBLK(1)(30:33)=CHTMP(13:16)
74052 WRITE(LFN,5700) CHBLK(ILIN)
74057 C...Formats for reading and writing particle data.
74058 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
74059 5100 FORMAT(10X,2I5,F12.6,5I10)
74070 C*********************************************************************
74073 C...Provides various integer-valued event related data.
74077 C...Double precision and integer declarations.
74078 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74079 IMPLICIT INTEGER(I-N)
74080 INTEGER PYK,PYCHGE,PYCOMP
74082 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74083 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74084 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74085 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74087 C...Default value. For I=0 number of entries, number of stable entries
74088 C...or 3 times total charge.
74090 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
74091 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
74093 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
74095 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
74096 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
74099 ELSEIF(I.EQ.0) THEN
74101 C...For I > 0 direct readout of K matrix or charge.
74102 ELSEIF(J.LE.5) THEN
74104 ELSEIF(J.EQ.6) THEN
74107 C...Status (existing/fragmented/decayed), parton/hadron separation.
74108 ELSEIF(J.LE.8) THEN
74109 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
74110 IF(J.EQ.8) PYK=PYK*K(I,2)
74111 ELSEIF(J.LE.12) THEN
74115 IF(KC.NE.0) KQ=KCHG(KC,2)
74116 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
74117 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
74119 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
74121 C...Heaviest flavour in hadron/diquark.
74122 ELSEIF(J.EQ.13) THEN
74124 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
74125 IF(KFA.LT.10) PYK=KFA
74126 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
74127 PYK=PYK*ISIGN(1,K(I,2))
74129 C...Particle history: generation, ancestor, rank.
74130 ELSEIF(J.LE.15) THEN
74137 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
74140 ELSEIF(J.EQ.16) THEN
74142 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
74143 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
74150 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
74151 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
74153 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
74154 IF(ILP.EQ.1) GOTO 120
74156 IF(K(I1,1).EQ.12) THEN
74158 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
74159 & .AND.K(I3,2).NE.93) PYK=PYK+1
74165 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
74169 C...Particle coming from collapsing jet system or not.
74170 ELSEIF(J.EQ.17) THEN
74177 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
74178 IF(PYK.EQ.1) PYK=-1
74182 IF(KCHG(KC,2).EQ.0) GOTO 150
74183 IF(K(I1,1).NE.12) PYK=0
74184 IF(K(I1,1).NE.12) RETURN
74187 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
74189 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
74191 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
74193 C...Number of decay products. Colour flow.
74194 ELSEIF(J.EQ.18) THEN
74195 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
74196 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
74197 ELSEIF(J.LE.22) THEN
74198 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
74199 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
74200 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
74201 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
74202 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
74209 C*********************************************************************
74212 C...Provides various real-valued event related data.
74216 C...Double precision and integer declarations.
74217 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74218 IMPLICIT INTEGER(I-N)
74219 INTEGER PYK,PYCHGE,PYCOMP
74221 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74222 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74223 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74224 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74228 C...Set default value. For I = 0 sum of momenta or charges,
74229 C...or invariant mass of system.
74231 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
74232 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
74234 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
74236 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
74240 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
74244 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
74245 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
74247 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
74249 ELSEIF(I.EQ.0) THEN
74251 C...Direct readout of P matrix.
74252 ELSEIF(J.LE.5) THEN
74255 C...Charge, total momentum, transverse momentum, transverse mass.
74256 ELSEIF(J.LE.12) THEN
74257 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
74258 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
74259 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
74260 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
74261 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
74263 C...Theta and phi angle in radians or degrees.
74264 ELSEIF(J.LE.16) THEN
74265 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
74266 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
74267 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
74269 C...True rapidity, rapidity with pion mass, pseudorapidity.
74270 ELSEIF(J.LE.19) THEN
74272 IF(J.EQ.17) PMR=P(I,5)
74273 IF(J.EQ.18) PMR=PYMASS(211)
74274 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
74275 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
74278 C...Energy and momentum fractions (only to be used in CM frame).
74279 ELSEIF(J.LE.25) THEN
74280 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
74281 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
74282 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
74283 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
74284 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
74285 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
74291 C*********************************************************************
74294 C...Performs sphericity tensor analysis to give sphericity,
74295 C...aplanarity and the related event axes.
74297 SUBROUTINE PYSPHE(SPH,APL)
74299 C...Double precision and integer declarations.
74300 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74301 IMPLICIT INTEGER(I-N)
74302 INTEGER PYK,PYCHGE,PYCOMP
74303 C...Parameter statement to help give large particle numbers.
74304 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74305 &KEXCIT=4000000,KDIMEN=5000000)
74307 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74308 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74309 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74310 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74312 DIMENSION SM(3,3),SV(3,3)
74314 C...Calculate matrix to be diagonalized.
74323 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
74324 IF(MSTU(41).GE.2) THEN
74326 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74327 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74328 & K(I,2).EQ.KSUSY1+39) GOTO 140
74329 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74333 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74335 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
74336 & MAX(1D-10,PA)**(PARU(41)-2D0)
74339 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
74345 C...Very low multiplicities (0 or 1) not considered.
74347 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
74354 SM(J1,J2)=SM(J1,J2)/PS
74358 C...Find eigenvalues to matrix (third degree equation).
74359 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
74360 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
74361 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
74362 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
74363 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
74364 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
74365 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
74366 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
74367 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
74368 IF(P(N+2,4).LT.1D-5) THEN
74369 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
74375 C...Find first and last eigenvector by solving equation system.
74378 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
74380 SV(J1,J2)=SM(J1,J2)
74381 SV(J2,J1)=SM(J1,J2)
74387 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
74390 SMAX=ABS(SV(J1,J2))
74394 DO 220 J3=JA+1,JA+2
74396 RL=SV(J1,JB)/SV(JA,JB)
74398 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
74399 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
74401 SMAX=ABS(SV(J1,J2))
74405 JB2=JB+2-3*((JB+1)/3)
74406 P(N+I,JB1)=-SV(JC,JB2)
74407 P(N+I,JB2)=SV(JC,JB1)
74408 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
74410 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
74411 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74413 P(N+I,J)=SGN*P(N+I,J)/PA
74417 C...Middle axis orthogonal to other two. Fill other codes.
74418 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74419 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
74420 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
74421 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
74434 C...Calculate sphericity and aplanarity. Select storing option.
74435 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
74439 IF(MSTU(43).LE.1) MSTU(3)=3
74440 IF(MSTU(43).GE.2) N=N+3
74445 C*********************************************************************
74448 C...Performs thrust analysis to give thrust, oblateness
74449 C...and the related event axes.
74451 SUBROUTINE PYTHRU(THR,OBL)
74453 C...Double precision and integer declarations.
74454 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74455 IMPLICIT INTEGER(I-N)
74456 INTEGER PYK,PYCHGE,PYCOMP
74457 C...Parameter statement to help give large particle numbers.
74458 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74459 &KEXCIT=4000000,KDIMEN=5000000)
74461 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74462 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74463 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74464 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74466 DIMENSION TDI(3),TPR(3)
74468 C...Take copy of particles that are to be considered in thrust analysis.
74472 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
74473 IF(MSTU(41).GE.2) THEN
74475 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74476 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74477 & K(I,2).EQ.KSUSY1+39) GOTO 100
74478 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74481 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
74482 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
74492 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74494 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
74495 & P(N+NP,4)**(PARU(42)-1D0)
74496 PS=PS+P(N+NP,4)*P(N+NP,5)
74499 C...Very low multiplicities (0 or 1) not considered.
74501 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
74507 C...Loop over thrust and major. T axis along z direction in latter case.
74511 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
74513 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
74514 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
74515 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
74518 C...Find and order particles with highest p (pT for major).
74519 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
74523 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
74524 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
74525 IF(P(I,4).LE.P(ILF,4)) GOTO 140
74527 P(ILF+1,J)=P(ILF,J)
74536 C...Find and order initial axes with highest thrust (major).
74537 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
74540 NC=2**(MIN(MSTU(44),NP)-1)
74545 DO 200 ILF=1,MIN(MSTU(44),NP)
74546 SGN=P(N+NP+ILF+3,5)
74547 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
74549 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
74552 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
74553 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
74554 IF(TDS.LE.P(ILG,4)) GOTO 230
74556 P(ILG+1,J)=P(ILG,J)
74559 ILG=N+NP+MSTU(44)+4
74566 C...Iterate direction of axis until stable maximum.
74573 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
74574 IF(THP.GT.1D-10) TDI(J)=TPR(J)
74578 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
74580 TPR(J)=TPR(J)+SGN*P(I,J)
74583 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
74584 IF(THP.GE.THPS+PARU(48)) GOTO 270
74586 C...Save good axis. Try new initial axis until a number of tries agree.
74587 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
74588 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
74590 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74592 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
74598 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
74601 C...Find minor axis and value by orthogonality.
74602 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74603 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
74604 P(N+NP+3,2)=SGN*P(N+NP+2,1)
74608 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
74613 C...Fill axis information. Rotate back to original coordinate system.
74621 P(N+ILD,J)=P(N+NP+ILD,J)
74625 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
74627 C...Calculate thrust and oblateness. Select storing option.
74629 OBL=P(N+2,4)-P(N+3,4)
74632 IF(MSTU(43).LE.1) MSTU(3)=3
74633 IF(MSTU(43).GE.2) N=N+3
74638 C*********************************************************************
74641 C...Subdivides the particle content of an event into jets/clusters.
74643 SUBROUTINE PYCLUS(NJET)
74645 C...Double precision and integer declarations.
74646 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74647 IMPLICIT INTEGER(I-N)
74648 INTEGER PYK,PYCHGE,PYCOMP
74649 C...Parameter statement to help give large particle numbers.
74650 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74651 &KEXCIT=4000000,KDIMEN=5000000)
74653 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74654 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74655 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74656 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74657 C...Local arrays and saved variables.
74659 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
74661 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
74662 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
74663 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
74664 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
74665 &P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
74666 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
74667 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
74669 C...If first time, reset. If reentering, skip preliminaries.
74670 IF(MSTU(48).LE.0) THEN
74676 PIMASS=PMAS(PYCOMP(211),1)
74679 IF(MSTU(43).GE.2) N=N-NJET
74680 DO 110 I=N+1,N+NJET
74681 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74683 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
74686 R2ACC=PARU(45)*PS(5)**2
74692 C...Find which particles are to be considered in cluster search.
74694 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
74695 IF(MSTU(41).GE.2) THEN
74697 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74698 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74699 & K(I,2).EQ.KSUSY1+39) GOTO 140
74700 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74703 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
74704 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
74709 C...Take copy of these particles, with space left for jets later on.
74715 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
74716 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
74717 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
74718 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74720 PS(J)=PS(J)+P(N+NP,J)
74730 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
74732 C...Very low multiplicities not considered.
74733 IF(NP.LT.MSTU(47)) THEN
74734 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
74739 C...Find precluster configuration. If too few jets, make harder cuts.
74741 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
74744 R2ACC=PARU(45)*PS(5)**2
74746 RINIT=1.25D0*PARU(43)
74747 IF(NP.LE.MSTU(47)+2) RINIT=0D0
74748 170 RINIT=0.8D0*RINIT
74751 DO 180 I=N+NP+1,N+2*NP
74755 C...Sum up small momentum region. Jet if enough absolute momentum.
74756 IF(MSTU(46).LE.2) THEN
74760 DO 210 I=N+NP+1,N+2*NP
74761 IF(P(I,5).GT.2D0*RINIT) GOTO 210
74765 P(N+1,J)=P(N+1,J)+P(I,J)
74768 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
74769 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
74770 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
74771 IF(NREM.EQ.0) GOTO 170
74774 C...Find fastest remaining particle.
74777 DO 230 I=N+NP+1,N+2*NP
74778 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
74783 P(N+NPRE,J)=P(IMAX,J)
74788 C...Sum up precluster around it according to pT separation.
74789 IF(MSTU(46).LE.2) THEN
74790 DO 260 I=N+NP+1,N+2*NP
74791 IF(K(I,4).NE.0) GOTO 260
74793 IF(R2.GT.RINIT**2) GOTO 260
74797 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
74800 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
74802 C...Sum up precluster around it according to mass or
74803 C...Durham pT separation.
74807 DO 280 I=N+NP+1,N+2*NP
74808 IF(K(I,4).NE.0) GOTO 280
74809 IF(MSTU(46).LE.4) THEN
74814 IF(R2.GE.R2MIN) GOTO 280
74820 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
74822 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
74829 C...Check if more preclusters to be found. Start over if too few.
74830 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
74831 IF(NREM.GT.0) GOTO 220
74834 C...Reassign all particles to nearest jet. Sum up new jet momenta.
74837 310 IF(MSTU(46).LE.1) THEN
74838 DO 330 I=N+1,N+NJET
74843 DO 360 I=N+NP+1,N+2*NP
74845 DO 340 IJET=N+1,N+NJET
74846 IF(P(IJET,5).LT.RINIT) GOTO 340
74848 IF(R2.GE.R2MIN) GOTO 340
74854 V(IMIN,J)=V(IMIN,J)+P(I,J)
74858 DO 380 I=N+1,N+NJET
74862 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74867 C...Find two closest jets.
74868 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
74869 DO 400 ITRY1=N+1,N+NJET-1
74870 DO 390 ITRY2=ITRY1+1,N+NJET
74871 IF(MSTU(46).LE.2) THEN
74872 R2=R2T(ITRY1,ITRY2)
74873 ELSEIF(MSTU(46).LE.4) THEN
74874 R2=R2M(ITRY1,ITRY2)
74876 R2=R2D(ITRY1,ITRY2)
74878 IF(R2.GE.R2MIN) GOTO 390
74885 C...If allowed, join two closest jets and start over.
74886 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
74887 IREC=MIN(IMIN1,IMIN2)
74888 IDEL=MAX(IMIN1,IMIN2)
74890 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
74892 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
74893 DO 430 I=IDEL+1,N+NJET
74898 IF(MSTU(46).GE.2) THEN
74899 DO 440 I=N+NP+1,N+2*NP
74901 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
74902 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
74908 C...Divide up broad jet if empty cluster in list of final ones.
74909 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
74910 DO 450 I=N+1,N+NJET
74913 DO 460 I=N+NP+1,N+2*NP
74914 K(N+K(I,4),5)=K(N+K(I,4),5)+1
74917 DO 470 I=N+1,N+NJET
74918 IF(K(I,5).EQ.0) IEMP=I
74924 DO 480 I=N+NP+1,N+2*NP
74925 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
74928 IF(R2.LE.R2MAX) GOTO 480
74935 P(IEMP,J)=P(ISPL,J)
74936 P(IJET,J)=P(IJET,J)-P(ISPL,J)
74938 P(IEMP,5)=P(ISPL,5)
74939 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
74940 IF(NLOOP.LE.2) GOTO 300
74945 C...If generalized thrust has not yet converged, continue iteration.
74946 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
74952 C...Reorder jets according to energy.
74953 DO 510 I=N+1,N+NJET
74958 DO 540 INEW=N+1,N+NJET
74960 DO 520 ITRY=N+1,N+NJET
74961 IF(V(ITRY,4).LE.PEMAX) GOTO 520
74970 P(INEW,J)=V(IMAX,J)
74976 C...Clean up particle-jet assignments and jet information.
74977 DO 550 I=N+NP+1,N+2*NP
74980 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
74981 K(IORI,4)=K(IORI,4)+1
74985 DO 570 I=N+1,N+NJET
74988 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
74992 IF(K(I,4).EQ.0) IEMP=I
74995 C...Select storing option. Output variables. Check for failure.
75001 PARU(63)=SQRT(R2MIN)
75002 IF(NJET.LE.1) PARU(63)=0D0
75004 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
75008 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
75009 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
75015 C*********************************************************************
75018 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
75019 C...as used for calorimeters at hadron colliders.
75021 SUBROUTINE PYCELL(NJET)
75023 C...Double precision and integer declarations.
75024 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75025 IMPLICIT INTEGER(I-N)
75026 INTEGER PYK,PYCHGE,PYCOMP
75027 C...Parameter statement to help give large particle numbers.
75028 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75029 &KEXCIT=4000000,KDIMEN=5000000)
75031 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75032 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75033 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75034 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75036 C...Loop over all particles. Find cell that was hit by given particle.
75037 PTLRAT=1D0/SINH(PARU(51))**2
75041 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
75042 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
75043 IF(MSTU(41).GE.2) THEN
75045 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75046 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75047 & K(I,2).EQ.KSUSY1+39) GOTO 110
75048 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75052 PT=SQRT(P(I,1)**2+P(I,2)**2)
75053 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
75054 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
75055 & (ETA/PARU(51)+1D0))))
75056 PHI=PYANGL(P(I,1),P(I,2))
75057 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
75058 & (PHI/PARU(1)+1D0))))
75059 IETPH=MSTU(52)*IETA+IPHI
75061 C...Add to cell already hit, or book new cell.
75063 IF(IETPH.EQ.K(IC,3)) THEN
75069 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
75070 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
75078 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
75079 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
75083 C...Smear true bin content by calorimeter resolution.
75084 IF(MSTU(53).GE.1) THEN
75087 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
75088 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
75089 & COS(PARU(2)*PYR(0))
75090 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
75092 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
75096 C...Remove cells below threshold.
75097 IF(PARU(58).GT.0D0) THEN
75101 IF(P(IC,5).GT.PARU(58)) THEN
75113 C...Find initiator cell: the one with highest pT of not yet used ones.
75117 IF(K(IC,5).NE.2) GOTO 160
75118 IF(P(IC,5).LE.ETMAX) GOTO 160
75124 IF(ETMAX.LT.PARU(52)) GOTO 220
75125 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
75126 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
75140 C...Sum up unused cells within required distance of initiator.
75142 IF(K(IC,5).EQ.0) GOTO 170
75143 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
75144 DPHIA=ABS(P(IC,2)-PHI)
75145 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
75147 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
75148 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
75150 K(NJ,4)=K(NJ,4)+K(IC,4)
75151 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
75152 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
75153 P(NJ,5)=P(NJ,5)+P(IC,5)
75156 C...Reject cluster below minimum ET, else accept.
75157 IF(P(NJ,5).LT.PARU(53)) THEN
75160 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
75162 ELSEIF(MSTU(54).LE.2) THEN
75163 P(NJ,3)=P(NJ,3)/P(NJ,5)
75164 P(NJ,4)=P(NJ,4)/P(NJ,5)
75165 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
75168 IF(K(IC,5).LT.0) K(IC,5)=0
75175 IF(K(IC,5).GE.0) GOTO 210
75176 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
75177 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
75178 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
75179 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
75185 C...Arrange clusters in falling ET sequence.
75186 220 DO 250 I=1,NJ-NC
75189 IF(K(IJ,5).EQ.0) GOTO 230
75190 IF(P(IJ,5).LT.ETMAX) GOTO 230
75198 K(N+I,4)=K(IJMAX,4)
75201 P(N+I,J)=P(IJMAX,J)
75207 C...Convert to massless or massive four-vectors.
75208 IF(MSTU(54).EQ.2) THEN
75209 DO 260 I=N+1,N+NJET
75211 P(I,1)=P(I,5)*COS(P(I,4))
75212 P(I,2)=P(I,5)*SIN(P(I,4))
75213 P(I,3)=P(I,5)*SINH(ETA)
75214 P(I,4)=P(I,5)*COSH(ETA)
75217 ELSEIF(MSTU(54).GE.3) THEN
75218 DO 270 I=N+1,N+NJET
75219 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
75223 C...Information about storage.
75227 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
75228 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
75233 C*********************************************************************
75236 C...Determines, approximately, the two jet masses that minimize
75237 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
75239 SUBROUTINE PYJMAS(PMH,PML)
75241 C...Double precision and integer declarations.
75242 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75243 IMPLICIT INTEGER(I-N)
75244 INTEGER PYK,PYCHGE,PYCOMP
75245 C...Parameter statement to help give large particle numbers.
75246 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75247 &KEXCIT=4000000,KDIMEN=5000000)
75249 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75250 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75251 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75252 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75254 DIMENSION SM(3,3),SAX(3),PS(3,5)
75267 PIMASS=PMAS(PYCOMP(211),1)
75269 C...Take copy of particles that are to be considered in mass analysis.
75271 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
75272 IF(MSTU(41).GE.2) THEN
75274 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75275 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75276 & K(I,2).EQ.KSUSY1+39) GOTO 170
75277 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75280 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
75281 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
75290 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
75291 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
75292 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
75294 C...Fill information in sphericity tensor and total momentum vector.
75297 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
75300 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
75302 PS(3,J)=PS(3,J)+P(N+NP,J)
75306 C...Very low multiplicities (0 or 1) not considered.
75308 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
75313 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
75316 C...Find largest eigenvalue to matrix (third degree equation).
75319 SM(J1,J2)=SM(J1,J2)/PSS
75322 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
75323 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
75324 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
75325 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
75326 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
75327 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
75328 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
75330 C...Find largest eigenvector by solving equation system.
75332 SM(J1,J1)=SM(J1,J1)-SMA
75334 SM(J2,J1)=SM(J1,J2)
75340 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
75343 SMAX=ABS(SM(J1,J2))
75347 DO 250 J3=JA+1,JA+2
75349 RL=SM(J1,JB)/SM(JA,JB)
75351 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
75352 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
75354 SMAX=ABS(SM(J1,J2))
75358 JB2=JB+2-3*((JB+1)/3)
75359 SAX(JB1)=-SM(JC,JB2)
75360 SAX(JB2)=SM(JC,JB1)
75361 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
75363 C...Divide particles into two initial clusters by hemisphere.
75365 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
75367 IF(PSAX.LT.0D0) IS=2
75370 PS(IS,J)=PS(IS,J)+P(I,J)
75373 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
75374 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
75376 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
75380 PS(3,J)=PS(1,J)-PS(2,J)
75383 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)
75384 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
75385 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
75386 IF(PMDI.LT.PMD) THEN
75392 C...Loop back if significant reduction in sum of m^2.
75393 IF(PMD.LT.-PARU(48)*PMS) THEN
75397 PS(IS,J)=PS(IS,J)-P(IM,J)
75398 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
75404 C...Final masses and output.
75407 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
75408 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
75409 PMH=MAX(PS(1,5),PS(2,5))
75410 PML=MIN(PS(1,5),PS(2,5))
75415 C*********************************************************************
75418 C...Calculates the first few Fox-Wolfram moments.
75420 SUBROUTINE PYFOWO(H10,H20,H30,H40)
75422 C...Double precision and integer declarations.
75423 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75424 IMPLICIT INTEGER(I-N)
75425 INTEGER PYK,PYCHGE,PYCOMP
75426 C...Parameter statement to help give large particle numbers.
75427 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75428 &KEXCIT=4000000,KDIMEN=5000000)
75430 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75431 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75432 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75433 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75435 C...Copy momenta for particles and calculate H0.
75440 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
75441 IF(MSTU(41).GE.2) THEN
75443 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75444 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75445 & K(I,2).EQ.KSUSY1+39) GOTO 110
75446 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75449 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
75450 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
75461 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
75467 C...Very low multiplicities (0 or 1) not considered.
75469 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
75477 C...Calculate H1 - H4.
75483 DO 120 I2=I1+1,N+NP
75484 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
75485 & (P(I1,4)*P(I2,4))
75486 H10=H10+P(I1,4)*P(I2,4)*CTHE
75487 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
75488 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
75489 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
75494 C...Calculate H1/H0 - H4/H0. Output.
75497 H10=(HD+2D0*H10)/H0
75498 H20=(HD+2D0*H20)/H0
75499 H30=(HD+2D0*H30)/H0
75500 H40=(HD+2D0*H40)/H0
75505 C*********************************************************************
75508 C...Evaluates various properties of an event, with statistics
75509 C...accumulated during the course of the run and
75510 C...printed at the end.
75512 SUBROUTINE PYTABU(MTABU)
75514 C...Double precision and integer declarations.
75515 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75516 IMPLICIT INTEGER(I-N)
75517 INTEGER PYK,PYCHGE,PYCOMP
75518 C...Parameter statement to help give large particle numbers.
75519 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75520 &KEXCIT=4000000,KDIMEN=5000000)
75522 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75523 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75524 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75525 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
75526 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
75527 C...Local arrays, character variables, saved variables and data.
75528 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
75529 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
75530 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
75531 &KFDM(8),KFDC(200,0:8),NPDC(200)
75532 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
75533 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
75534 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
75535 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
75536 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
75537 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
75538 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
75539 &NEVDC/0/,NKFDC/0/,NREDC/0/
75541 C...Reset statistics on initial parton state.
75542 IF(MTABU.EQ.10) THEN
75546 C...Identify and order flavour content of initial state.
75547 ELSEIF(MTABU.EQ.11) THEN
75549 KFM1=2*IABS(MSTU(161))
75550 IF(MSTU(161).GT.0) KFM1=KFM1-1
75551 KFM2=2*IABS(MSTU(162))
75552 IF(MSTU(162).GT.0) KFM2=KFM2-1
75553 KFMN=MIN(KFM1,KFM2)
75554 KFMX=MAX(KFM1,KFM2)
75556 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
75559 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
75560 & KFMX.LT.KFIS(I,2))) THEN
75566 110 IF(IKFIS.LT.0) THEN
75569 IF(NKFIS.GE.100) RETURN
75570 DO 130 I=NKFIS,IKFIS,-1
75571 KFIS(I+1,1)=KFIS(I,1)
75572 KFIS(I+1,2)=KFIS(I,2)
75574 NPIS(I+1,J)=NPIS(I,J)
75584 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
75586 C...Count number of partons in initial state.
75589 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
75590 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
75591 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
75596 IF(IM.LE.0.OR.IM.GT.N) THEN
75598 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
75600 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
75601 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
75611 IF(NP.GE.11) NPCO=8
75612 IF(NP.GE.16) NPCO=9
75613 IF(NP.GE.26) NPCO=10
75614 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
75617 C...Write statistics on initial parton state.
75618 ELSEIF(MTABU.EQ.12) THEN
75619 FAC=1D0/MAX(1,NEVIS)
75620 WRITE(MSTU(11),5000) NEVIS
75623 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
75625 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
75626 CALL PYNAME(KFM1,CHAU)
75628 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
75630 IF(KFIS(I,1).EQ.0) KFMX=0
75632 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
75633 CALL PYNAME(KFM2,CHAU)
75635 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
75636 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
75637 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
75640 C...Copy statistics on initial parton state into /PYJETS/.
75641 ELSEIF(MTABU.EQ.13) THEN
75642 FAC=1D0/MAX(1,NEVIS)
75645 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
75647 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
75649 IF(KFIS(I,1).EQ.0) KFMX=0
75651 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
75658 P(I,J)=FAC*NPIS(I,J)
75659 V(I,J)=FAC*NPIS(I,J+5)
75673 C...Reset statistics on number of particles/partons.
75674 ELSEIF(MTABU.EQ.20) THEN
75681 C...Identify whether particle/parton is primary or not.
75682 ELSEIF(MTABU.EQ.21) THEN
75686 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
75687 MSTU(62)=MSTU(62)+1
75690 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
75692 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
75694 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
75696 ELSEIF(KC.EQ.0) THEN
75697 ELSEIF(K(K(I,3),1).EQ.13) THEN
75699 IF(IM.LE.0.OR.IM.GT.N) THEN
75701 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
75704 ELSEIF(KCHG(KC,2).EQ.0) THEN
75705 KCM=PYCOMP(K(K(I,3),2))
75707 IF(KCHG(KCM,2).NE.0) MPRI=1
75710 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
75711 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
75713 IF(K(I,1).LE.10) THEN
75715 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
75718 C...Fill statistics on number of particles/partons in event.
75720 KFS=3-ISIGN(1,K(I,2))-MPRI
75722 IF(KFA.EQ.KFFS(IP)) THEN
75725 ELSEIF(KFA.LT.KFFS(IP)) THEN
75731 220 IF(IKFFS.LT.0) THEN
75734 IF(NKFFS.GE.400) RETURN
75735 DO 240 IP=NKFFS,IKFFS,-1
75736 KFFS(IP+1)=KFFS(IP)
75738 NPFS(IP+1,J)=NPFS(IP,J)
75747 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
75750 C...Write statistics on particle/parton composition of events.
75751 ELSEIF(MTABU.EQ.22) THEN
75752 FAC=1D0/MAX(1,NEVFS)
75753 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
75755 CALL PYNAME(KFFS(I),CHAU)
75758 IF(KC.NE.0) MDCYF=MDCY(KC,1)
75759 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
75760 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
75763 C...Copy particle/parton composition information into /PYJETS/.
75764 ELSEIF(MTABU.EQ.23) THEN
75765 FAC=1D0/MAX(1,NEVFS)
75771 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
75773 P(I,J)=FAC*NPFS(I,J)
75793 C...Reset factorial moments statistics.
75794 ELSEIF(MTABU.EQ.30) THEN
75800 FM1FM(IM,IB,IP)=0D0
75801 FM2FM(IM,IB,IP)=0D0
75806 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
75807 ELSEIF(MTABU.EQ.31) THEN
75812 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
75813 IF(MSTU(41).GE.2) THEN
75815 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75816 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75817 & K(I,2).EQ.KSUSY1+39) GOTO 410
75818 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
75819 & PYCHGE(K(I,2)).EQ.0) GOTO 410
75822 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
75823 IF(MSTU(42).GE.2) PMR=P(I,5)
75824 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
75825 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
75827 IF(ABS(YETA).GT.PARU(57)) GOTO 410
75828 PHI=PYANGL(P(I,1),P(I,2))
75829 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
75830 IYETA=MAX(0,MIN(511,IYETA))
75831 IPHI=512D0*(PHI+PARU(1))/PARU(2)
75832 IPHI=MAX(0,MIN(511,IPHI))
75835 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
75838 C...Order particles in (pseudo)rapidity and/or azimuth.
75839 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
75840 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
75844 IF(NUPP.EQ.NLOW+1) THEN
75849 DO 350 I1=NUPP-1,NLOW+1,-1
75850 IF(IYETA.GE.K(I1,1)) GOTO 360
75853 360 K(I1+1,1)=IYETA
75854 DO 370 I1=NUPP-1,NLOW+1,-1
75855 IF(IPHI.GE.K(I1,2)) GOTO 380
75859 DO 390 I1=NUPP-1,NLOW+1,-1
75860 IF(IYEP.GE.K(I1,3)) GOTO 400
75870 C...Calculate sum of factorial moments in event.
75878 IF(IM.LE.2) IBIN=2**(10-IB)
75879 IF(IM.EQ.3) IBIN=4**(10-IB)
75880 IAGR=K(NLOW+1,IM)/IBIN
75882 DO 440 I=NLOW+2,NUPP+1
75884 IF(ICUT.EQ.IAGR) THEN
75888 ELSEIF(NAGR.EQ.2) THEN
75889 FEVFM(IB,1)=FEVFM(IB,1)+2D0
75890 ELSEIF(NAGR.EQ.3) THEN
75891 FEVFM(IB,1)=FEVFM(IB,1)+6D0
75892 FEVFM(IB,2)=FEVFM(IB,2)+6D0
75893 ELSEIF(NAGR.EQ.4) THEN
75894 FEVFM(IB,1)=FEVFM(IB,1)+12D0
75895 FEVFM(IB,2)=FEVFM(IB,2)+24D0
75896 FEVFM(IB,3)=FEVFM(IB,3)+24D0
75898 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
75899 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
75900 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
75902 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
75903 & (NAGR-3D0)*(NAGR-4D0)
75911 C...Add results to total statistics.
75914 IF(FEVFM(1,IP).LT.0.5D0) THEN
75916 ELSEIF(IM.LE.2) THEN
75917 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
75919 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
75921 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
75922 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
75926 NMUFM=NMUFM+(NUPP-NLOW)
75929 C...Write accumulated statistics on factorial moments.
75930 ELSEIF(MTABU.EQ.32) THEN
75931 FAC=1D0/MAX(1,NEVFM)
75932 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
75933 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
75934 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
75936 WRITE(MSTU(11),5500)
75939 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
75941 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
75942 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
75943 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
75945 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
75946 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
75949 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
75954 C...Copy statistics on factorial moments into /PYJETS/.
75955 ELSEIF(MTABU.EQ.33) THEN
75956 FAC=1D0/MAX(1,NEVFM)
75963 IF(IM.NE.2) K(I,3)=2**(IB-1)
75965 IF(IM.NE.1) K(I,4)=2**(IB-1)
75967 P(I,1)=2D0*PARU(57)/K(I,3)
75968 V(I,1)=PARU(2)/K(I,4)
75970 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
75971 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
75987 C...Reset statistics on Energy-Energy Correlation.
75988 ELSEIF(MTABU.EQ.40) THEN
75999 C...Find particles to include, with proper assumed mass.
76000 ELSEIF(MTABU.EQ.41) THEN
76006 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
76007 IF(MSTU(41).GE.2) THEN
76009 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76010 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76011 & K(I,2).EQ.KSUSY1+39) GOTO 570
76012 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
76013 & PYCHGE(K(I,2)).EQ.0) GOTO 570
76016 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
76017 IF(MSTU(42).GE.2) PMR=P(I,5)
76018 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
76019 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
76026 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
76027 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
76030 IF(NUPP.EQ.NLOW) RETURN
76032 C...Analyze Energy-Energy Correlation in event.
76033 FAC=(2D0/ECM**2)*50D0/PARU(1)
76037 DO 600 I1=NLOW+2,NUPP
76038 DO 590 I2=NLOW+1,I1-1
76039 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
76040 & (P(I1,5)*P(I2,5))
76041 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
76042 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
76043 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
76047 FE1EC(J)=FE1EC(J)+FEVEE(J)
76048 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
76049 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
76050 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
76051 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
76052 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
76056 C...Write statistics on Energy-Energy Correlation.
76057 ELSEIF(MTABU.EQ.42) THEN
76058 FAC=1D0/MAX(1,NEVEE)
76059 WRITE(MSTU(11),5700) NEVEE
76062 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
76063 FEEC2=FAC*FE1EC(51-J)
76064 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
76066 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
76067 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
76068 & FEEC2,FEES2,FEECA,FEESA
76071 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
76072 ELSEIF(MTABU.EQ.43) THEN
76073 FAC=1D0/MAX(1,NEVEE)
76080 P(I,1)=FAC*FE1EC(I)
76081 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
76082 P(I,2)=FAC*FE1EC(51-I)
76083 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
76084 P(I,3)=FAC*FE1EA(I)
76085 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
76086 P(I,4)=PARU(1)*(I-1)/50D0
76087 P(I,5)=PARU(1)*I/50D0
76102 C...Reset statistics on decay channels.
76103 ELSEIF(MTABU.EQ.50) THEN
76108 C...Identify and order flavour content of final state.
76109 ELSEIF(MTABU.EQ.51) THEN
76113 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
76120 IF(K(I,2).LT.0) KFM=KFM-1
76121 DO 650 IDS=NDS-1,1,-1
76123 IF(KFM.LT.KFDM(IDS)) GOTO 660
76124 KFDM(IDS+1)=KFDM(IDS)
76130 C...Find whether old or new final state.
76132 IF(NDS.LT.KFDC(IDC,0)) THEN
76135 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
76137 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
76140 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
76149 700 IF(IKFDC.LT.0) THEN
76151 ELSEIF(NKFDC.GE.200) THEN
76155 DO 720 IDC=NKFDC,IKFDC,-1
76156 NPDC(IDC+1)=NPDC(IDC)
76158 KFDC(IDC+1,I)=KFDC(IDC,I)
76164 KFDC(IKFDC,I)=KFDM(I)
76168 NPDC(IKFDC)=NPDC(IKFDC)+1
76170 C...Write statistics on decay channels.
76171 ELSEIF(MTABU.EQ.52) THEN
76172 FAC=1D0/MAX(1,NEVDC)
76173 WRITE(MSTU(11),5900) NEVDC
76175 DO 740 I=1,KFDC(IDC,0)
76178 IF(2*KF.NE.KFM) KF=-KF
76179 CALL PYNAME(KF,CHAU)
76181 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
76183 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
76185 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
76187 C...Copy statistics on decay channels into /PYJETS/.
76188 ELSEIF(MTABU.EQ.53) THEN
76189 FAC=1D0/MAX(1,NEVDC)
76195 K(IDC,5)=KFDC(IDC,0)
76200 DO 770 I=1,KFDC(IDC,0)
76203 IF(2*KF.NE.KFM) KF=-KF
76204 IF(I.LE.5) P(IDC,I)=KF
76205 IF(I.GE.6) V(IDC,I-5)=KF
76207 V(IDC,5)=FAC*NPDC(IDC)
76222 C...Format statements for output on unit MSTU(11) (default 6).
76223 5000 FORMAT(///20X,'Event statistics - initial state'/
76224 &20X,'based on an analysis of ',I6,' events'//
76225 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
76226 &'according to fragmenting system multiplicity'/
76227 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
76228 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
76229 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
76230 5200 FORMAT(///20X,'Event statistics - final state'/
76231 &20X,'based on an analysis of ',I7,' events'//
76232 &5X,'Mean primary multiplicity =',F10.4/
76233 &5X,'Mean final multiplicity =',F10.4/
76234 &5X,'Mean charged multiplicity =',F10.4//
76235 &5X,'Number of particles produced per event (directly and via ',
76236 &'decays/branchings)'/
76237 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
76238 &8X,'Total'/35X,'prim seco prim seco'/)
76239 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
76240 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
76241 &20X,'based on an analysis of ',I6,' events'//
76242 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
76243 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
76245 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
76246 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
76247 &20X,'based on an analysis of ',I6,' events'//
76248 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
76249 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
76250 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
76251 5900 FORMAT(///20X,'Decay channel analysis - final state'/
76252 &20X,'based on an analysis of ',I6,' events'//
76253 &2X,'Probability',10X,'Complete final state'/)
76254 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
76255 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
76256 &'or table overflow)')
76261 C*********************************************************************
76264 C...Handles the generation of an e+e- annihilation jet event.
76266 SUBROUTINE PYEEVT(KFL,ECM)
76268 C...Double precision and integer declarations.
76269 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76270 IMPLICIT INTEGER(I-N)
76271 INTEGER PYK,PYCHGE,PYCOMP
76273 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76274 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76275 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76276 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76278 C...Check input parameters.
76279 IF(MSTU(12).NE.12345) CALL PYLIST(0)
76280 IF(KFL.LT.0.OR.KFL.GT.8) THEN
76281 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
76282 IF(MSTU(21).GE.1) RETURN
76284 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
76285 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
76286 IF(ECM.LT.ECMMIN) THEN
76287 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
76288 IF(MSTU(21).GE.1) RETURN
76291 C...Check consistency of MSTJ options set.
76292 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
76294 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
76297 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
76299 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
76303 C...Initialize alpha_strong and total cross-section.
76304 MSTU(111)=MSTJ(108)
76305 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
76307 PARU(112)=PARJ(121)
76308 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
76309 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
76310 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
76312 IF(MSTJ(116).GE.3) MSTJ(116)=1
76315 C...Add initial e+e- to event record (documentation only).
76318 IF(NTRY.GT.100) THEN
76319 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
76324 IF(MSTJ(115).GE.2) THEN
76326 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
76328 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
76332 C...Radiative photon (in initial state).
76335 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
76337 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
76338 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
76340 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
76341 K(NC,3)=MIN(MSTJ(115)/2,1)
76344 C...Virtual exchange boson (gamma or Z0).
76345 IF(MSTJ(115).GE.3) THEN
76348 IF(MSTJ(102).EQ.2) KF=23
76352 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
76358 C...Choice of flavour and jet configuration.
76359 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
76360 IF(KFLC.EQ.0) GOTO 100
76361 CALL PYXJET(ECMC,NJET,CUT)
76363 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
76365 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
76366 IF(NJET.EQ.2) MSTJ(120)=1
76368 C...Fill jet configuration and origin.
76369 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
76370 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
76372 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
76373 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
76374 &-KFLC,ECMC,X1,X2,X4,X12,X14)
76375 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
76376 &-KFLC,ECMC,X1,X2,X4,X12,X14)
76377 IF(MSTU(24).NE.0) GOTO 100
76379 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
76382 C...Angular orientation according to matrix element.
76383 IF(MSTJ(106).EQ.1) THEN
76384 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
76385 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
76386 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
76389 C...Rotation and boost from radiative photon.
76391 DBEK=-PAK/(ECM-PAK)
76392 NMIN=NC+1-MSTJ(115)/3
76393 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
76394 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
76395 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
76398 C...Generate parton shower. Rearrange along strings and check.
76399 IF(MSTJ(101).EQ.5) THEN
76400 CALL PYSHOW(N-1,N,ECMC)
76402 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
76403 IF(MSTJ(105).GE.0) MSTU(28)=0
76406 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
76409 C...Fragmentation/decay generation. Information for PYTABU.
76410 IF(MSTJ(105).EQ.1) CALL PYEXEC
76417 C*********************************************************************
76420 C...Calculates total cross-section, including initial state
76421 C...radiation effects.
76423 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
76425 C...Double precision and integer declarations.
76426 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76427 IMPLICIT INTEGER(I-N)
76428 INTEGER PYK,PYCHGE,PYCOMP
76430 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76431 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76432 SAVE /PYDAT1/,/PYDAT2/
76434 C...Status, (optimized) Q^2 scale, alpha_strong.
76436 MSTJ(119)=10*MSTJ(102)+KFL
76437 IF(MSTJ(111).EQ.0) THEN
76439 ELSEIF(MSTU(111).EQ.0) THEN
76440 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
76441 & ((33D0-2D0*MSTU(112))*PARU(111)))))
76442 Q2R=PARJ(168)*ECM**2
76444 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
76445 & (2D0*PARU(112)/ECM)**2))
76446 Q2R=PARJ(168)*ECM**2
76448 ALSPI=PYALPS(Q2R)/PARU(1)
76450 C...QCD corrections factor in R.
76451 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
76453 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
76455 ELSEIF(MSTJ(109).EQ.0) THEN
76456 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
76457 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
76458 & LOG(PARJ(168))*ALSPI**2)
76459 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
76460 RQCD=1D0+(3D0/4D0)*ALSPI
76462 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
76465 C...Calculate Z0 width if default value not acceptable.
76466 IF(MSTJ(102).GE.3) THEN
76467 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
76468 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
76471 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
76472 & (2D0*PYMASS(KFLC)/ ECM)**2))
76473 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
76474 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
76475 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
76477 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
76481 C...Calculate propagator and related constants for QFD case.
76482 POLL=1D0-PARJ(131)*PARJ(132)
76483 IF(MSTJ(102).GE.2) THEN
76484 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
76485 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
76486 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
76487 VE=4D0*PARU(102)-1D0
76488 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
76489 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
76494 C...Loop over different flavours: charge, velocity.
76499 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
76500 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
76503 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
76504 QF=KCHG(KFLC,1)/3D0
76506 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
76508 C...Calculate R and sum of charges for QED or QFD case.
76509 RQQ=RQQ+3D0*QF**2*POLL
76510 IF(MSTJ(102).LE.1) THEN
76511 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
76513 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
76514 RQV=RQV-6D0*QF*VF*SF1I
76515 RVA=RVA+3D0*(VF**2+1D0)*SF1W
76516 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
76517 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
76521 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
76523 C...Calculate cross-section, including QCD corrections.
76526 PARJ(143)=RTOT*RQCD
76527 PARJ(144)=PARJ(143)
76528 PARJ(145)=PARJ(141)*86.8D0/ECM**2
76529 PARJ(146)=PARJ(142)*86.8D0/ECM**2
76530 PARJ(147)=PARJ(143)*86.8D0/ECM**2
76531 PARJ(148)=PARJ(147)
76532 PARJ(157)=RSUM*RQCD
76536 IF(MSTJ(107).LE.0) RETURN
76538 C...Virtual cross-section.
76540 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
76541 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
76542 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
76543 &1.526D0*LOG(ECM**2/0.932D0)
76545 C...Soft and hard radiative cross-section in QED case.
76546 IF(MSTJ(102).LE.1) THEN
76547 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
76548 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
76549 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
76551 C...Soft and hard radiative cross-section in QFD case.
76553 SZM=1D0-(PARJ(123)/ECM)**2
76554 SZW=PARJ(123)*PARJ(124)/ECM**2
76555 PARJ(161)=-RQQ/RSUM
76556 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
76557 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
76558 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
76559 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
76560 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
76561 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
76562 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
76563 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
76564 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
76565 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
76566 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
76567 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
76568 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
76571 C...Total cross-section and fraction of hard photon events.
76572 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
76573 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
76574 PARJ(144)=PARJ(157)
76575 PARJ(148)=PARJ(144)*86.8D0/ECM**2
76581 C*********************************************************************
76584 C...Generates initial state photon radiation.
76586 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
76588 C...Double precision and integer declarations.
76589 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76590 IMPLICIT INTEGER(I-N)
76591 INTEGER PYK,PYCHGE,PYCOMP
76593 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76596 C...Function: cumulative hard photon spectrum in QFD case.
76597 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
76598 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
76600 C...Determine whether radiative photon or not.
76603 IF(PARJ(160).LT.PYR(0)) RETURN
76606 C...Photon energy range. Find photon momentum in QED case.
76608 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
76609 IF(MSTJ(102).LE.1) THEN
76610 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
76611 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
76613 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
76615 SZM=1D0-(PARJ(123)/ECM)**2
76616 SZW=PARJ(123)*PARJ(124)/ECM**2
76619 FXKD=1D-4*(FXKU-FXKL)
76620 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
76625 IF(FXKV.GT.FXKR) THEN
76632 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
76633 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
76637 C...Photon polar and azimuthal angle.
76638 PME=2D0*(PYMASS(11)/ECM)**2
76639 120 CTHM=PME*(2D0/PME)**PYR(0)
76640 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
76641 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
76643 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
76644 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
76645 THEK=PYANGL(CTHE,STHE)
76646 PHIK=PARU(2)*PYR(0)
76648 C...Rotation angle for hadronic system.
76650 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
76652 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
76653 &(2D0-XK*(1D0-SGN*CTHE)))
76658 C*********************************************************************
76661 C...Selects flavour for produced qqbar pair.
76663 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
76665 C...Double precision and integer declarations.
76666 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76667 IMPLICIT INTEGER(I-N)
76668 INTEGER PYK,PYCHGE,PYCOMP
76670 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76671 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76672 SAVE /PYDAT1/,/PYDAT2/
76674 C...Calculate maximum weight in QED or QFD case.
76675 IF(MSTJ(102).LE.1) THEN
76678 POLL=1D0-PARJ(131)*PARJ(132)
76679 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
76680 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
76681 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
76682 VE=4D0*PARU(102)-1D0
76683 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
76684 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
76685 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
76686 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
76687 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
76691 C...Choose flavour. Gives charge and velocity.
76694 IF(NTRY.GT.100) THEN
76695 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
76700 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
76703 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
76704 QF=KCHG(KFLC,1)/3D0
76706 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
76708 C...Calculate weight in QED or QFD case.
76709 IF(MSTJ(102).LE.1) THEN
76711 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
76713 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
76714 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
76715 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
76717 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
76720 C...Weighting or new event (radiative photon). Cross-section update.
76721 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
76722 PARJ(158)=PARJ(158)+1D0
76723 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
76724 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
76725 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
76726 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
76727 PARJ(148)=PARJ(144)*86.8D0/ECM**2
76732 C*********************************************************************
76735 C...Selects number of jets in matrix element approach.
76737 SUBROUTINE PYXJET(ECM,NJET,CUT)
76739 C...Double precision and integer declarations.
76740 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76741 IMPLICIT INTEGER(I-N)
76742 INTEGER PYK,PYCHGE,PYCOMP
76744 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76746 C...Local array and data.
76748 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
76750 C...Trivial result for two-jets only, including parton shower.
76751 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
76754 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
76755 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
76757 IF(MSTJ(109).EQ.2) CF=1D0
76758 IF(MSTJ(111).EQ.0) THEN
76761 ELSEIF(MSTU(111).EQ.0) THEN
76762 PARJ(169)=MIN(1D0,PARJ(129))
76763 Q2=PARJ(169)*ECM**2
76764 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
76765 & ((33D0-2D0*MSTU(112))*PARU(111)))))
76766 Q2R=PARJ(168)*ECM**2
76768 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
76769 Q2=PARJ(169)*ECM**2
76770 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
76771 & (2D0*PARU(112)/ECM)**2))
76772 Q2R=PARJ(168)*ECM**2
76775 C...alpha_strong for R and R itself.
76776 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
76777 IF(IABS(MSTJ(101)).EQ.1) THEN
76779 ELSEIF(MSTJ(109).EQ.0) THEN
76780 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
76781 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
76782 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
76784 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
76787 C...alpha_strong for jet rate. Initial value for y cut.
76788 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76789 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
76790 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
76791 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
76792 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
76794 C...Parametrization of first order three-jet cross-section.
76795 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
76798 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
76799 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
76800 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
76801 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
76802 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
76806 C...Parametrization of second order three-jet cross-section.
76807 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
76808 & CUT.GE.0.25D0) THEN
76810 ELSEIF(MSTJ(110).LE.1) THEN
76811 CT=LOG(1D0/CUT-2D0)
76812 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
76813 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
76815 C...Interpolation in second/first order ratio for Zhu parametrization.
76816 ELSEIF(MSTJ(110).EQ.2) THEN
76819 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
76825 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
76827 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
76830 C...Shift in second order three-jet cross-section with optimized Q^2.
76831 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
76832 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
76833 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
76835 C...Parametrization of second order four-jet cross-section.
76836 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
76839 CT=LOG(1D0/CUT-5D0)
76840 IF(CUT.LE.0.018D0) THEN
76841 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
76842 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
76844 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
76845 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
76847 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
76848 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
76849 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
76850 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
76851 & 0.002093D0*CT**3)
76852 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
76854 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
76855 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
76858 C...If negative three-jet rate, change y' optimization parameter.
76859 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
76860 & PARJ(169).LT.0.99D0) THEN
76861 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
76862 Q2=PARJ(169)*ECM**2
76863 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76867 C...If too high cross-section, use harder cuts, or fail.
76868 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
76869 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
76870 & PARJ(169).LT.0.99D0) THEN
76871 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
76872 Q2=PARJ(169)*ECM**2
76873 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76875 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
76877 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
76879 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
76880 & PARJ(154))**(-1D0/3D0)
76881 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
76885 C...Scalar gluon (first order only).
76887 ALSPI=PYALPS(ECM**2)/PARU(1)
76888 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
76890 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
76891 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
76896 C...Select number of jets.
76898 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
76900 ELSEIF(MSTJ(101).LE.0) THEN
76901 NJET=MIN(4,2-MSTJ(101))
76905 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
76906 IF(PARJ(154).GT.RNJ) NJET=4
76912 C*********************************************************************
76915 C...Selects the kinematical variables of three-jet events.
76917 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
76919 C...Double precision and integer declarations.
76920 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76921 IMPLICIT INTEGER(I-N)
76922 INTEGER PYK,PYCHGE,PYCOMP
76924 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76927 DIMENSION ZHUP(5,12)
76929 C...Coefficients of Zhu second order parametrization.
76930 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
76931 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
76932 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
76933 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
76934 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
76935 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
76936 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
76937 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
76938 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
76939 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
76940 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
76942 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
76943 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
76946 C...Event type. Mass effect factors and other common constants.
76950 QME=(2D0*PMQ/ECM)**2
76951 IF(MSTJ(109).NE.1) THEN
76953 CUTD=LOG(1D0/CUT-2D0)
76954 IF(MSTJ(109).EQ.0) THEN
76958 WTMX=MIN(20D0,37D0-6D0*CUTD)
76959 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
76967 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
76968 ALS2PI=PARU(118)/PARU(2)
76970 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
76971 & LOG(PARJ(169))*ALS2PI
76972 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
76974 C...Choose three-jet events in allowed region.
76976 110 Y13L=CUTL+CUTD*PYR(0)
76977 Y23L=CUTL+CUTD*PYR(0)
76981 IF(Y12.LE.CUT) GOTO 110
76982 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
76984 C...Second order corrections.
76985 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
76990 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
76991 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
76992 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
76993 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
76994 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
76995 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
76996 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
76997 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
76998 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
76999 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
77000 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
77001 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
77002 & TR*(2D0*CUTL/3D0-10D0/9D0)+
77003 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
77004 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
77005 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
77006 & Y13*Y23)/(Y12+Y13)**2)/WT1+
77007 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
77008 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
77009 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
77010 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
77011 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
77012 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
77013 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
77014 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
77015 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
77016 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
77018 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
77019 C...Second order corrections; Zhu parametrization of ERT.
77024 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
77028 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77029 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77030 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77031 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77034 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77035 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77036 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77037 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77039 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77040 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77041 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77042 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77043 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
77045 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
77046 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
77047 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
77050 C...Impose mass cuts (gives two jets). For fixed jet number new try.
77054 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
77055 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
77056 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
77057 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
77058 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
77060 C...Scalar gluon model (first order only, no mass effects).
77063 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
77064 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
77065 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
77066 X1=1D0-0.5D0*(X3+YD)
77067 X2=1D0-0.5D0*(X3-YD)
77068 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
77069 IF(MSTJ(102).GE.2) THEN
77070 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
77071 & X3**2*PYR(0)) NJET=2
77073 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
77079 C*********************************************************************
77082 C...Selects the kinematical variables of four-jet events.
77084 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
77086 C...Double precision and integer declarations.
77087 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77088 IMPLICIT INTEGER(I-N)
77089 INTEGER PYK,PYCHGE,PYCOMP
77091 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77094 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
77096 C...Common constants. Colour factors for QCD and Abelian gluon theory.
77098 QME=(2D0*PMQ/ECM)**2
77099 CT=LOG(1D0/CUT-5D0)
77100 IF(MSTJ(109).EQ.0) THEN
77110 C...Choice of process (qqbargg or qqbarqqbar).
77113 IF(PARJ(155).GT.PYR(0)) IT=2
77114 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
77115 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
77116 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
77117 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
77120 C...Sample the five kinematical variables (for qqgg preweighted in y34).
77121 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
77122 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
77123 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
77124 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
77125 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
77127 CP=COS(PARU(1)*PYR(0))
77130 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
77131 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
77132 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
77134 Y12=1D0-Y134-Y23-Y24
77135 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
77139 C...Calculate matrix elements for qqgg or qqqq process.
77144 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
77145 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
77146 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
77147 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
77148 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
77149 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
77150 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
77151 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
77152 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
77153 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
77154 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
77155 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
77156 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
77157 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
77158 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
77159 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
77160 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
77161 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
77162 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
77163 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
77164 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
77165 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
77166 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
77167 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
77168 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
77169 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
77170 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
77171 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
77172 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
77173 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
77174 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
77175 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
77176 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
77177 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
77178 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
77179 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
77180 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
77181 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
77182 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
77183 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
77184 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
77187 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
77188 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
77189 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
77190 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
77191 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
77192 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
77193 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
77194 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
77195 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
77196 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
77197 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
77198 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
77199 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
77200 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
77201 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
77202 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
77203 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
77204 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
77207 C...Permutations of momenta in matrix element. Weighting.
77208 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
77219 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
77230 IF(IC.LE.3) GOTO 120
77231 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
77234 C...qqgg events: string configuration and event type.
77236 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
77237 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
77238 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
77239 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
77240 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
77241 IF(ID.EQ.2) GOTO 130
77242 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
77243 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
77244 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
77245 IF(ID.EQ.2) GOTO 130
77248 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
77249 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
77252 C...Mass cuts. Kinematical variables out.
77253 IF(Y12.LE.CUT+QME) NJET=2
77254 IF(NJET.EQ.2) GOTO 150
77255 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
77256 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
77257 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
77259 X12=(1D0-Q12)*Y13+Q12*Y23
77261 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
77263 C...qqbarqqbar events: string configuration, choose new flavour.
77266 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
77267 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
77268 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
77269 IF(WTR.LT.WTD(4)) ID=4
77270 IF(ID.GE.2) GOTO 130
77273 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
77274 140 KFLN=1+INT(5D0*PYR(0))
77275 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
77276 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
77277 IF(KFLN.GT.MSTJ(104)) NJET=2
77279 QMEN=(2D0*PMQN/ECM)**2
77281 C...Mass cuts. Kinematical variables out.
77282 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
77283 IF(NJET.EQ.2) GOTO 150
77284 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
77285 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
77286 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
77287 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
77288 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
77289 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
77292 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
77294 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
77295 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
77296 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
77298 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
77303 C*********************************************************************
77306 C...Gives the angular orientation of events.
77308 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
77310 C...Double precision and integer declarations.
77311 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77312 IMPLICIT INTEGER(I-N)
77313 INTEGER PYK,PYCHGE,PYCOMP
77315 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77316 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77317 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77318 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77320 C...Charge. Factors depending on polarization for QED case.
77322 POLL=1D0-PARJ(131)*PARJ(132)
77323 POLD=PARJ(132)-PARJ(131)
77324 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
77330 C...Factors depending on flavour, energy and polarization for QFD case.
77332 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
77333 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
77334 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
77336 VE=4D0*PARU(102)-1D0
77338 VF=AF-4D0*QF*PARU(102)
77339 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
77340 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
77341 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
77342 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
77343 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
77344 & SFW*SFF**2*(VE**2-AE**2))
77345 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
77349 C...Mass factor. Differential cross-sections for two-jet events.
77352 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
77353 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
77355 SIGU=4D0*SQRT(1D0-QME)
77356 SIGL=2D0*QME*SQRT(1D0-QME)
77362 C...Kinematical variables. Reduce four-jet event to three-jet one.
77365 X1=2D0*P(NC+1,4)/ECM
77366 X2=2D0*P(NC+3,4)/ECM
77368 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
77369 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
77370 X1=2D0*P(NC+1,4)/ECMR
77371 X2=2D0*P(NC+4,4)/ECMR
77374 C...Differential cross-sections for three-jet (or reduced four-jet).
77375 XQ=(1D0-X1)/(1D0-X2)
77376 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
77377 ST12=SQRT(1D0-CT12**2)
77378 IF(MSTJ(109).NE.1) THEN
77379 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
77380 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
77381 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
77382 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
77384 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
77385 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
77386 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
77387 SIGA=X2**2*ST12/SQ2
77388 SIGP=2D0*(X1**2-X2**2*CT12)
77390 C...Differential cross-sect for scalar gluons (no mass effects).
77394 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
77395 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
77396 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
77397 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
77398 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
77399 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
77400 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
77401 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
77402 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
77403 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
77404 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
77408 C...Upper bounds for differential cross-section.
77413 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
77414 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
77415 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
77416 &2D0*HF2A*ABS(SIGP)
77418 C...Generate angular orientation according to differential cross-sect.
77419 100 CHI=PARU(2)*PYR(0)
77420 CTHE=2D0*PYR(0)-1D0
77428 C2PHI=COS(2D0*(PHI-PARJ(134)))
77429 S2PHI=SIN(2D0*(PHI-PARJ(134)))
77430 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
77431 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
77432 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
77433 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
77434 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
77435 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
77436 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
77437 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
77442 C*********************************************************************
77445 C...Generates Upsilon and toponium decays into three gluons
77446 C...or two gluons and a photon.
77448 SUBROUTINE PYONIA(KFL,ECM)
77450 C...Double precision and integer declarations.
77451 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77452 IMPLICIT INTEGER(I-N)
77453 INTEGER PYK,PYCHGE,PYCOMP
77455 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77456 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77457 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77458 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77460 C...Printout. Check input parameters.
77461 IF(MSTU(12).NE.12345) CALL PYLIST(0)
77462 IF(KFL.LT.0.OR.KFL.GT.8) THEN
77463 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
77464 IF(MSTU(21).GE.1) RETURN
77466 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
77467 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
77468 IF(MSTU(21).GE.1) RETURN
77471 C...Initial e+e- and onium state (optional).
77473 IF(MSTJ(115).GE.2) THEN
77475 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
77477 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
77481 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
77487 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
77493 C...Choose x1 and x2 according to matrix element.
77498 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
77499 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
77502 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
77503 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
77505 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
77506 MSTU(111)=MSTJ(108)
77507 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
77509 PARU(112)=PARJ(121)
77510 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
77512 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
77513 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
77516 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
77517 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
77519 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
77520 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
77523 ECMC=SQRT(1D0-X1)*ECM
77524 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
77529 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
77530 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
77531 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
77532 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
77534 IF(ECMC.LT.4D0*PARJ(127)) THEN
77538 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
77544 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
77547 C...Differential cross-sections. Upper limit for cross-section.
77548 IF(MSTJ(106).EQ.1) THEN
77550 HF1=1D0-PARJ(131)*PARJ(132)
77552 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
77553 ST13=SQRT(1D0-CT13**2)
77554 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
77555 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
77557 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
77558 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
77559 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
77561 C...Angular orientation of event.
77562 120 CHI=PARU(2)*PYR(0)
77563 CTHE=2D0*PYR(0)-1D0
77571 C2PHI=COS(2D0*(PHI-PARJ(134)))
77572 S2PHI=SIN(2D0*(PHI-PARJ(134)))
77573 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
77574 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
77575 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
77576 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
77577 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
77578 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
77579 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
77580 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
77583 C...Generate parton shower. Rearrange along strings and check.
77584 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
77585 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
77587 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
77588 IF(MSTJ(105).GE.0) MSTU(28)=0
77591 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
77594 C...Generate fragmentation. Information for PYTABU:
77595 IF(MSTJ(105).EQ.1) CALL PYEXEC
77596 MSTU(161)=110*KFLC+3
77602 C*********************************************************************
77605 C...Books a histogram.
77607 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
77609 C...Double precision declaration.
77610 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77611 IMPLICIT INTEGER(I-N)
77613 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77615 C...Local character variables.
77616 CHARACTER TITLE*(*), TITFX*60
77618 C...Check that input is sensible. Find initial address in memory.
77619 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77620 &'(PYBOOK:) not allowed histogram number')
77621 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
77622 &'(PYBOOK:) not allowed number of bins')
77623 IF(XL.GE.XU) CALL PYERRM(28,
77624 &'(PYBOOK:) x limits in wrong order')
77626 IHIST(4)=IHIST(4)+28+NX
77627 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
77628 &'(PYBOOK:) out of histogram space')
77631 C...Store histogram size and reset contents.
77635 BIN(IS+4)=(XU-XL)/NX
77638 C...Store title by conversion to integer to double precision.
77641 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
77642 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
77648 C*********************************************************************
77651 C...Fills entry in histogram.
77653 SUBROUTINE PYFILL(ID,X,W)
77655 C...Double precision declaration.
77656 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77657 IMPLICIT INTEGER(I-N)
77659 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77662 C...Find initial address in memory. Increase number of entries.
77663 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77664 &'(PYFILL:) not allowed histogram number')
77666 IF(IS.EQ.0) CALL PYERRM(28,
77667 &'(PYFILL:) filling unbooked histogram')
77668 BIN(IS+5)=BIN(IS+5)+1D0
77670 C...Find bin in x, including under/overflow, and fill.
77671 IF(X.LT.BIN(IS+2)) THEN
77672 BIN(IS+6)=BIN(IS+6)+W
77673 ELSEIF(X.GE.BIN(IS+3)) THEN
77674 BIN(IS+8)=BIN(IS+8)+W
77676 BIN(IS+7)=BIN(IS+7)+W
77677 IX=(X-BIN(IS+2))/BIN(IS+4)
77678 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
77679 BIN(IS+9+IX)=BIN(IS+9+IX)+W
77685 C*********************************************************************
77688 C...Multiplies histogram contents by factor.
77690 SUBROUTINE PYFACT(ID,F)
77692 C...Double precision declaration.
77693 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77694 IMPLICIT INTEGER(I-N)
77696 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77699 C...Find initial address in memory. Multiply all contents bins.
77700 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77701 &'(PYFACT:) not allowed histogram number')
77703 IF(IS.EQ.0) CALL PYERRM(28,
77704 &'(PYFACT:) scaling unbooked histogram')
77705 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
77712 C*********************************************************************
77715 C...Performs operations between histograms.
77717 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
77719 C...Double precision declaration.
77720 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77721 IMPLICIT INTEGER(I-N)
77723 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77725 C...Character variable.
77728 C...Find initial addresses in memory, and histogram size.
77729 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
77730 &'(PYFACT:) not allowed histogram number')
77732 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
77733 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
77734 NX=NINT(BIN(IS3+1))
77735 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
77737 C...Update info on number of histogram entries.
77738 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
77739 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
77740 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
77741 BIN(IS3+5)=BIN(IS1+5)
77744 C...Operations on pair of histograms: addition, subtraction,
77745 C...multiplication, division.
77746 IF(OPER.EQ.'+') THEN
77748 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
77750 ELSEIF(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
77761 IF(ABS(FA2).LE.1D-20) THEN
77764 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
77768 C...Operations on single histogram: multiplication+addition,
77769 C...square root+addition, logarithm+addition.
77770 ELSEIF(OPER.EQ.'A') THEN
77772 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
77774 ELSEIF(OPER.EQ.'S') THEN
77776 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
77778 ELSEIF(OPER.EQ.'L') THEN
77781 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
77782 & ZMIN=0.8D0*BIN(IS1+IX)
77785 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
77788 C...Operation on two or three histograms: average and
77789 C...standard deviation.
77790 ELSEIF(OPER.EQ.'M') THEN
77792 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
77795 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
77798 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
77801 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
77805 BIN(IS1+IX)=F1*BIN(IS1+IX)
77812 C*********************************************************************
77815 C...Prints and resets all histograms.
77819 C...Double precision declaration.
77820 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77821 IMPLICIT INTEGER(I-N)
77823 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77826 C...Loop over histograms, print and reset used ones.
77827 DO 100 ID=1,IHIST(1)
77829 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
77838 C*********************************************************************
77841 C...Prints a histogram (but does not reset it).
77843 SUBROUTINE PYPLOT(ID)
77845 C...Double precision declaration.
77846 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77847 IMPLICIT INTEGER(I-N)
77849 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77850 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77851 SAVE /PYDAT1/,/PYBINS/
77852 C...Local arrays and character variables.
77853 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
77854 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
77856 C...Steps in histogram scale. Character sequence.
77857 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
77858 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
77860 C...Find initial address in memory; skip if empty histogram.
77861 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
77864 IF(NINT(BIN(IS+5)).LE.0) THEN
77865 WRITE(MSTU(11),5000) ID
77869 C...Number of histogram lines and x bins.
77873 C...Extract title by conversion from double precision via integer.
77875 IEQ=NINT(BIN(IS+8+NX+IT))
77876 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
77877 & //CHAR(MOD(IEQ,256))
77880 C...Find time; print title.
77882 IF(IDATI(1).GT.0) THEN
77883 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
77885 WRITE(MSTU(11),5200) ID, TITLE
77888 C...Find minimum and maximum bin content.
77891 DO 110 IX=IS+10,IS+8+NX
77892 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
77893 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
77896 C...Determine scale and step size for y axis.
77897 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
77898 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
77899 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
77900 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
77901 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
77902 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
77905 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
77909 C...Convert bin contents to integer form; fractional fill in top row.
77911 CTA=ABS(BIN(IS+8+IX))/DY
77912 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
77913 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
77915 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
77916 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
77918 C...Print histogram row by row.
77919 DO 150 IR=IRMA,IRMI,-1
77920 IF(IR.EQ.0) GOTO 150
77923 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
77924 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
77926 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
77929 C...Print sign and value of bin contents.
77930 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
77933 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
77934 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
77936 WRITE(MSTU(11),5400) OUT
77939 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
77941 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
77944 C...Print sign and value of lower bin edge.
77945 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
77949 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
77950 & OUT(IX:IX)=CHA(11)
77951 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
77953 WRITE(MSTU(11),5600) OUT
77956 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
77958 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
77962 C...Calculate and print statistics.
77967 CTA=ABS(BIN(IS+8+IX))
77968 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
77971 CXXSUM=CXXSUM+CTA*X**2
77973 XMEAN=CXSUM/MAX(CSUM,1D-20)
77974 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
77975 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
77976 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
77978 C...Formats for output.
77979 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
77980 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
77982 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
77983 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
77984 5400 FORMAT(/8X,'Contents',3X,A100)
77985 5500 FORMAT(9X,'*10**',I2,3X,A100)
77986 5600 FORMAT(/8X,'Low edge',3X,A100)
77987 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
77988 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
77989 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
77994 C*********************************************************************
77997 C...Resets bin contents of a histogram.
77999 SUBROUTINE PYNULL(ID)
78001 C...Double precision declaration.
78002 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78003 IMPLICIT INTEGER(I-N)
78005 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
78008 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
78011 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
78018 C*********************************************************************
78021 C...Dumps histogram contents on file for reading by other program.
78022 C...Can also read back own dump.
78024 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
78026 C...Double precision declaration.
78027 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78028 IMPLICIT INTEGER(I-N)
78030 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
78032 C...Local arrays and character variables.
78033 DIMENSION IHI(*),ISS(100),VAL(5)
78034 CHARACTER TITLE*60,FORMAT*13
78036 C...Dump all histograms that have been booked,
78037 C...including titles and ranges, one after the other.
78038 IF(MDUMP.EQ.1) THEN
78040 C...Loop over histograms and find which are wanted and booked.
78055 C...Write title, histogram size, filling statistics.
78058 IEQ=NINT(BIN(IS+8+NX+IT))
78059 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
78060 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
78062 WRITE(LFN,5100) ID,TITLE
78063 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
78064 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
78068 C...Write histogram contents, in groups of five.
78069 DO 120 IXG=1,(NX+4)/5
78073 VAL(IXV)=BIN(IS+8+IX)
78078 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
78081 C...Go to next histogram; finish.
78082 ELSEIF(NHI.GT.0) THEN
78083 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
78087 C...Read back in histograms dumped MDUMP=1.
78088 ELSEIF(MDUMP.EQ.2) THEN
78090 C...Read histogram number, title and range, and book.
78091 140 READ(LFN,5100,END=170) ID,TITLE
78092 READ(LFN,5200) NX,XL,XU
78093 CALL PYBOOK(ID,TITLE,NX,XL,XU)
78096 C...Read filling statistics.
78097 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
78098 BIN(IS+5)=DBLE(NENTRY)
78100 C...Read histogram contents, in groups of five.
78101 DO 160 IXG=1,(NX+4)/5
78102 READ(LFN,5400) (VAL(IXV),IXV=1,5)
78105 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
78109 C...Go to next histogram; finish.
78113 C...Write histogram contents in column format,
78114 C...convenient e.g. for GNUPLOT input.
78115 ELSEIF(MDUMP.EQ.3) THEN
78117 C...Find addresses to wanted histograms.
78131 IF(IS.NE.0.AND.NSS.LT.100) THEN
78134 ELSEIF(NSS.GE.100) THEN
78135 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
78136 ELSEIF(NHI.GT.0) THEN
78137 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
78141 C...Check that they have common number of x bins. Fix format.
78142 NX=NINT(BIN(ISS(1)+1))
78144 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
78145 CALL PYERRM(8,'(PYDUMP:) different number of bins')
78149 FORMAT='(1P,000E12.4)'
78150 WRITE(FORMAT(5:7),'(I3)') NSS+1
78152 C...Write histogram contents; first column x values.
78154 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
78155 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
78160 C...Formats for output.
78161 5100 FORMAT(I5,5X,A60)
78162 5200 FORMAT(I5,1P,2D12.4)
78163 5300 FORMAT(I12,1P,3D12.4)
78164 5400 FORMAT(1P,5D12.4)
78169 C*********************************************************************
78172 C...Allows users to handle STOP statemens
78174 SUBROUTINE PYSTOP(MCOD)
78176 C...Double precision and integer declarations.
78177 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78178 IMPLICIT INTEGER(I-N)
78179 INTEGER PYK,PYCHGE,PYCOMP
78181 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78185 C...Write message, then stop
78186 WRITE(MSTU(11),5000) MCOD
78190 C...Formats for output.
78191 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
78194 C*********************************************************************
78197 C...Dummy routine, which the user can replace in order to make cuts on
78198 C...the kinematics on the parton level before the matrix elements are
78199 C...evaluated and the event is generated. The cross-section estimates
78200 C...will automatically take these cuts into account, so the given
78201 C...values are for the allowed phase space region only. MCUT=0 means
78202 C...that the event has passed the cuts, MCUT=1 that it has failed.
78204 SUBROUTINE PYKCUT(MCUT)
78206 C...Double precision and integer declarations.
78207 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78208 IMPLICIT INTEGER(I-N)
78209 INTEGER PYK,PYCHGE,PYCOMP
78211 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78212 COMMON/PYINT1/MINT(400),VINT(400)
78213 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
78214 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
78216 C...Set default value (accepting event) for MCUT.
78219 C...Read out subprocess number.
78223 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78227 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
78229 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
78231 C...Calculate x_1, x_2, x_F.
78232 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
78233 X1=SQRT(TAU)*EXP(YST)
78234 X2=SQRT(TAU)*EXP(-YST)
78236 X1=SQRT(TAUP)*EXP(YST)
78237 X2=SQRT(TAUP)*EXP(-YST)
78241 C...Calculate shat, that, uhat, p_T^2.
78247 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
78248 RPTS=4D0*VINT(71)**2/SHAT
78249 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
78252 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
78253 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
78254 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
78255 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
78257 C...Decisions by user to be put here.
78259 C...Stop program if this routine is ever called.
78260 C...You should not copy these lines to your own routine.
78261 WRITE(MSTU(11),5000)
78264 C...Format for error printout.
78265 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
78266 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78267 &1X,'Execution stopped!')
78272 C*********************************************************************
78275 C...Dummy routine, which the user can replace in order to multiply the
78276 C...standard PYTHIA differential cross-section by a process- and
78277 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
78278 C...to generation of weighted events, with weight 1/WTXS, while for
78279 C...MSTP(142)=2 it corresponds to a modification of the underlying
78282 SUBROUTINE PYEVWT(WTXS)
78284 C...Double precision and integer declarations.
78285 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78286 IMPLICIT INTEGER(I-N)
78287 INTEGER PYK,PYCHGE,PYCOMP
78289 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78290 COMMON/PYINT1/MINT(400),VINT(400)
78291 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
78292 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
78294 C...Set default weight for WTXS.
78297 C...Read out subprocess number.
78301 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78305 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
78307 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
78309 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
78318 C...Modifications by user to be put here.
78320 C...Stop program if this routine is ever called.
78321 C...You should not copy these lines to your own routine.
78322 WRITE(MSTU(11),5000)
78325 C...Format for error printout.
78326 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
78327 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78328 &1X,'Execution stopped!')
78333 C*********************************************************************
78336 C...Dummy routine, to be replaced by a user implementing external
78337 C...processes. Is supposed to fill the HEPRUP commonblock with info
78338 C...on incoming beams and allowed processes.
78340 C...New example: handles a standard Les Houches Events File.
78344 C...Double precision and integer declarations.
78345 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78346 IMPLICIT INTEGER(I-N)
78348 C...PYTHIA commonblock: only used to provide read unit MSTP(161).
78349 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78352 C...User process initialization commonblock.
78354 PARAMETER (MAXPUP=100)
78355 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78356 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78357 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78358 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78362 C...Lines to read in assumed never longer than 200 characters.
78363 PARAMETER (MAXLEN=200)
78364 CHARACTER*(MAXLEN) STRING
78366 C...Format for reading lines.
78369 WRITE(STRFMT(3:5),'(I3)') MAXLEN
78371 C...Loop until finds line beginning with "<init>" or "<init ".
78372 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
78375 C...Allow indentation.
78376 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
78377 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
78378 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
78380 C...Read first line of initialization info.
78381 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
78382 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78384 C...Read NPRUP subsequent lines with information on each process.
78386 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
78387 & XMAXUP(IPR),LPRUP(IPR)
78391 C...Error exit: give up if initalization does not work.
78392 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
78393 WRITE(*,*) ' Event generation will be stopped.'
78399 C...Old example: handles a simple Pythia 6.4 initialization file.
78401 c SUBROUTINE UPINIT
78403 C...Double precision and integer declarations.
78404 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78405 c IMPLICIT INTEGER(I-N)
78408 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78409 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78410 c SAVE /PYDAT1/,/PYPARS/
78412 C...User process initialization commonblock.
78414 c PARAMETER (MAXPUP=100)
78415 c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78416 c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78417 c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78418 c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78422 C...Read info from file.
78423 c IF(MSTP(161).GT.0) THEN
78424 c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
78425 c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78426 c DO 100 IPR=1,NPRUP
78427 c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
78428 c & XMAXUP(IPR),LPRUP(IPR)
78431 C...Error or prematurely reached end of file.
78432 c 110 WRITE(MSTU(11),5000)
78435 C...Else not implemented.
78437 c WRITE(MSTU(11),5100)
78441 C...Format for error printout.
78442 c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
78443 c &1X,'Execution stopped!')
78444 c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
78445 c &1X,'Dummy routine in PYTHIA file called instead.'/
78446 c &1X,'Execution stopped!')
78451 C*********************************************************************
78454 C...Dummy routine, to be replaced by a user implementing external
78455 C...processes. Depending on cross section model chosen, it either has
78456 C...to generate a process of the type IDPRUP requested, or pick a type
78457 C...itself and generate this event. The event is to be stored in the
78458 C...HEPEUP commonblock, including (often) an event weight.
78460 C...New example: handles a standard Les Houches Events File.
78464 C...Double precision and integer declarations.
78465 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78466 IMPLICIT INTEGER(I-N)
78468 C...PYTHIA commonblock: only used to provide read unit MSTP(162).
78469 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78472 C...User process event common block.
78474 PARAMETER (MAXNUP=500)
78475 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78476 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78477 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78478 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78479 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78482 C...Lines to read in assumed never longer than 200 characters.
78483 PARAMETER (MAXLEN=200)
78484 CHARACTER*(MAXLEN) STRING
78486 C...Format for reading lines.
78489 WRITE(STRFMT(3:5),'(I3)') MAXLEN
78491 C...Loop until finds line beginning with "<event>" or "<event ".
78492 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
78495 C...Allow indentation.
78496 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
78497 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
78498 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
78500 C...Read first line of event info.
78501 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
78504 C...Read NUP subsequent lines with information on each particle.
78506 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
78507 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78508 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78512 C...Error exit, typically when no more events.
78513 130 WRITE(*,*) ' Failed to read LHEF event information.'
78514 WRITE(*,*) ' Will assume end of file has been reached.'
78521 C...Old example: handles a simple Pythia 6.4 event file.
78523 c SUBROUTINE UPEVNT
78525 C...Double precision and integer declarations.
78526 c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78527 c IMPLICIT INTEGER(I-N)
78530 c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78531 c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78532 c SAVE /PYDAT1/,/PYPARS/
78534 C...User process event common block.
78536 c PARAMETER (MAXNUP=500)
78537 c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78538 c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78539 c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78540 c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78541 c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78544 C...Read info from file.
78545 c IF(MSTP(162).GT.0) THEN
78546 c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
78549 c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
78550 c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78551 c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78554 C...Special when reached end of file or other error.
78557 C...Else not implemented.
78559 c WRITE(MSTU(11),5000)
78563 C...Format for error printout.
78564 c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
78565 c &1X,'Dummy routine in PYTHIA file called instead.'/
78566 c &1X,'Execution stopped!')
78571 C*********************************************************************
78574 C...Dummy routine, to be replaced by user, to veto event generation
78575 C...on the parton level, after parton showers but before multiple
78576 C...interactions, beam remnants and hadronization is added.
78577 C...If resonances like W, Z, top, Higgs and SUSY particles are handed
78578 C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
78579 C...be undecayed at this stage; if decayed their decay products will
78580 C...have been allowed to shower.
78582 C...All partons at the end of the shower phase are stored in the
78583 C...HEPEVT commonblock. The interesting information is
78584 C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
78585 C...IDHEP(I) = the particle ID code according to PDG conventions,
78586 C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
78587 C...All ISTHEP entries are 1, while the rest is zeroed.
78589 C...The user decision is to be conveyed by the IVETO value.
78590 C...IVETO = 0 : retain current event and generate in full;
78591 C... = 1 : abort generation of current event and move to next.
78593 SUBROUTINE UPVETO(IVETO)
78595 C...HEPEVT commonblock.
78596 PARAMETER (NMXHEP=4000)
78597 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
78598 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
78599 DOUBLE PRECISION PHEP,VHEP
78602 C...Next few lines allow you to see what info PYVETO extracted from
78603 C...the full event record for the first two events.
78604 C...Delete if you don't want it.
78607 IF(NLIST.LE.2) THEN
78608 WRITE(*,*) ' Full event record at time of UPVETO call:'
78610 WRITE(*,*) ' Part of event record made available to UPVETO:'
78615 C...Make decision here.
78621 C*********************************************************************
78623 C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
78625 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
78626 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78627 IMPLICIT INTEGER(I-N)
78628 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
78631 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78634 C...Stop program if this routine is ever called.
78635 WRITE(MSTU(11),5000)
78638 C...Format for error printout.
78639 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78640 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
78641 &1X,'Execution stopped!')
78646 C*********************************************************************
78649 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78652 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78653 IMPLICIT INTEGER(I-N)
78654 CHARACTER*40 VISAJE
78657 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78660 C...Assign default value.
78663 C...Stop program if this routine is ever called.
78664 WRITE(MSTU(11),5000)
78667 C...Format for error printout.
78668 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78669 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
78670 &1X,'Execution stopped!')
78675 C*********************************************************************
78678 C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78680 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
78681 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
78682 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
78684 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78685 IMPLICIT INTEGER(I-N)
78686 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
78687 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
78688 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
78690 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78693 C...Stop program if this routine is ever called.
78694 WRITE(MSTU(11),5000)
78697 C...Format for error printout.
78698 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78699 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
78700 &1X,'Execution stopped!')
78704 C*********************************************************************
78707 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78709 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
78710 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78711 IMPLICIT INTEGER(I-N)
78712 Cmssmpart = 4 # full MSSM [recommended]
78713 Cfieldren = 0 # MSbar field ren. [strongly recommended]
78714 Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
78715 Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
78716 Cp2approx = 0 # no approximation [recommended]
78717 Clooplevel= 2 # include 2-loop corrections
78718 Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
78719 Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
78722 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78725 C...Stop program if this routine is ever called.
78726 WRITE(MSTU(11),5000)
78729 C...Format for error printout.
78730 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78731 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
78732 &1X,'Execution stopped!')
78736 C*********************************************************************
78739 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78741 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
78742 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
78743 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
78744 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
78745 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78746 IMPLICIT INTEGER(I-N)
78748 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78749 DOUBLE COMPLEX DMU,
78750 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78754 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78757 C...Stop program if this routine is ever called.
78758 WRITE(MSTU(11),5000)
78761 C...Format for error printout.
78762 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78763 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78764 &1X,'Execution stopped!')
78768 C*********************************************************************
78771 C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78773 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
78774 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78775 IMPLICIT INTEGER(I-N)
78777 C...FeynHiggs variables
78778 DOUBLE PRECISION RMHIGG(4)
78779 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78780 DOUBLE COMPLEX DMU,
78781 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78785 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78788 C...Stop program if this routine is ever called.
78789 WRITE(MSTU(11),5000)
78792 C...Format for error printout.
78793 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78794 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78795 &1X,'Execution stopped!')
78799 C*********************************************************************
78802 C...Dummy routine, to be replaced by user, to handle the decay of a
78803 C...polarized tau lepton.
78805 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
78806 C...IORIG is the position where the mother of the tau is stored;
78807 C... is 0 when the mother is not stored.
78808 C...KFORIG is the flavour of the mother of the tau;
78809 C... is 0 when the mother is not known.
78810 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
78811 C... e.g. in B hadron semileptonic decays the W propagator
78812 C... is not explicitly stored but the W code is still unambiguous.
78814 C...NDECAY is the number of decay products in the current tau decay.
78815 C...These decay products should be added to the /PYJETS/ common block,
78816 C...in positions N+1 through N+NDECAY. For each product I you must
78817 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
78818 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
78820 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
78822 C...Double precision and integer declarations.
78823 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78824 IMPLICIT INTEGER(I-N)
78825 INTEGER PYK,PYCHGE,PYCOMP
78827 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
78828 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78829 SAVE /PYJETS/,/PYDAT1/
78831 C...Stop program if this routine is ever called.
78832 C...You should not copy these lines to your own routine.
78833 NDECAY=ITAU+IORIG+KFORIG
78834 WRITE(MSTU(11),5000)
78837 C...Format for error printout.
78838 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
78839 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78840 &1X,'Execution stopped!')
78845 C*********************************************************************
78848 C...Finds current date and time.
78849 C...Since this task is not standardized in Fortran 77, the routine
78850 C...is dummy, to be replaced by the user. Examples are given for
78851 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
78852 C...you do not have access to suitable routines.
78854 SUBROUTINE PYTIME(IDATI)
78856 C...Double precision and integer declarations.
78857 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78858 IMPLICIT INTEGER(I-N)
78859 INTEGER PYK,PYCHGE,PYCOMP
78862 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
78864 C...Example 0: if you do not have suitable routines.
78869 C...Example 1: Fortran 90 routine.
78870 C CALL DATE_AND_TIME(VALUES=IVAL)
78878 C...Example 2: DEC Fortran 77. AIX.
78879 C CALL IDATE(IMON,IDAY,IYEAR)
78883 C CALL ITIME(IHOUR,IMIN,ISEC)
78888 C...Example 3: DEC Fortran, IRIX, IRIX64.
78889 C CALL IDATE(IMON,IDAY,IYEAR)
78897 C READ(ATIME(1:2),'(I2)') IHOUR
78898 C READ(ATIME(4:5),'(I2)') IMIN
78899 C READ(ATIME(7:8),'(I2)') ISEC
78904 C...Example 4: GNU LINUX libU77, SunOS.
78905 C CALL IDATE(IDTEMP)
78906 C IDATI(1)=IDTEMP(3)
78907 C IDATI(2)=IDTEMP(2)
78908 C IDATI(3)=IDTEMP(1)
78909 C CALL ITIME(IDTEMP)
78910 C IDATI(4)=IDTEMP(1)
78911 C IDATI(5)=IDTEMP(2)
78912 C IDATI(6)=IDTEMP(3)
78914 C...Common code to ensure right century.
78915 IDATI(1)=2000+MOD(IDATI(1),100)
78919 C... ALICE interface to PDFLIB with possibility to select nuclear structure
78922 C... The MSTP array in the PYPARS common block is used to enable and
78923 C... select the nuclear structure functions.
78924 C... MSTP(52) : (D=1) choice of proton and nuclear structure-function library
78925 C... =1: internal PYTHIA acording to MSTP(51)
78926 C... =2: PDFLIB proton s.f., with MSTP(51) = 1000xNGROUP+NSET
78927 C... MSTP( 51) = 1000xNPGROUP+NPSET
78928 C... MSTP(151) = 1000xNAGROUP+NASET
78929 C... MSTP(192) : Mass number of nucleus side 1
78930 C... MSTP(193) : Mass number of nucleus side 2
78933 C... MINT(124) : side (1 or 2)
78936 SUBROUTINE PDFSET_ALICE(PARM, VALUE)
78938 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78939 IMPLICIT INTEGER(I-N)
78940 C...Interface to PDFLIB.
78941 COMMON/LW50512/QCDL4,QCDL5
78943 DOUBLE PRECISION QCDL4,QCDL5
78944 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
78946 DOUBLE PRECISION XMIN,XMAX,Q2MIN,Q2MAX
78948 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78949 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78950 DOUBLE PRECISION VALUE(20)
78951 CHARACTER*20 PARM(20)
78952 write(6,*) MSTP(52)
78956 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
78960 VALUE(6)=MSTP(191)/1000
78962 VALUE(7)=MOD(MSTP(191),1000)
78963 CALL PDFSET(PARM,VALUE,
78964 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
78966 > XMIN,XMAX,Q2MIN,Q2MAX)
78967 IF (MSTP(194) .EQ. 0) THEN
78968 CALL SETLHAPARM("EKS98")
78970 CALL SETLHAPARM("EPS08")
78973 write(6,*) "-> pdfset"
78974 CALL PDFSET(PARM,VALUE,
78975 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
78977 > XMIN,XMAX,Q2MIN,Q2MAX)
78984 SUBROUTINE STRUCTM_ALICE
78985 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
78987 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78988 IMPLICIT INTEGER(I-N)
78989 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78990 COMMON/PYINT1/MINT(400),VINT(400)
78991 C write(6,*) "structm_alice->"
78992 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
78993 A=MSTP(191+MINT(124))
78994 C write(6,*) mint(124), "-> structa ", A
78995 CALL STRUCTA(XX,QQ,A,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
78997 C write(6,*) mint(124), "-> structm "
78998 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
git://git.uio.no / u / mrichter / AliRoot.git / blob